#!/usr/local/bin/tclsh8.0 # # A simple guest book WWW CGI application # initially (one of my early Tcl/Web program, written back in 1994!) # requiring TclX, now pure Tcl 8 # # (c) 1994-1997 by Laurent Demailly - L@Demailly.com - v 1.11 - Oct 20 1999 # Latest version & info should be on http://www.demailly.com/~dl/wwwtools.html # # NO Warranty, Gnu General Public License. # (ask if you need another license). # # Please keep the my (author's) reference # (though this code is certainly not the best example of my programming style!) #usage : # Please sign my guestbook # (+ => space) # you need to create the guest_book.data file, owned by the cgi's uid (httpd) # in the cgi dir # restrict the accepted referer url to following matching regexp # If you don't care : # set ul {^http://} # The regexp that I use to limit to url coming from my server only: set ul {^http://www\.demailly\.com(:80)?/} # TclX replacements: proc read_file {fname} { set f [open $fname] set r [read $f] close $f set r } proc cequal {s1 s2} { expr {[string compare $s1 $s2]==0} } # # UnCgi Translation hack, in Tcl, v1.5 5/1995 by L@demailly.com # this version should be updated to newer, using subst and taking # care of :: proc uncgi {buf} { # ncsa httpd (at least) \ quotes some chars, including \ so : regsub -all {\\(.)} $buf {\1} buf ; regsub -all {\\} $buf {\\\\} buf ; regsub -all { } $buf {\ } buf ; regsub -all {\+} $buf {\ } buf ; regsub -all {\$} $buf {\$} buf ; regsub -all \n $buf {\n} buf ; regsub -all {;} $buf {\;} buf ; regsub -all {\[} $buf {\[} buf ; regsub -all \" $buf \\\" buf ; # the next one can probably be skipped as the first char is prolly not # an \{, but, hey who knows... lets be safe... regsub ^\{ $buf \\\{ buf ; # I think everything has been escaped, now the real work : regsub -all -nocase {%([a-fA-F0-9][a-fA-F0-9])} $buf {[format %c 0x\1]} buf # And now lets replace all those escaped back, along with excuting of # the format : eval return \"$buf\" # now everything is in buf, but translated, nice trick no ? } # # text -> html + auto link of urls # proc escape {str {auto 1}} { regsub -all {&} $str {\&} str; regsub -all {<} $str {\<} str; regsub -all {>} $str {\>} str; regsub -all {"} $str {\"} str; regsub -all "\[\t\r\n\]\[ \t\r\n\]*" $str { } str; if {$auto} { regsub -all {(http|ftp|gopher)://([^& ,;)|]+)} $str {\0} str; } return $str; } # returns in the 'cgi' array all the parameters sent to the script # through 'message' (each array cell is a list (ie if only one value # is expected through 'test' variable, use [lindex $cgi(test) 0] to get it. proc parse_cgi_message {message} { global cgi; foreach pair [split $message &] { set plst [split $pair =]; set name [uncgi [lindex $plst 0]]; set val [uncgi [lindex $plst 1]]; lappend cgi($name) $val; } } # process form values, accept only post method set message ""; if {[info exist env(REQUEST_METHOD)] && [string compare $env(REQUEST_METHOD) "POST"]==0} { set message [read stdin $env(CONTENT_LENGTH)]; } set cgi() "" parse_cgi_message $message; set filename guest_book.data; set defsubj "The+Guestbook"; set portstr "" if {[string compare $env(SERVER_PORT) "80"]} { set portstr ":$env(SERVER_PORT)" } set defurl "http://$env(SERVER_NAME)$portstr$env(SCRIPT_NAME)"; puts "Content-type: text/html\n