/pliant/appli/source_browser.pli
1	# Copyright  Patrice Ossona de Mendez
2	# Repackaged for new Pliant HTTP layout by Hubert Tonneau
3	#
4	# This program is free software; you can redistribute it and/or
5	# modify it under the terms of the GNU General Public License version 2
6	# as published by the Free Software Foundation.
7	#
8	# This program is distributed in the hope that it will be useful,
9	# but WITHOUT ANY WARRANTY; without even the implied warranty of
10	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11	# GNU General Public License for more details.
12	#
13	# You should have received a copy of the GNU General Public License
14	# version 2 along with this program; if not, write to the Free Software
15	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
16
17	module "/pliant/language/compiler.pli"
18	module "/pliant/language/stream.pli"
19	module "/pliant/util/encoding/html.pli"
20	module "/pliant/protocol/http/server.pli"
21
22
23	constant use_properties false
24
25	'pliant watch' Type false := "#C80096"
26	'pliant watch' Str false := "green"
27	'pliant watch' Char false := "green"
28	'pliant watch' InlineText false := "green"
29	'pliant watch' Function true := "black"
30	'pliant watch' Meta true := "black"
31	'pliant watch' GlobalVariable true := "#FF0000"
32	'pliant watch' LocalVariable true := "#C80032"
33
34	type Tag
35	field Char kind
36	field Pointer:Type key
37	field Str link
38
39	function apply t s -> s2
40	arg Tag t; arg Str s s2
41	var Str ss:=s
42	if t:kind="C"
43	var Str color := "#006446"
44	var Pointer:Str eff :> t:key 'pliant is_watched' false
45	if exists:eff
46	color := eff
47	ss := "<font color="+string:color+">"+ss+"</font>"
48	eif t:kind="A"
49	var Pointer:Str eff :> t:key 'pliant is_watched' true
50	if exists:eff
51	color := eff
52	ss := "<font color="+string:color+">"+ss+"</font>"
53	eif t:kind=" "
54	ss := replace (html_encode ss true) " " "&nbsp;"
55	eif t:kind="#"
56	if ss="#"+(repeat (max ss:len-1 3) "-")
57	ss := "<hr>"
58	else
59	ss := "<em><font color='blue'>"+(replace (html_encode ss true) " " "&nbsp;")+"</font></em>"
60	if t:link<>""
61	ss := "<a href="+t:link+"><b>"+ss+"</b></a>"
62	s2 := ss
63
64	method position decode filename line column
65	arg ListingPosition position; arg_w Str filename; arg_w Int line column
66	var Str s := cast position Str
67	if not (s eparse any:filename _ any:(var Str remain))
68	filename:=""; line:=0; column := 0
69	return
70	if not (remain parse line column)
71	remain parse any:(var Str dummy) line column
72
73	method fun 'get position' -> pos
74	oarg Function fun; arg ListingPosition pos
75	return fun:position
76
77	method met 'get position' -> pos
78	oarg Meta met; arg ListingPosition pos
79	var Link:Function fun :> addressof:met omap Function
80	return fun:position
81
82	method gv 'get position' -> pos
83	oarg GlobalVariable gv; arg ListingPosition pos
84	return gv:position
85
86	function fill_tags tags m
87	arg_rw (Link Array:(Dictionary Int Tag)) tags ; arg Module m
88	if not exists:m
89	return
90	var Link:Module mm :> m
91	if (addressof mm:external)<>null
92	mm :> mm external
93	if use_properties
94	var Pointer:Arrow c :> m:properties first "pliant tags list"
95	else
96	var Pointer:Arrow c :> m first "pliant tags list "+mm:name
97	if c=null
98	console "no tags for this module" eol
99	return
100	var Link:ListingTags lt :> c map ListingTags
101	var ListingTag xt
102	var Address a := lt first
103	while a<>null
104	xt := lt get a
105	var Int line := xt line
106	var Int column := xt:column-1
107	c :> xt value
108	a := lt next a
109	var Tag t
110	if c<>null and entry_type:c=TagMarker
111	var Int s := tags:size
112	tags := new Array:(Dictionary Int Tag)
113	tags size := s
114	eif line<tags:size
115	if c<>null and exists:(entry_type:c 'pliant is_watched' true)
116	t:kind:="A"; t:key:>entry_type:c
117	var Link:Universal data :> c omap Universal
118	data:'get position' decode (var Str filename) (var Int lin) (var Int col)
119	if filename<>""
120	t link := filename+"#line"+string:lin
121	else
122	t link := ""
123	tags:line insert column t
124	eif c<>null
125	t kind := "C" ; t key :> entry_type c ; t link := ""
126	if entry_type:c=Type
127	var Link:Type typ :> c map Type
128	typ:position decode (var Str filename) (var Int lin) (var Int col)
129	if filename<>""
130	t link := filename+"#line"+string:lin
131	tags:line insert column t
132	else
133	t:kind := "C" ; t key :> null map Type ; t link := ""
134	tags:line insert column t
135
136	type ApplyStack
137	field List:Tag tstack
138	field List:Str left
139	field Str piece <- ""
140
141	method as purge
142	arg_rw ApplyStack as
143	var Pointer:Tag sc
144	while {sc :> as:tstack:last; exists:sc}
145	as:piece := as:left:last+(apply sc as:piece)
146	as:tstack -= sc
147	as:left -= as:left:last
148
149	method as push t
150	arg_rw ApplyStack as; arg Tag t
151	as:tstack += t
152	as:left += as:piece
153	as:piece := ""
154
155	function source_listing filename server http
156	arg Str filename ; arg_rw HttpServer server ; arg_rw Stream http
157	(var Stream src) open filename in+safe
158	var Link:(List Str) pgm :> new (List Str)
159	while not src:atend
160	pgm += new Str src:readline
161	var Link:(Array (Dictionary Int Tag)) tags :> new (Array (Dictionary Int Tag))
162	tags size := pgm:size+1
163	var Link:Module module :> (pliant_module_dictionary first filename) map Module
164	if not exists:module and (reverse:filename eparse (pattern reverse:".page") any:(var Str filebase))
165	if exists:server
166	var Link:DynamicPage dp :> server find_dynamic_page filename
167	if exists:dp
168	module :> (dp:function:properties first "module") map Module
169	else
170	console filename " module not found" eol
171	# if not exists:module
172	#   console "module " filename " not loaded" eol
173	fill_tags tags module
174	http writeline "<!DOCTYPE HTML PUBLIC [dq]-//W3C//DTD HTML 3.2//EN[dq]>"
175	http writeline "<html>"
176	http writeline "<head>"
177	http writeline "<meta http-equiv=[dq]Content-Type[dq] content=[dq]text/html; charset=iso-8859-1[dq]>"
178	http writeline "<title>Listing of file "+html_encode:filename+"</title>"
179	http writeline "<style TYPE=[dq]text/css[dq]>"
180	http writeline "<!--"
181	http writeline "A:link, A:visited, A:active { text-decoration: none; color: black}"
182	http writeline "-->"
183	http writeline "</style>"
184	http writeline "</head>"
185	http writeline "<body bgcolor='white'><table column=3 border=0 cellpadding=0 cellspacing=0>"
186	http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
187	http writechars "<tr><td colspan=3 bgcolor='#FFF0E6'><tt><center><big>"
188	http writeline html_encode:filename+"</big></center></tt></td></tr>"
189	http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
190	var Int l := 1
191	each line pgm
192	http writechars "<tr><td bgcolor='#FFF0E6'><tt>&nbsp;<a name=[dq]line"+string:l+"[dq]></a><small>"+string:l+"</small>&nbsp;</tt></td><td><tt>"
193	var Link:ApplyStack as :> new ApplyStack
194	http eol
195	var Int s := 0
196	var Bool neutral:=false
197	var Bool in_str := false
198	while s<line:len
199	var Pointer:Tag cur :> tags:l first s
200	if exists:cur
201	neutral := false
202	as purge # purge the stack
203	while exists:cur # should be only one
204	as push cur
205	cur :> tags:l next s cur
206	if line:s="#"
207	as purge # purge the stack
208	var Tag t; t:kind:="#"; t key:>null map Type; t:link:=""
209	as push t
210	as piece := (line s line:len)
211	s := line:len
212	as purge
213	eif line:s="[dq]"
214	as purge
215	var Tag t; t:kind:="C"; t key:>Str; t link:=""
216	as push t
217	t:kind:=" "
218	as push t
219	var Int length := 2+((line s+1 line:len) search "[dq]" line:len)
220	as piece := (line s length)
221	s+=length
222	as purge
223	else
224	if not neutral
225	var Tag t; t:kind:=" "; t key:>null map Type; t:link:=""
226	as push t
227	neutral := true
228	as piece += line:s
229	s += 1
230	as purge
231	http writeline as:piece+"</tt></td><td bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
232	l += 1
233	http writeline "<tr><td colspan=3 bgcolor='#FFF0E6'><tt>&nbsp;</tt></td></tr>"
234	http writeline "</table>"
235	http writeline "</body>"
236	http writeline "</html>"
237
238	export source_listing
239
240
241	if false # deprecated filters
242
243	function c_filter src dest options
244	arg_rw Stream src dest ; arg_rw Str options
245	dest writeline "module [dq]/pliant/protocol/http/style/listing.style[dq] #"
246	var CBool doc := false
247	while not src:atend
248	var Str line := src readline
249	if doc
250	if (line parse "*/")
251	doc := false
252	eif (line parse "doc")
253	dest writeline "table columns 1 border 0"
254	dest writeline "  [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]"
255	dest writeline "  cell color (color hsl 60 10 80)"
256	else
257	dest writeline "  "+line
258	eif (line parse "/*")
259	line := src readline
260	if line="doc" or line="abstract"
261	dest writeline "table columns 1 border 0"
262	dest writeline "  [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]"
263	if line="doc"
264	dest writeline "  cell color (color hsl 60 10 80)"
265	else
266	dest writeline "  cell color (color hsl 60 35 80)"
267	doc := true
268	else
269	dest writeline "raw_line "+string:"/*"
270	dest writeline "raw_line "+string:line
271	eif line:len>10 and line="/"+(repeat line:len-2 "*")+"/"
272	dest writeline "horizontal_line"
273	eif (line eparse any:(var Str base) "///" offset:(var Int offset1) spaces:(var Str drop) offset:(var Int offset2) any:(var Str comment))
274	if (comment parse word:"section" (var Str drop))
275	dest writeline comment ; comment := ""
276	dest writeline "raw_characters "+string:(line 0 offset1-3)
277	if comment<>""
278	dest writeline "[0]right_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number)+" "+string:offset2+"[0]"+comment
279	dest writeline "eol"
280	eif (line parse any:(var Str base) "//" any:(var Str comment))
281	dest writeline "section "+(string "comment "+comment)
282	dest writeline "raw_line "+string:line
283	else
284	dest writeline "raw_line "+string:line
285
286
287	# xlHtml has been removed because it tends to run forever
288	constant xlhtml "" # (shunt (file_query "embedded:/usr/bin/xlhtml" standard)=success "xlhtml" (file_query "embedded:/usr/bin/xlHtml" standard)=success "xlHtml" "")
289	constant wvhtml "" # (shunt (file_query "embedded:/usr/bin/wvHtml" standard)=success "wvHtml" "")
290
291	if xlhtml<>""
292	module "/pliant/language/unsafe.pli"
293	module "/pliant/admin/file.pli"
294	module "/pliant/admin/execute.pli"
295
296	function xls_filter src dest options
297	arg_rw Stream src dest ; arg_rw Str options
298	var Str temp1 := replace file_temporary "file:/" "embedded:/"
299	(var Stream s) open temp1 out+safe
300	while not src:atend
301	src read_available (var Address adr) (var Int size)
302	s raw_write adr size
303	s close
304	var Str temp2 := replace file_temporary "file:/" "embedded:/"
305	execute xlhtml+" "+file_os_name:(replace temp1 "embedded:/" "file:/") root "embedded:/" path "embedded:/" output temp2
306	(var Stream s) open temp2 in+safe
307	while not s:atend
308	s read_available (var Address adr) (var Int size)
309	dest raw_write adr size
310	s close
311	file_delete temp1
312	file_delete temp2
313	options += " mime [dq]text/html[dq]"
314	declare_mime_static_filter ".xls" (the_function xls_filter Stream Stream Str)
315	declare_mime_static_filter ".XLS" (the_function xls_filter Stream Stream Str)
316
317	if wvhtml<>""
318	module "/pliant/language/unsafe.pli"
319	module "/pliant/admin/file.pli"
320	module "/pliant/admin/execute.pli"
321
322	function doc_filter src dest options
323	arg_rw Stream src dest ; arg_rw Str options
324	var Str temp1 := replace file_temporary "file:/" "embedded:/"
325	(var Stream s) open temp1 out+safe
326	while not src:atend
327	src read_available (var Address adr) (var Int size)
328	s raw_write adr size
329	s close
330	var Str temp2 := (replace file_temporary "file:/" "embedded:/")+"/"
331	file_tree_create temp2
332	execute wvhtml+" --targetdir="+file_os_name:(replace temp2 "embedded:/" "file:/")+" "+file_os_name:(replace temp1 "embedded:/" "file:/")+" document.html" root "embedded:/" path "embedded:/"
333	(var Stream s) open temp2+"document.html" in+safe
334	while not s:atend
335	s read_available (var Address adr) (var Int size)
336	dest raw_write adr size
337	s close
338	file_delete temp1
339	file_tree_delete temp2
340	options += " mime [dq]text/html[dq]"
341	declare_mime_static_filter ".doc" (the_function doc_filter Stream Stream Str)
342	declare_mime_static_filter ".DOC" (the_function doc_filter Stream Stream Str)
343