#!/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 Guestbook Jump to last message

\"\[Tcl GuestBook

" if {[info exist cgi(url)] && [info exist cgi(subj)]} { set subj [lindex $cgi(subj) 0]; set url [lindex $cgi(url) 0]; } elseif {$argc} { set subj [join $argv]; if {[info exists env(HTTP_REFERER)]} { set url $env(HTTP_REFERER); } else { set url $defurl; } } else { if { [info exists env(HTTP_REFERER)] && \ (![cequal $env(HTTP_REFERER) ""]) && \ ([string first $env(SCRIPT_NAME) $env(HTTP_REFERER)]==-1) } { set url $env(HTTP_REFERER); set subj $url; } else { set subj $defsubj set url $defurl } } set subject "[escape [uncgi $subj] 0]"; set more ""; set urlok [regexp -nocase $ul $url]; if {[info exists cgi(cmt)] && [info exists cgi(name)]} { set cmt [lindex $cgi(cmt) 0]; set name [lindex $cgi(name) 0]; if {![cequal $cmt ""] && ![cequal $name ""] && $urlok} { set fic [open $filename {WRONLY APPEND}] # flock -write $fic; set cmt [escape $cmt]; set name [escape $name]; puts $fic "

[clock format [clock seconds]\ -format "%d %b, %H:%M"], $name, from $env(REMOTE_HOST), About `$subject':\n
$cmt\n

"; close $fic; set more "
Thank you!,\ comment recorded...
"; } else { set more "
Invalid comment,\ please retry !
"; } } if {!$urlok} { puts stderr "guest_book: Error: invalid url ($url) from $env(REMOTE_HOST) host, subj was ($subj)"; set subj $defsubj; set url $defurl; set subject "[escape [uncgi $subj] 0]"; } puts "$more Please enter a comment about $subject below (Text, not html (no <a href...), Urls will be auto-linked (just type http://wherever, and it'll be clickable)):

Your name (and email)

to the GuestBook.
[read_file guest_book.data]
-end- $more
Guestbook v1.11, in Tcl by Laurent Demailly, Last change Oct 20th 1999.
"