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