1#!/bin/sh
2#
3# scriptview.cgi = Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com>
4#
5# Present a named Tcl script file over HTTP. Include some font-lock style 
6# syntax colouring.
7#
8# The regular expression segment needs work to mask syntax elements within
9# comments / quoted strings. Otherwise it looks good.
10#
11# restart with tclsh \
12exec tclsh "$0" ${1+"$@"}
13
14# -------------------------------------------------------------------------
15# << configure me >>
16# -------------------------------------------------------------------------
17
18# Point to our installation of tcllib etc.
19#set auto_path [linsert $auto_path 0 [file join [pwd] "../../.."]]
20#set auto_path [linsert $auto_path 0 [file join [pwd] "../lib/tcl/tcllib0.8"]]
21set auto_path [linsert $auto_path 0 /home/pat/lib/tcl \
22	/home/pat/lib/tcl/tcllib0.8]
23
24# This is the filesystem root and list of permissible script names.
25#set root [file join [pwd] "../../../tclsoap"]
26#set root [file join [pwd] "../tclsoap"]
27set root /home/pat/lib/tcl/tclsoap
28
29# -------------------------------------------------------------------------
30
31set permitted {SOAP.tcl SOAP-domain.tcl SOAP-parse.tcl SOAP-service.tcl \
32	       xpath.tcl XMLRPC.tcl XMLRPC-domain.tcl XMLRPC-typed.tcl \
33	       samples/SOAP-tests.tcl samples/XMLRPC-tests.tcl }
34
35proc SV_subst {body} {
36    regsub -all {\\([][{}\\])} $body {\1} body
37    return $body
38}
39
40proc SV_plain {body} {
41    puts -nonewline "[SV_subst $body]"
42}
43
44proc SV_comment {text {body {}}} {
45    set r {}
46    foreach elt $text {
47	if { ! [string match SV_* $elt] } { append r $elt }
48    }
49    puts -nonewline "<font color=\"red\">[SV_subst $r]</font>[SV_subst $body]"
50}
51
52proc SV_string {text {body {}}} {
53    set r {}
54    foreach elt $text {
55	if { ! [string match SV_* $elt] } { append r $elt }
56    }
57    puts -nonewline "<font color=\"salmon\">[SV_subst $r]</font>[SV_subst $body]"
58}
59
60proc SV_function {type name param rest} {
61    puts -nonewline "<font color=\"blue\">$type</font> <font color=\"magenta\">$name</font>${param}[SV_subst $rest]"
62}
63
64proc SV_keyword {text body} {
65    puts -nonewline "<font color=\"blue\">[SV_subst $text]</font>[SV_subst $body]"
66}
67
68proc SV_variable {text rest} {
69    puts -nonewline "<font color=\"green\">[SV_subst $text]</font>[SV_subst $rest]"
70}
71
72proc SV_fontify {data} {
73    regsub -all {[][{}\\]} $data {\\&} data
74
75    # Protect quoted strings, then protect HTML special characters
76    regsub -all "\"" $data {zQuOtE} data
77    set data [html::quoteFormValue $data]
78    regsub -all {zQuOtE} $data "\"" data
79
80    # Emacs W3 browser needs a newline added after the comments. I don't know about
81    # netscape.
82    set comment_fix {}
83    if {[string match {Emacs-W3*} $::env(HTTP_USER_AGENT)]} {
84	set comment_fix "\n"
85    }
86	
87    regsub -all "\#\[^\n\]*\n" $data \
88	    "\}\nSV_comment {{&${comment_fix}}} \{" data
89    #regsub -all {"[^"]*"} $data "\}\nSV_string {{&}} \{" data ;#"
90    regsub -all \
91	    "(proc)\[ \t\]+(\[^ \t\]+)"\
92	    $data "\}\nSV_function {\\1} {\\2} {\\3} \{" data
93
94    regsub -all [join [list \
95	    "(\\\\?\[\]\[{} \t\n\r:;\])" \
96            {(break|case|continue|default|e((lse|lseif)|rror|val|xit)}\
97	    {|for|for_(array_keys|file|recursive_glob)|foreach}\
98	    {|i([fn]|tcl_class)|loop|namespace e(val|xport)}\
99	    {|package (provide|require)|return}\
100	    {|switch|then|uplevel|while)} \
101            "(\\\\?\[ \t\r\n:;\])" ] {}] \
102	    $data "\}\nSV_keyword {&} \{" data
103
104    regsub -all [join [list \
105	    "(\\\\?\[\]\[{} \t\n\r:;\])" \
106	    {(common|global|inherit|p(r(ivate|otected)|ublic)}\
107	    {|upvar|variable)} \
108            "(\\\\?\[ \t\r\n:;\])" ] {}] \
109	    $data "\}\nSV_variable {&} \{" data
110
111    #puts "<pre>SV_plain { $data }</pre><h1>[string repeat - 76]</h1>"
112    return $data
113}
114
115proc log {data} {
116    set f [open /tmp/scriptview.log w]
117    puts -nonewline $f [list $data]
118    close $f
119}
120
121if { [catch {
122
123    package require ncgi
124    package require html
125
126    set query [ncgi::nvlist]
127    set scriptname [lindex $query 1]
128    if { [lsearch $permitted $scriptname] == -1 } {
129	error "Permission denied: \"$scriptname\" must be one of \"$permitted\"" {} CGI
130    }
131    set filename [file join $root $scriptname]
132    if { ! [file exists $filename] } {
133	error "file not found: \"$scriptname\" does not exist under $root" {} CGI
134    }
135
136    # Read in the script contents
137    set f [open $filename r]
138    set data [read $f]
139    close $f
140
141    ncgi::header text/html {}
142#    [list "Last Modified" [clock format [file mtime $filename]]]
143    puts "<html><head><title>$scriptname</title></head>"
144    flush stdout
145
146    set data [SV_fontify $data]
147    puts "<body bgcolor=\"\#ffffff\" text=\"\#000000\">"
148    puts -nonewline "<pre>"
149    log "\{$data\}"
150    eval "SV_plain \{$data\}"
151    puts "</pre><br>"
152    puts -nonewline "<font size=\"-1\"># Generated by <em>scriptview.cgi</em> "
153    puts "on [clock format [clock seconds]] "
154    puts "using tcl ${tcl_patchLevel}."
155    puts "</font></body></html>"
156
157    flush stdout
158    exit 0
159
160} msg] } {
161
162    puts "Content-Type: text/html\n"
163    puts "<h1>Error During CGI Script Execution</h1><p>$msg</p>"
164    if { $errorCode != "CGI" } {
165	puts "<p>Additional information:<pre>$errorInfo</pre></p>"
166    }
167
168}
169
170
171#
172# Local variables:
173# mode: tcl
174# End:
175