# Copyright Patrice Ossona de Mendez # Repackaged for new Pliant HTTP layout by Hubert Tonneau # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License version 2 # as published by the Free Software Foundation. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # version 2 along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. module "/pliant/language/compiler.pli" module "/pliant/language/stream.pli" module "/pliant/util/encoding/html.pli" module "/pliant/protocol/http/server.pli" constant use_properties false 'pliant watch' Type false := "#C80096" 'pliant watch' Str false := "green" 'pliant watch' Char false := "green" 'pliant watch' InlineText false := "green" 'pliant watch' Function true := "black" 'pliant watch' Meta true := "black" 'pliant watch' GlobalVariable true := "#FF0000" 'pliant watch' LocalVariable true := "#C80032" type Tag field Char kind field Pointer:Type key field Str link function apply t s -> s2 arg Tag t; arg Str s s2 var Str ss:=s if t:kind="C" var Str color := "#006446" var Pointer:Str eff :> t:key 'pliant is_watched' false if exists:eff color := eff ss := ""+ss+"" eif t:kind="A" var Pointer:Str eff :> t:key 'pliant is_watched' true if exists:eff color := eff ss := ""+ss+"" eif t:kind=" " ss := replace (html_encode ss true) " " " " eif t:kind="#" if ss="#"+(repeat (max ss:len-1 3) "-") ss := "
" else ss := ""+(replace (html_encode ss true) " " " ")+"" if t:link<>"" ss := ""+ss+"" s2 := ss method position decode filename line column arg ListingPosition position; arg_w Str filename; arg_w Int line column var Str s := cast position Str if not (s eparse any:filename _ any:(var Str remain)) filename:=""; line:=0; column := 0 return if not (remain parse line column) remain parse any:(var Str dummy) line column method fun 'get position' -> pos oarg Function fun; arg ListingPosition pos return fun:position method met 'get position' -> pos oarg Meta met; arg ListingPosition pos var Link:Function fun :> addressof:met omap Function return fun:position method gv 'get position' -> pos oarg GlobalVariable gv; arg ListingPosition pos return gv:position function fill_tags tags m arg_rw (Link Array:(Dictionary Int Tag)) tags ; arg Module m if not exists:m return var Link:Module mm :> m if (addressof mm:external)<>null mm :> mm external if use_properties var Pointer:Arrow c :> m:properties first "pliant tags list" else var Pointer:Arrow c :> m first "pliant tags list "+mm:name if c=null console "no tags for this module" eol return var Link:ListingTags lt :> c map ListingTags var ListingTag xt var Address a := lt first while a<>null xt := lt get a var Int line := xt line var Int column := xt:column-1 c :> xt value a := lt next a var Tag t if c<>null and entry_type:c=TagMarker var Int s := tags:size tags := new Array:(Dictionary Int Tag) tags size := s eif linenull and exists:(entry_type:c 'pliant is_watched' true) t:kind:="A"; t:key:>entry_type:c var Link:Universal data :> c omap Universal data:'get position' decode (var Str filename) (var Int lin) (var Int col) if filename<>"" t link := filename+"#line"+string:lin else t link := "" tags:line insert column t eif c<>null t kind := "C" ; t key :> entry_type c ; t link := "" if entry_type:c=Type var Link:Type typ :> c map Type typ:position decode (var Str filename) (var Int lin) (var Int col) if filename<>"" t link := filename+"#line"+string:lin tags:line insert column t else t:kind := "C" ; t key :> null map Type ; t link := "" tags:line insert column t type ApplyStack field List:Tag tstack field List:Str left field Str piece <- "" method as purge arg_rw ApplyStack as var Pointer:Tag sc while {sc :> as:tstack:last; exists:sc} as:piece := as:left:last+(apply sc as:piece) as:tstack -= sc as:left -= as:left:last method as push t arg_rw ApplyStack as; arg Tag t as:tstack += t as:left += as:piece as:piece := "" function source_listing filename server http arg Str filename ; arg_rw HttpServer server ; arg_rw Stream http (var Stream src) open filename in+safe var Link:(List Str) pgm :> new (List Str) while not src:atend pgm += new Str src:readline var Link:(Array (Dictionary Int Tag)) tags :> new (Array (Dictionary Int Tag)) tags size := pgm:size+1 var Link:Module module :> (pliant_module_dictionary first filename) map Module if not exists:module and (reverse:filename eparse (pattern reverse:".page") any:(var Str filebase)) if exists:server var Link:DynamicPage dp :> server find_dynamic_page filename if exists:dp module :> (dp:function:properties first "module") map Module else console filename " module not found" eol # if not exists:module # console "module " filename " not loaded" eol fill_tags tags module http writeline "" http writeline "" http writeline "" http writeline "" http writeline "Listing of file "+html_encode:filename+"" http writeline "" http writeline "" http writeline "" http writeline "" http writechars "" http writeline "" var Int l := 1 each line pgm http writechars "" l += 1 http writeline "" http writeline "
 
" http writeline html_encode:filename+"
 
 "+string:l+" " var Link:ApplyStack as :> new ApplyStack http eol var Int s := 0 var Bool neutral:=false var Bool in_str := false while s tags:l first s if exists:cur neutral := false as purge # purge the stack while exists:cur # should be only one as push cur cur :> tags:l next s cur if line:s="#" as purge # purge the stack var Tag t; t:kind:="#"; t key:>null map Type; t:link:="" as push t as piece := (line s line:len) s := line:len as purge eif line:s="[dq]" as purge var Tag t; t:kind:="C"; t key:>Str; t link:="" as push t t:kind:=" " as push t var Int length := 2+((line s+1 line:len) search "[dq]" line:len) as piece := (line s length) s+=length as purge else if not neutral var Tag t; t:kind:=" "; t key:>null map Type; t:link:="" as push t neutral := true as piece += line:s s += 1 as purge http writeline as:piece+" 
 
" http writeline "" http writeline "" export source_listing if false # deprecated filters function c_filter src dest options arg_rw Stream src dest ; arg_rw Str options dest writeline "module [dq]/pliant/protocol/http/style/listing.style[dq] #" var CBool doc := false while not src:atend var Str line := src readline if doc if (line parse "*/") doc := false eif (line parse "doc") dest writeline "table columns 1 border 0" dest writeline " [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]" dest writeline " cell color (color hsl 60 10 80)" else dest writeline " "+line eif (line parse "/*") line := src readline if line="doc" or line="abstract" dest writeline "table columns 1 border 0" dest writeline " [0]left_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number-1)+" 1[0]" if line="doc" dest writeline " cell color (color hsl 60 10 80)" else dest writeline " cell color (color hsl 60 35 80)" doc := true else dest writeline "raw_line "+string:"/*" dest writeline "raw_line "+string:line eif line:len>10 and line="/"+(repeat line:len-2 "*")+"/" dest writeline "horizontal_line" eif (line eparse any:(var Str base) "///" offset:(var Int offset1) spaces:(var Str drop) offset:(var Int offset2) any:(var Str comment)) if (comment parse word:"section" (var Str drop)) dest writeline comment ; comment := "" dest writeline "raw_characters "+string:(line 0 offset1-3) if comment<>"" dest writeline "[0]right_zero_is_at [dq]"+src:name+"[dq] "+(string src:line_number)+" "+string:offset2+"[0]"+comment dest writeline "eol" eif (line parse any:(var Str base) "//" any:(var Str comment)) dest writeline "section "+(string "comment "+comment) dest writeline "raw_line "+string:line else dest writeline "raw_line "+string:line # xlHtml has been removed because it tends to run forever constant xlhtml "" # (shunt (file_query "embedded:/usr/bin/xlhtml" standard)=success "xlhtml" (file_query "embedded:/usr/bin/xlHtml" standard)=success "xlHtml" "") constant wvhtml "" # (shunt (file_query "embedded:/usr/bin/wvHtml" standard)=success "wvHtml" "") if xlhtml<>"" module "/pliant/language/unsafe.pli" module "/pliant/admin/file.pli" module "/pliant/admin/execute.pli" function xls_filter src dest options arg_rw Stream src dest ; arg_rw Str options var Str temp1 := replace file_temporary "file:/" "embedded:/" (var Stream s) open temp1 out+safe while not src:atend src read_available (var Address adr) (var Int size) s raw_write adr size s close var Str temp2 := replace file_temporary "file:/" "embedded:/" execute xlhtml+" "+file_os_name:(replace temp1 "embedded:/" "file:/") root "embedded:/" path "embedded:/" output temp2 (var Stream s) open temp2 in+safe while not s:atend s read_available (var Address adr) (var Int size) dest raw_write adr size s close file_delete temp1 file_delete temp2 options += " mime [dq]text/html[dq]" declare_mime_static_filter ".xls" (the_function xls_filter Stream Stream Str) declare_mime_static_filter ".XLS" (the_function xls_filter Stream Stream Str) if wvhtml<>"" module "/pliant/language/unsafe.pli" module "/pliant/admin/file.pli" module "/pliant/admin/execute.pli" function doc_filter src dest options arg_rw Stream src dest ; arg_rw Str options var Str temp1 := replace file_temporary "file:/" "embedded:/" (var Stream s) open temp1 out+safe while not src:atend src read_available (var Address adr) (var Int size) s raw_write adr size s close var Str temp2 := (replace file_temporary "file:/" "embedded:/")+"/" file_tree_create temp2 execute wvhtml+" --targetdir="+file_os_name:(replace temp2 "embedded:/" "file:/")+" "+file_os_name:(replace temp1 "embedded:/" "file:/")+" document.html" root "embedded:/" path "embedded:/" (var Stream s) open temp2+"document.html" in+safe while not s:atend s read_available (var Address adr) (var Int size) dest raw_write adr size s close file_delete temp1 file_tree_delete temp2 options += " mime [dq]text/html[dq]" declare_mime_static_filter ".doc" (the_function doc_filter Stream Stream Str) declare_mime_static_filter ".DOC" (the_function doc_filter Stream Stream Str)