diff options
Diffstat (limited to 'web/src/cgi.tcl-1.10/example')
39 files changed, 2349 insertions, 0 deletions
diff --git a/web/src/cgi.tcl-1.10/example/README b/web/src/cgi.tcl-1.10/example/README new file mode 100644 index 00000000..6bbbb80c --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/README @@ -0,0 +1,77 @@ +This file is cgi.tcl/README. It contains brief descriptions of the +examples in this directory. You are welcome to send me additional +scripts. + +-------------------- +Instructions on running scripts +-------------------- + +The "examples.cgi" script provides a page of clickable links to all +the other example scripts. "frame.cgi" is a framed version - it's not +particularly good looking but it does work and - anyway - I needed a +frame example! + +There are three ways of running these scripts: + +1) Point your browser at http://expect.nist.gov/cgi.tcl + +2) Run them by hand, such as by typing "tclsh scriptname" at the +command line. This is appropriate if you just want to study the raw +HTML output or see how fast they run. + +3) Install them in your own web and run them through your browser. +(If you're on a UNIX host, the "make examples" target in the Makefile +fixes up the #! line of each examples and installs them in a public +demo directory.) You'll want to edit the example.tcl file to redefine +cgi_root appropriately. + +If you run the examples locally (options 2 and 3): + + - In order to get the submit buttons to take you back to your + site (instead of on to my site!), check the cgi_root call in + example.tcl to point back to your site. + + - Some of these examples may do things that are not portable + and therefore may not run on all systems. For example, some + of them call "exec". The "unimail" script assumes the + existence of sendmail through cgi.tcl's built-in mail + support. See the ../install.win file for more info. + +-------------------- +Source files in this directory +-------------------- + + cookie.cgi - demonstrates cookies + + display.cgi - display a CGI script + + error.cgi - demonstrates error handing + + examples.cgi - Provides a page with clickable links to all + these examples. + + form-tour.cgi - demonstrates most form elements (Note that these + don't do anything - they're just for looks.) + + format-tour.cgi - demonstrates many formats, unrelated to forms + + frame.cgi - a friend's home page that demonstrates frames + + kill.cgi - kill runaway CGI processes + + parray.cgi - displays an array (or the environment by default) + + passwd-form.cgi - creates a form for changing a password + passwd.cgi - backend to passwd-form where password is actually changed + Note that this script is an Expect script. + passwd.tcl - common definitions for passwd*.cgi scripts + + upload.cgi - file upload + + vclock.pl - Lincoln Stein's virtual clock from CGI.pm paper + vclock.cgi - Lincoln Stein's virtual clock (but in Tcl) + + visitor.cgi - implements a visitor counter + visitor.cnt - file containing the count + + example.tcl - common definitions for most of the examples diff --git a/web/src/cgi.tcl-1.10/example/cookie.cgi b/web/src/cgi.tcl-1.10/example/cookie.cgi new file mode 100755 index 00000000..ea0709bc --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/cookie.cgi @@ -0,0 +1,45 @@ +#!/depot/path/tclsh + +# This CGI script shows how to create a cookie. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_http_head { + cgi_content_type text/html + if {0==[catch {cgi_import Name}]} { + cgi_export_cookie Name ;# expires=never + # For a persistent cookie, uncomment the "expires=never" + } else { + catch {cgi_import_cookie Name} + } + } + cgi_head { + cgi_title "Cookie Form Example" + } + cgi_body { + p "This form finds a value from a previous submission of \ + the form either directly or through a cookie." + set Name "" + + if {0==[catch {cgi_import Name}]} { + p "The value was found from the form submission and the cookie + has now been set. Bookmark this form, surf somewhere else + and then return to this page to get the value via the cookie." + } elseif {0==[catch {cgi_import_cookie Name}]} { + p "The value was found from the cookie." + } else { + p "No cookie is currently set. To set a cookie, enter a value + and press return." + } + + cgi_form cookie { + puts "Value: " + cgi_text Name + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/creditcard.cgi b/web/src/cgi.tcl-1.10/example/creditcard.cgi new file mode 100755 index 00000000..a205b452 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/creditcard.cgi @@ -0,0 +1,137 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + set cardtypes { + "American Express" + "Carte Blanche" + "Diners Card" + "Discover" + "Enroute" + "JCB" + "Mastercard" + "Novus" + "Visa" + } + + # My own version of the LUHN check + proc LUHNFormula {cardnumber} { + if {0==[regexp "(.*)(.)$" $cardnumber dummy cardnumber check]} { + user_error "No card number entered" + } + set evenodd [expr [string length $cardnumber] % 2] + + set sum 0 + foreach digit [split $cardnumber ""] { + incr sum $digit + if {$evenodd} { + incr sum [lindex {0 1 2 3 4 -4 -3 -2 -1 0} $digit] + } + set evenodd [expr !$evenodd] + } + set computed [expr {(10 - ($sum % 10)) % 10}] + if {$computed != $check} { + user_error "Invalid card number. (Failed LUHN test - try changing last digit to $computed.)" + } + } + + # generate digit patterns of length n + proc d {n} { + for {set i 0} {$i < $n} {incr i} { + append buf {[0-9]} + } + return $buf + } + + cgi_input + + cgi_title "Check Credit Card" + + cgi_body { + if {0 == [catch {cgi_import cardtype}]} { + if {[catch {cgi_import cardnumber}]} { + user_error "No card number entered" + } + # Save original version for clearer diagnostics + set originalcardnumber [cgi_quote_html $cardnumber] + + if {[catch {cgi_import expiration}]} { + user_error "You must enter an expiration." + } + if {-1 == [lsearch $cardtypes $cardtype]} { + user_error "Unknown card type: $cardtype" + } + + # Remove any spaces or dashes in card number + regsub -all "\[- ]" $cardnumber "" cardnumber + + # Make sure that only digits are left + if {[regexp "\[^0-9]" $cardnumber invalid]} { + user_error "Invalid character ([cgi_quote_html $invalid]) in credit card number: $originalcardnumber" + } + + if {$cardtype != "Enroute"} { + LUHNFormula $cardnumber + } + + # Verify correct length and prefix for each card type + switch $cardtype { + Visa { + regexp "^4[d 12]([d 3])?$" $cardnumber match + } Mastercard { + regexp "^5\[1-5][d 14]$" $cardnumber match + } "American Express" { + regexp "^3\[47][d 13]$" $cardnumber match + } "Diners Club" { + regexp "^3(0\[0-5]|\[68][d 1])[d 11]$" $cardnumber match + } "Carte Blanche" { + regexp "^3(0\[0-5]|\[68][d 1])[d 11]$" $cardnumber match + } Discover { + regexp "^6011[d 12]$" $cardnumber match + } Enroute { + regexp "^(2014|2149)[d 11]$" $cardnumber match + } JCB { + regexp "^(2131|1800)[d 11]$" $cardnumber match + regexp "^3(088|096|112|158|337|528)[d 12]$" $cardnumber match + } Novus { + if {[string length $cardnumber] == 16} { + set match 1 + } + } + } + + if 0==[info exists match] { + user_error "Invalid card number: $originalcardnumber" + } + h3 "Your card appears to be valid. Thanks!" + return + } + + cgi_form creditcard { + h3 "Select a card type, enter the card number and expiration." + puts "Card type: " + cgi_select cardtype { + foreach t $cardtypes { + cgi_option $t + } + } + puts "[nl]Card number: " + cgi_text cardnumber= + puts "(blanks and dashes are ignored)" + + puts "[nl]Expiration: " + cgi_text expiration= + + br + submit_button "=Confirm purchase" + reset_button + h5 "This script will perform all of the known syntactic + checks for each card type but will not actually contact + a credit bureau. The expiration field is not presently + checked at all." + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/display-in-frame.cgi b/web/src/cgi.tcl-1.10/example/display-in-frame.cgi new file mode 100755 index 00000000..6366957e --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/display-in-frame.cgi @@ -0,0 +1,31 @@ +#!/depot/path/tclsh + +# This is a CGI script that displays the results of other CGI scripts +# in a separate frame. It is only used for a few rare examples such +# as image.cgi + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_head { + set scriptname image.cgi + catch {cgi_import scriptname} + set scriptname [file tail $scriptname] + cgi_title $scriptname + } + cgi_frameset rows=50%,50% { + cgi_frame =$scriptname?header=1 + cgi_frame =$scriptname + } + cgi_noframes { + cgi_h1 "uh oh" + + p "This document is designed to be viewed by a Frames-capable + browser. If you see this message your browser is not + Frames-capable." + } +} diff --git a/web/src/cgi.tcl-1.10/example/display.cgi b/web/src/cgi.tcl-1.10/example/display.cgi new file mode 100755 index 00000000..efadbe05 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/display.cgi @@ -0,0 +1,44 @@ +#!/depot/path/tclsh + +# This is a CGI script that displays another CGI script +# and massages "source" commands into hyperlinks + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_head { + set scriptname [info script]; # display self by default! + catch {cgi_import scriptname} + + # strip tildes to gracefully handle experimenters + set scriptname [string trimleft $scriptname ~] + + set scriptname [file tail $scriptname] + cgi_title "Source for $scriptname" + } + cgi_body { + # gracefully handle hackers trying to opening directories + switch -- $scriptname . - .. - "" { + h3 "No such file: $scriptname" + return + } + if {[catch {set fid [open $scriptname]}]} { + h3 "No such file: $scriptname" + return + } + cgi_preformatted { + while {-1 != [gets $fid buf]} { + if {[regexp "^(\[ \t]*)source (.*)" $buf ignore space filename]} { + puts "[set space]source [cgi_url $filename [cgi_cgi display scriptname=$filename]]" + } else { + puts [cgi_quote_html $buf] + } + } + } + } +} + diff --git a/web/src/cgi.tcl-1.10/example/download.cgi b/web/src/cgi.tcl-1.10/example/download.cgi new file mode 100755 index 00000000..c82cb3f5 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/download.cgi @@ -0,0 +1,36 @@ +#!/depot/path/tclsh + +package require cgi + +set msg "Very funny, Scotty. Now beam down my clothes." +set filename "scotty.msg" + +cgi_eval { + source example.tcl + + cgi_input + + if {[catch {cgi_import style}]} { + cgi_title "download example" + body { + cgi_suffix "" + form download.cgi/$filename { + puts "This example demonstrates how to force files to be + downloaded into a separate file via the popup file browser." + br + puts "Download data" + submit_button "style=in window" + submit_button "style=in file using popup file browser" + } + } + } else { + if {[regexp "in window" $style]} { + title "Display data in browser window" + } else { + cgi_http_head { + content_type application/x-download + } + } + puts $msg + } +} diff --git a/web/src/cgi.tcl-1.10/example/error.cgi b/web/src/cgi.tcl-1.10/example/error.cgi new file mode 100755 index 00000000..0b97c99a --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/error.cgi @@ -0,0 +1,31 @@ +#!/depot/path/tclsh + +# This is a CGI script that demonstrates error processing. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_title "This CGI script contains an intentional error." + + cgi_body { + p "The page that you are now reading is being generated by a + CGI script that contains an intentional error." + + cgi_debug -on + + p "Debugging is enabled, so the error message will be shown in +the browser window (below). Disable this by commenting out the +cgi_debug command and reloading this script." + + cgi_number_list { + cgi_li "List item 1" + cgi_li "List item 2" + cgi_lix "List item 3 - intentionally misspelled" + cgi_li "List item 4" + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/evaljs.cgi b/web/src/cgi.tcl-1.10/example/evaljs.cgi new file mode 100755 index 00000000..ea732e9d --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/evaljs.cgi @@ -0,0 +1,36 @@ +#!/depot/path/tclsh + +# This CGI script uses JavaScript to evaluate an expression. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_head { + title "Using JavaScript to evaluate an expression" + + javascript { + puts { + function compute(f) { + f.result.value = eval(f.expr.value) + } + } + } + noscript { + puts "Sorry - your browser doesn't understand JavaScript." + } + } + + cgi_body { + cgi_form dummy { + cgi_unbreakable { + cgi_button "Evaluate" onClick=compute(this.form) + cgi_text expr=Math.sqrt(2)*10000 + puts "=" + cgi_text result= + } + p "Feel free to enter and evaluate your own JavaScript expression." + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/example.tcl b/web/src/cgi.tcl-1.10/example/example.tcl new file mode 100644 index 00000000..c1246621 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/example.tcl @@ -0,0 +1,82 @@ +# common definitions for all examples + +# cgi_debug -on + +set NIST_HOST http://www.nist.gov +set MSID_HOST http://www.nist.gov +set EXPECT_HOST http://expect.nist.gov +set EXPECT_ART $EXPECT_HOST/art +set MSID_STAFF $MSID_HOST/msidstaff +set CGITCL $EXPECT_HOST/cgi.tcl +set DATADIR data + +set domainname "unknown" +catch {set domainname [exec domainname]} + +# prevent everyone in the world from sending specious mail to Don! +if {($domainname == "cme.nist.gov") || ([info hostname] == "ats.nist.gov")} { + cgi_admin_mail_addr libes@nist.gov +} + +set TOP target=_top +cgi_link NIST "NIST" $NIST_HOST $TOP +cgi_link Don "Don Libes" $MSID_STAFF/libes $TOP +cgi_link admin "your system administrator" mailto:[cgi_admin_mail_addr] +cgi_link CGITCL "cgi.tcl homepage" $CGITCL $TOP +cgi_link examples "list of examples" [cgi_cgi examples] $TOP +cgi_link realapps "real applications" $CGITCL/realapps.html $TOP +cgi_link Expect "Expect" $EXPECT_HOST $TOP +cgi_link Oratcl "Oratcl" http://www.nyx.net/~tpoindex/tcl.html#Oratcl $TOP + +cgi_imglink logo $EXPECT_ART/cgitcl-powered-feather.gif align=right "alt=powered-by-cgi.tcl logo" +cgi_link logolink [cgi_imglink logo] $CGITCL $TOP + +# Allow for both my development and production environment. And people +# who copy this to their own server and fail to change cgi_root will get +# my production environment! +if {$domainname == "cme.nist.gov"} { + cgi_root "http://www-i.cme.nist.gov/cgi-bin/cgi-tcl-examples" +} else { + cgi_root "http://ats.nist.gov/cgi-bin/cgi.tcl" +} + +proc scriptlink {} { + if {0==[catch {cgi_import framed}]} { + set target "target=script" + } else { + set target "" + } + + cgi_url "the Tcl script" [cgi_cgi display scriptname=[info script]] $target +} + +proc app_body_start {} { + h2 [cgi_title] + puts "See [scriptlink] that created this page." + hr +} + +proc app_body_end {} { + hr; puts "[cgi_link logolink]" + puts "Report problems with this script to [link admin]." + br; puts "CGI script author: [link Don], [link NIST]" + br; puts "Go back to [link CGITCL] or [link examples]." +} + +cgi_body_args bgcolor=#00b0b0 text=#ffffff + +proc user_error {msg} { + h3 "Error: $msg" + cgi_exit +} + +# support for rare examples that must be explicitly framed +proc describe_in_frame {title msg} { + if {0 == [catch {cgi_import header}]} { + cgi_title $title + cgi_body { + p $msg + } + exit + } +} diff --git a/web/src/cgi.tcl-1.10/example/examples.cgi b/web/src/cgi.tcl-1.10/example/examples.cgi new file mode 100755 index 00000000..75afb1e9 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/examples.cgi @@ -0,0 +1,81 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + input + + title "cgi.tcl examples" + + # use targets if we are framed + if {0==[catch {import framed}]} { + set target "target=script" + } else { + set target "" + } + + # create a hyperlink to run a script + proc run {name} { + url $name.cgi [cgi $name] [uplevel {set target}] + } + + # create hyperlink to show script source + proc display {name} { + url $name.cgi [cgi display scriptname=$name.cgi] [uplevel {set target}] + } + + body bgcolor=#d0a0a0 text=#000000 { + p "These are examples of cgi.tcl, a CGI support library for Tcl + programmers. If you would like to show off what you've + written with cgi.tcl, give me an html-formatted blurb and I'll + add it to a page of [link realapps]. For more information, + visit the [link CGITCL]." + + bullet_list { + li "[run cookie] - Cookie example. Also see [run passwd-form] to see cookies in the context of a real application." + li "[run creditcard] - Check a credit card." + li "[run download] - Demonstrate file downloading. Also see [run upload]." + li "[run echo] - Echo everything - good for debugging forms." + li "[run error] - Error handling example." + li "[run evaljs] - Evaluate an expression using JavaScript." + li "[run examples] - Generate the page you are now reading." + li "[run form-tour] and [display form-tour-result] - Show + many different form elements and the backend to process them." + li "[run format-tour] - Demonstrate many formats." + li "[run frame] - Framed example (of this page)." + li "[url "image.cgi" [cgi display-in-frame [cgi_cgi_set scriptname \ + image.cgi]] $target] - Produce a raw image." + li "[run img] - Examples of images embedded in a page." + li "[run kill] - Allow anyone to kill runaway CGI processes." + li "[display oratcl] - Use [link Oratcl] to query an Oracle database." + li "[run nistguest] - Specialized guestbook" + li "[run parray] - Demonstrate parray (print array elements)." + li "[run passwd-form] and [display passwd] - Form for + changing a password and its backend. Note that this CGI script + is [bold not] setuid because it is written using [link Expect]. + The script also demonstrates a nice use of cookies." + li "[run push] - Demonstrate server-push." + li "[run rm] - Allow anyone to remove old CGI files from /tmp." + li "[run stopwatch] - A stopwatch written as a Tcl applet." + li "[display unimail] - A universal mail backend that mails the + values of any form back to the form owner." + li "[run upload] - Demonstrate file uploading. Also see [run download]." + li "[run utf] - Demonstrate UTF output." + li "[run validate] - Validate input fields using JavaScript." + li "[run vclock] - Lincoln Stein's virtual clock. + This was the big example in his CGI.pm paper. Examine the + source to [eval url [list "his Perl version"] \ + [cgi display scriptname=vclock.pl] $target] or compare them + [url "side by side" [cgi vclock-src-frame] target=script2]." + li "[run visitor] - Example of a visitor counter." + li "[run version] - Show version information." + li "[run vote] - Vote for a quote." + li "[run display] - Display a CGI script with clickable + source commands. Not a particularly interesting application - + just a utility to help demo these other CGI scripts! But it is + written using cgi.tcl so it might as well be listed here." + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/form-tour-result.cgi b/web/src/cgi.tcl-1.10/example/form-tour-result.cgi new file mode 100755 index 00000000..d1278ecf --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/form-tour-result.cgi @@ -0,0 +1,69 @@ +#!/depot/path/tclsh + +# This is a CGI script that shows the result of the form tour. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + cgi_title "Form Element Tour Results" + + cgi_body { + h4 "This is a report of variables set by the form tour." + + if {0!=[catch {cgi_import Foo0}]} { + h5 "Error: It appears that you have invoked this script + without going through [cgi_url "the intended form" [cgi_cgi form-tour]]." + cgi_exit + } + + catch { + cgi_import Map.x + cgi_import Map.y + puts "image button coordinates = ${Map.x},${Map.y}[nl]" + } + + catch { + cgi_import Action + puts "submit button Action=$Action[nl]" + br + } + + foreach x {version A B C D} { + catch { + cgi_import $x + puts "radio button \"$x\": [set $x][nl]" + } + } + catch { + cgi_import VegieList + puts "checkbox Vegielist = $VegieList[nl]" + } + for {set i 0} {$i<=6} {incr i} { + set var Foo$i + cgi_import $var + puts "text $var:" + cgi_preformatted { + puts [set $var] + } + } + for {set i 0} {$i<=9} {incr i} { + set var Foo1$i + cgi_import $var + puts "textvar $var:" + cgi_preformatted { + puts [set $var] + } + } + catch { + cgi_import Foo + puts "select pull-down Foo: $Foo[nl]" + } + catch { + cgi_import FooList + puts "select scrolled list FooList: $FooList[nl]" + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/form-tour.cgi b/web/src/cgi.tcl-1.10/example/form-tour.cgi new file mode 100755 index 00000000..7e5e49d5 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/form-tour.cgi @@ -0,0 +1,123 @@ +#!/depot/path/tclsh + +# This is a CGI script that shows a selection of form elements +# This script doesn't actually DO anything. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "A Tour of Form Elements" + + cgi_body { + form form-tour-result { + h4 "Samples of image button" + cgi_put "image as button" + cgi_image_button "=http://www.nist.gov/msidimages/title.gif" + br + cgi_put "image as button (and will return coords)" + cgi_image_button "Map=http://www.nist.gov/public_affairs/gallery/fireseat.jpg" + + h4 "Samples of submit button" + cgi_submit_button + cgi_submit_button ="Submit" + cgi_submit_button "=Submit Form" + cgi_submit_button "Action=Pay Raise" + + h4 "Samples of reset button" + cgi_reset_button + cgi_put "Default Reset Button" + br + cgi_reset_button "Not the Default Reset Button" + cgi_put "Not the Default Reset Button" + + h4 "Samples of radio button" + cgi_radio_button "version=1" + cgi_put "Version 1" + br + cgi_radio_button "version=2" + cgi_put "Version 2" + br + cgi_radio_button "version=3" checked + cgi_put "Version 3" + + br + foreach x {A B C D} { + cgi_radio_button "$x=" checked_if_equal=B + cgi_put "$x" + br + } + + h4 "Samples of checkbox" + cgi_checkbox VegieList=carrot + cgi_put "Carrot" + br + cgi_checkbox VegieList=rutabaga checked + cgi_put "Rutabaga" + br + cgi_checkbox VegieList= + cgi_put "Vegie" + + h4 "Samples of textentry" + set Foo0 "value1" + set Foo1 "value1" + cgi_text Foo0 + br;cgi_text Foo1= + br;cgi_text Foo2=value2 + br;cgi_text Foo3=value2 size=5 + br;cgi_text Foo4=value2 size=5 maxlength=10 + br;cgi_text Foo5=value2 size=10 maxlength=5 + br;cgi_text Foo6=value2 maxlength=5 + + h4 "Samples of textarea" + + set value "A really long line so that we can compare the\ + effect of wrap options." + + set Foo10 "value1" + set Foo11 "value1" + cgi_textarea Foo10 + br;cgi_textarea Foo11= + br;cgi_textarea Foo12=$value + br;cgi_textarea Foo13=$value rows=3 + br;cgi_textarea "Foo14=default wrap" rows=3 cols=7 + br;cgi_textarea Foo15=wrap=off rows=3 cols=7 wrap=off + br;cgi_textarea Foo16=wrap=soft rows=3 cols=7 wrap=soft + br;cgi_textarea Foo17=wrap=hard rows=3 cols=7 wrap=hard + br;cgi_textarea Foo18=wrap=physical rows=3 cols=7 wrap=physical + br;cgi_textarea Foo19=wrap=virtual rows=3 cols=7 wrap=virtual + + h4 "Samples of select as pull-down menu" + cgi_select Foo { + cgi_option one selected + cgi_option two + cgi_option many value=hello + } + + h4 "Samples of select as scrolled list" + cgi_select FooList multiple { + cgi_option one selected + cgi_option two selected + cgi_option many + } + br + cgi_select FooList multiple size=2 { + cgi_option two selected + cgi_option three selected + cgi_option manymore + } + br + # choose "selected" dynamically + cgi_select FooList multiple size=5 { + foreach o [info comm] { + cgi_option $o selected_if_equal=exit + } + } + h4 "Samples of isindex" + } + cgi_isindex + cgi_isindex "prompt=Enter some delicious keywords: " + } +} + diff --git a/web/src/cgi.tcl-1.10/example/format-tour.cgi b/web/src/cgi.tcl-1.10/example/format-tour.cgi new file mode 100755 index 00000000..b399279f --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/format-tour.cgi @@ -0,0 +1,101 @@ +#!/depot/path/tclsh + +# This is a CGI script that shows a selection of format elements + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "A Tour of HTML Elements" + cgi_body { + + definition_list { + term "term" + term_definition "definition of term" + } + + h4 "menu list" + menu_list { + li item1 + li item2 + } + + h4 "directory list" + directory_list { + li item1 + li item2 + } + + h4 "a list item by itself" + li "item" + + h4 "number list (roman, starting from 4)" + number_list type=i value=4 { + li "first element" + li "second" + li value=9 "third, start numbering from 9" + li type=A "fourth, switch to upper-arabic" + } + + h4 "bullet list" + bullet_list { + p "plain text" + li "plain item" + h4 "nested list (disc, starting from 4)" + bullet_list type=disc value=4 { + li "first element" + li "second" + li type=circle "third, type=circle" + li type=square "fourth, type=square" + li "fifth, should remain square" + } + } + + h4 "Character formatting samples" + cgi_put "[bold bold]\ + [italic italic]\ + [underline underline]\ + [strikeout strikeout]\ + [subscript subscript]\ + [superscript superscript]\ + [typewriter typewriter]\ + [blink blink] + [emphasis emphasis]\ + [strong strong]\ + [cite cite]\ + [sample sample]\ + [keyboard keyboard]\ + [variable variable]\ + [definition definition]\ + [big big]\ + [small small]\ + [font color=#4499cc "color=#4499cc"]\ + " + for {set i 1} {$i<8} {incr i} { + puts [cgi_font size=$i "size=$i"] + } + + h4 "Paragraph formatting samples" + + cgi_h1 h1 + cgi_h2 h2 + cgi_h3 h3 + cgi_h4 h4 + cgi_h5 h5 + cgi_h6 h6 + cgi_h7 "h7 (beyond the spec, what the heck)" + cgi_h6 align=right "right-aligned h6" + cgi_p align=right "right-aligned paragraph" + cgi_put put + cgi_blockquote "blockquote" + cgi_address address + cgi_division { + puts "division" + } + cgi_preformatted { + puts "preformatted" + } + } +} + diff --git a/web/src/cgi.tcl-1.10/example/frame.cgi b/web/src/cgi.tcl-1.10/example/frame.cgi new file mode 100755 index 00000000..f8338b47 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/frame.cgi @@ -0,0 +1,32 @@ +#!/depot/path/tclsh + +# This is a CGI script that creates some frames. + +package require cgi + +cgi_eval { + source example.tcl + cgi_input + + cgi_title "Frame example" + + # allow URL's of the form ;# frame.cgi?example=.... + # so as to override default + set example examples ;# default is the examples page itself!! + catch {cgi_import example} + + cgi_frameset rows=100,* { + cgi_frame =$CGITCL + cgi_frameset cols=200,* { + cgi_frame =examples.cgi?framed=yes + cgi_frame script=$example.cgi + } + } + cgi_noframes { + cgi_h1 "uh oh" + + p "This document is designed to be viewed by a Frames-capable + browser. If you see this message your browser is not + Frames-capable." + } +} diff --git a/web/src/cgi.tcl-1.10/example/image.cgi b/web/src/cgi.tcl-1.10/example/image.cgi new file mode 100755 index 00000000..e1321523 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/image.cgi @@ -0,0 +1,29 @@ +#!/depot/path/tclsh +# See description below. + +package require cgi + +cgi_eval { + source example.tcl + cgi_input + + describe_in_frame "raw image" "This CGI script generates a raw + image. The script could be much more complicated - the point is + merely to show the framework. (The picture is of the US National + Prototype Kilogram. It is made of 90% platinum, 10% iridium. It + was assigned to the US in 1889 and is periodically recertified and + traceable to [italic "The Kilogram"] held at + [url "Bureau International des Poids et Mesures" http://www.bipm.fr" $TOP] + in France.)" + + # ignore the junk above this line - the crucial stuff is below + + cgi_content_type "image/jpeg" + + set fh [open $DATADIR/kg.jpg r] + fconfigure stdout -translation binary + fconfigure $fh -translation binary + fcopy $fh stdout + close $fh +} + diff --git a/web/src/cgi.tcl-1.10/example/img.cgi b/web/src/cgi.tcl-1.10/example/img.cgi new file mode 100755 index 00000000..4c84787d --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/img.cgi @@ -0,0 +1,39 @@ +#!/depot/path/tclsh + +# This is a CGI script that shows how to do simple images. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "Images" + + set NIST_IMAGES http://www.nist.gov/images + + cgi_imglink ball $NIST_IMAGES/ball.gif alt=ball + cgi_imglink birdies $NIST_IMAGES/brd-ln.gif alt=birdies + cgi_imglink daemon $NIST_IMAGES/bsd_daemon.gif "alt=Kirk McKusick's BSD deamon" + + # use white background because some of these images require it + cgi_body bgcolor=#ffffff text=#00b0b0 { + + p "Here are some birdies:[cgi_imglink birdies]" + p "and here is your basic ball [cgi_imglink ball] and here is + the BSD daemon [cgi_imglink daemon]." + + p "I like using the same picture" + p "[cgi_imglink ball] over" + p "[cgi_imglink ball] and over" + p "[cgi_imglink ball] and over" + p "[cgi_imglink ball] so I use the cgi_imglink command to make it easy." + + proc ball {} {return [cgi_imglink ball]} + + p "[cgi_imglink birdies]" + + p "[ball]I can make it even easier [ball] by making a ball + procedure [ball] which I've just done. [ball] You could + tell, eh? [ball]" + } +} diff --git a/web/src/cgi.tcl-1.10/example/kill.cgi b/web/src/cgi.tcl-1.10/example/kill.cgi new file mode 100755 index 00000000..f3ffe6a3 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/kill.cgi @@ -0,0 +1,69 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_title "Kill runaway CGI processes" + + cgi_body { + if {0==[catch {cgi_import PidList}]} { + catch {cgi_import Refresh;set PidList {}} + cgi_import Sig + h4 "If this were not a demo, the following commands would be executed:" + foreach pid $PidList { + # to undemoize this and allow processes to be killed, + # change h5 to exec and remove the quotes + if {[catch {h5 "kill -$Sig $pid"} msg]} { + h4 "$msg" + } + } + } + + cgi_form kill { + set ps /bin/ps + if {[file exists /usr/ucb/ps]} { + set ps /usr/ucb/ps + } + + set f [open "|$ps -auxww" r] + table border=2 { + table_row { + table_data {puts kill} + table_data {cgi_preformatted {puts [gets $f]}} + } + while {-1 != [gets $f buf]} { + if {[regexp "$argv0" $buf]} continue + if {![regexp "^http" $buf]} continue + table_row { + table_data { + scan $buf "%*s %d" pid + cgi_checkbox PidList=$pid + } + table_data { + cgi_preformatted {puts $buf} + } + } + } + + } + + submit_button "=Send signal to selected processes" + submit_button "Refresh=Refresh listing" + reset_button + + br; radio_button "Sig=TERM" checked; puts "SIGTERM: terminate gracefully" + br; radio_button "Sig=KILL"; puts "SIGKILL: terminate ungracefully" + br; radio_button "Sig=STOP"; puts "SIGSTOP: suspend" + br; radio_button "Sig=CONT"; puts "SIGCONT: continue" + + p "SIGSTOP and SIGCONT are particularly useful if the + processes aren't yours and the owner isn't around to ask. + Suspend them and let the owner decide later whether to + continue or kill them." + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/nistguest b/web/src/cgi.tcl-1.10/example/nistguest new file mode 100644 index 00000000..651efc9a --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/nistguest @@ -0,0 +1,102 @@ +Alabama +{} {} x +Alaska +{} {} {} +Arizona +{} {} {} +Arkansas +{} {} x +California +{} {} {} +Colorado +{} {} x +Connecticut +{} {} x +Delaware +{} {} x +Florida +{} {} x +Georgia +{} {} {} +Hawaii +{} {} {} +Idaho +{} {} {} +Illinois +{} {} {} +Indiana +{} {} x +Iowa +{} {} x +Kansas +{} {} {} +Kentucky +{} {} {} +Louisiana +{} {} {} +Maine +{} {} x +Maryland +{} {} x +Massachusetts +{} {} {} +Michigan +{} {} x +Minnesota +{} {} x +Mississippi +{} {} {} +Missouri +{} {} x +Montana +{} {} {} +Nebraska +{} {} x +Nevada +{} {} {} +New Hampshire +{} {} x +New Jersey +{} {} x +New Mexico +{} {} {} +New York +{} {} x +North Carolina +{} {} x +North Dakota +{} {} {} +Ohio +{} {} {} +Oklahoma +{} {} x +Oregon +{} {} {} +Pennsylvania +{} {} {} +Rhode Island +{} {} {} +South Carolina +{} {} x +South Dakota +{} {} x +Tennessee +{} {} x +Texas +{} {} x +Utah +{} {} x +Vermont +{} {} {} +Virginia +{} {} x +Washington +{} {} x +Washington DC +{} {} {} +West Virginia +{} {} {} +Wisconsin +{} {} x +Wyoming +{} {} {} diff --git a/web/src/cgi.tcl-1.10/example/nistguest.cgi b/web/src/cgi.tcl-1.10/example/nistguest.cgi new file mode 100755 index 00000000..b41d456b --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/nistguest.cgi @@ -0,0 +1,130 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + cgi_input + + cgi_title "NIST Guest Book" + + cgi_uid_check http + + set BarURL $EXPECT_ART/pink.gif + + set Q(filename) "$DATADIR/nistguest" + + set statesNeeded {} + + proc poll_read {} { + global Q + + set fid [open $Q(filename) r] + while {-1!=[gets $fid StateFullName]} { + regsub " " $StateFullName "" State + set Q($State) $StateFullName + gets $fid buf + foreach "Q($State,1) Q($State,2) Q($State,3)" $buf {} + lappend Q(statesAll) $State + if {0 == [string compare "" "$Q($State,3)"]} { + lappend Q(statesNeeded) $State + } + } + close $fid + } + + proc poll_write {} { + global Q + + # No file locking or real database handy so we can't guarantee that + # simultaneous votes aren't dropped, but we'll at least avoid + # corruption of the file by working on a private copy. + set tmpfile $Q(filename).[pid] + set fid [open $tmpfile w] + foreach state $Q(statesAll) { + set data [list $Q($state,1) $Q($state,2) $Q($state,3)] + puts $fid $Q($state)\n$data + } + close $fid + exec mv $tmpfile $Q(filename) + } + + cgi_body { + poll_read + + if {0 == [catch {cgi_import State}]} { + if {![info exists Q($State)]} { + user_error "There is no such state: $State" + } + + set Name "" + catch {import Name} + if {0==[string length $Name]} { + user_error "You didn't provide your name." + } + + set Email "" + catch {import Email} + + set Description "" + catch {import Description} + if {0==[string length $Description]} { + user_error "You didn't provide a description." + } + + set data "<Name $Name><Email $Email><Description $Description>" + # simplify poll_read by making each entry a single line + regsub -all \n $data " " data + + if {0 == [string compare "" $Q($State,1)]} { + set Q($State,1) $data + } elseif {0 == [string compare "" $Q($State,2)]} { + set Q($State,2) $data + } else { + set Q($State,3) $data + } + + poll_write + puts "Thanks for your submission!" + + return + } + + form nistguest { + puts "In the spirit of Scriptics' request for Tcl success +stories, our group at NIST is looking for some too. It's time for our +annual report to Congress. So if your state appears in the list below +and you can provide a brief description of how our work has helped +you, we would appreciate hearing from you." + hr + br;puts "If your state does not appear in this list, then we +already have enough entries for your state. Thanks anyway!" + br;puts "State:" + cgi_select State { + foreach state $Q(statesNeeded) { + option "$Q($state)" value=$state + } + } + + br;puts "Full name:" + cgi_text Name= + + br;puts "We probably won't need to contact you; But just in +case, please provide some means of doing so. Email info will remain +confidential - you will NOT be put on any mailing lists." + br;puts "Email:" + cgi_text Email= + puts "(optional)" + + p "Please describe a significant impact (e.g., goals +accomplished, hours/money saved, user expectations met or exceeded) +that NIST's Tcl-based work (Expect, cgi.tcl, APDE, APIB, EXPRESS +server, ...) has had on your organization. A brief paragraph is +fine." + + cgi_textarea Description= rows=10 cols=80 + br + submit_button "=Submit" + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/oratcl.cgi b/web/src/cgi.tcl-1.10/example/oratcl.cgi new file mode 100644 index 00000000..de4a7626 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/oratcl.cgi @@ -0,0 +1,33 @@ +#!/depot/path/tclsh + +# This is a CGI script that demonstrates how easy it is to use a web +# page to query an Oracle server - using cgi.tcl and Oratcl. +# This example fetches the date from Oracle. + +# I wish we had a public account on our Oracle server so that I could +# allow anyone to run this, but alas we don't. So you'll have to +# trust me that it works. - Don + +package require cgi +package require Oratcl + +cgi_eval { + source example.tcl + + cgi_title "Oracle Example" + cgi_input + + cgi_body { + set env(ORACLE_SID) fork + set env(ORACLE_HOME) /u01/oracle/product/7322 + + set logon [oralogon [import user] [import password]] + set cursor [oraopen $logon] + + orasql $cursor "select SysDate from Dual" + h4 "Oracle's date is [orafetch $cursor]" + + oraclose $cursor + oralogoff $logon + } +} diff --git a/web/src/cgi.tcl-1.10/example/parray.cgi b/web/src/cgi.tcl-1.10/example/parray.cgi new file mode 100755 index 00000000..a4c23316 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/parray.cgi @@ -0,0 +1,48 @@ +#!/depot/path/tclsh + +# This is a CGI script that displays the environment or another array. + +package require cgi + +cgi_eval { + source example.tcl + + proc arrays {} { + uplevel #0 { + set buf {} + foreach a [info globals] { + if {[array exists $a]} { + lappend buf $a + } + } + return $buf + } + } + + cgi_input + + cgi_title "Display environment or another array" + + cgi_body { + p "This script displays the environment or another array." + if {[catch {cgi_import Name}]} { + set Name env + } + + cgi_form parray { + cgi_select Name { + foreach a [arrays] { + cgi_option $a selected_if_equal=$Name + } + } + cgi_submit_button + } + + global $Name + if {[array exist $Name]} { + cgi_parray $Name + } else { + puts "$Name: no such array" + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/passwd-form.cgi b/web/src/cgi.tcl-1.10/example/passwd-form.cgi new file mode 100755 index 00000000..9d99b716 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/passwd-form.cgi @@ -0,0 +1,39 @@ +#!/depot/path/tclsh + +# This is a CGI script to present a form in which to change a password. + +# This form doesn't actually have to be written as a CGI script, +# however, it is done so here to demonstrate the procedures described +# in the Tcl '96 paper by Don Libes. You can find this same form +# written as static html in the example directory of the Expect +# package. + +package require cgi + +cgi_eval { + source example.tcl + source passwd.tcl + + cgi_input + + # Use a cookie so that if user has already entered name, don't make them + # do it again. If you dislike cookies, simply remove the next two + # lines - cookie use here is simply a convenience for users. + set login "" + catch {cgi_import_cookie login} + + cgi_title "Change your login password" + cgi_body { + cgi_form passwd { + put "Username: "; cgi_text login size=16 + password "Old" old + password "New" new1 + password "New" new2 + + p "(The new password must be entered twice to avoid typos.)" + + cgi_submit_button "=Change password" + cgi_reset_button + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/passwd.cgi b/web/src/cgi.tcl-1.10/example/passwd.cgi new file mode 100755 index 00000000..85c18174 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/passwd.cgi @@ -0,0 +1,119 @@ +#!/depot/path/expect -- + +# This is a CGI script to process requests created by the accompanying +# passwd.html form. This script is pretty basic, although it is +# reasonably robust. (Purposely intent users can make the script bomb +# by mocking up their own HTML form, however they can't expose or steal +# passwords or otherwise open any security holes.) This script doesn't +# need any special permissions or ownership. +# +# With a little more code, the script can do much more exotic things - +# for example, you could have the script: +# +# - telnet to another host first (useful if you run CGI scripts on a +# firewall), or +# +# - change passwords on multiple password server hosts, or +# +# - verify that passwords aren't in the dictionary, or +# +# - verify that passwords are at least 8 chars long and have at least 2 +# digits, 2 uppercase, 2 lowercase, or whatever restrictions you like, +# or +# +# - allow short passwords by responding appropriately to passwd +# +# and so on. Have fun! +# +# Don Libes, NIST + +package require cgi + +cgi_eval { + source example.tcl + source passwd.tcl + + cgi_input + + # Save username as cookie (see comment in passwd-form script) so that the + # next time users load the form, their username will already be filled in. + # If cookies bother you, simply remove this entire cgi_http_head command. + cgi_http_head { + cgi_content_type text/html + if {0==[catch {cgi_import login}]} { + cgi_export_cookie login expires=never + } + } + + cgi_title "Password Change Acknowledgment" + cgi_body { + if {(![info exists login]) + || [catch {cgi_import old}] + || [catch {cgi_import new1}] + || [catch {cgi_import new2}]} { + errormsg "This page has been called with input missing. Please \ + visit this form by filling out the password change \ + request form." + return + } + + # Prevent user from sneaking in commands (albeit under their own uid). + if {[regexp "\[^a-zA-Z0-9]" $login char]} { + errormsg "Illegal character ($char) in username." + return + } + + log_user 0 + + # Need to su first to get around passwd's requirement that + # passwd cannot be run by a totally unrelated user. Seems + # rather pointless since it's so easy to satisfy, eh? + + # Change following line appropriately for your site. + # (We use yppasswd, but you might use something else.) + spawn /bin/su $login -c "/bin/yppasswd $login" + # This fails on SunOS 4.1.3 (passwd says "you don't have a + # login name") so run on (or telnet first to) host running + # SunOS 4.1.4 or later. + + expect { + -re "Unknown (login|id):" { + errormsg "unknown user: $login" + return + } default { + errormsg "$expect_out(buffer)" + return + } "Password:" + } + send "$old\r" + expect { + "unknown user" { + errormsg "unknown user: $login" + return + } "Sorry" { + errormsg "Old password incorrect" + return + } default { + errormsg "$expect_out(buffer)" + return + } "Old password:" + } + send "$old\r" + expect "New password:" + send "$new1\r" + expect "New password:" + send "$new2\r" + expect -re (.+)\r\n { + set error $expect_out(1,string) + } + close + wait + + if {[info exists error]} { + errormsg "$error" + } else { + successmsg "Password changed successfully." + } + } +} + diff --git a/web/src/cgi.tcl-1.10/example/passwd.tcl b/web/src/cgi.tcl-1.10/example/passwd.tcl new file mode 100644 index 00000000..31de1e17 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/passwd.tcl @@ -0,0 +1,10 @@ +# common definitions for all password-related pages + +proc password {prompt varname} { + br + put "$prompt password: " + cgi_text $varname= type=password size=16 +} + +proc successmsg {s} {h3 "$s"} +proc errormsg {s} {h3 "Error: $s"} diff --git a/web/src/cgi.tcl-1.10/example/push.cgi b/web/src/cgi.tcl-1.10/example/push.cgi new file mode 100755 index 00000000..75aeb98c --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/push.cgi @@ -0,0 +1,37 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + set boundary "ThisRandomString" + + cgi_http_head { + cgi_content_type "multipart/x-mixed-replace;boundary=$boundary" + + puts \n--$boundary + cgi_content_type + } + + cgi_title "Multipart example - 1st page" + cgi_body { + h4 "This is an example of [italic server-push] as implemented + by the multipart MIME type. In contrast with client-pull, push + leaves the connection open and the CGI script remains in control + as to send more information. The additional information can + be anything - this example demonstrates an entire page being + replaced." + } + + puts \n--$boundary + after 5000 + + cgi_content_type + + cgi_title "Multipart example - 2nd page" + cgi_body { + h4 "This page replaced the previous page with no action on the + client side." + } +} diff --git a/web/src/cgi.tcl-1.10/example/rm.cgi b/web/src/cgi.tcl-1.10/example/rm.cgi new file mode 100644 index 00000000..bc9534af --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/rm.cgi @@ -0,0 +1,59 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_title "Remove old CGI files from /tmp" + + cgi_body { + if {0==[catch {cgi_import FileList}]} { + catch {cgi_import Refresh;set FileList {}} + h4 "If this were not a demo, the following commands would have been executed:" + foreach File $FileList { + # prevent deletion of this dir or anything outside it + set File [file tail $File] + switch $File . - .. - "" { + h3 "Illegal filename: $File" + continue + } + + # to undemoize this and allow files to be killed, + # remove h5 and quotes + if {[catch {h5 "file delete -force /tmp/$File"} msg]} { + h4 "$msg" + } + } + } + + cgi_form rm { + set f [open "|/bin/ls -Alt /tmp" r] + table border=2 { + table_row { + table_data {puts "rm -rf"} + table_data {cgi_preformatted {puts "permissions ln owner group size date filename"}} + } + while {-1 != [gets $f buf]} { + if {![regexp " http " $buf]} continue + table_row { + table_data { + regexp ".* (\[^ ]+)$" $buf dummy File + cgi_checkbox FileList=$File + } + table_data { + cgi_preformatted {puts $buf} + } + } + } + + } + + submit_button "=Removed selected files" + submit_button "Refresh=Refresh listing" + reset_button + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/stopwatch.cgi b/web/src/cgi.tcl-1.10/example/stopwatch.cgi new file mode 100755 index 00000000..4fb4f8c3 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/stopwatch.cgi @@ -0,0 +1,64 @@ +#!/depot/path/tclsh + +# This is a CGI script that demonstrates a simple Tcl applet + +package require cgi + +source example.tcl + +set srcdir http://www.nist.gov/mel/div826/src/stopwatch +set plugins http://www.sunlabs.com/research/tcl/plugin + +cgi_link source "source" $srcdir/stopwatch.tcl.html" +cgi_link gz "complete distribution" $srcdir/stopwatch.tar.gz +cgi_link moreplugins "More info on Tcl plugins" $plugins +cgi_link homepage "homepage" $EXPECT_HOST/stopwatch + +cgi_eval { + + cgi_input + + cgi_head { + cgi_title "Stopwatch implemented via Tcl applet" + } + cgi_body { + h3 "Description" + + p "This tclet provides a stopwatch. I wrote it to help me + time talks and individual slides within a talk. Stopwatch can + also be run as a Tk script outside the browser - which is the + way I normally use it. If you want to use it outside the browser, grab the distribution from the stopwatch [cgi_link homepage]." + + h3 "Directions" + + p {Press "start" to start the stopwatch and "stop" to stop it. + "zero" resets the time. You can also edit/cut/paste the time + by hand and set it to any valid time. A second timer is + provided as well. It works just like a normal lap timer.} + + cgi_embed http://www.nist.gov/mel/div826/src/stopwatch/stopwatch.tcl \ + 450x105 + + p "This is the first Tclet I've ever written. Actually, I + just took an existing Tk script I had already written and + wrapped it in an HTML page. It took about 30 minutes to write + the original Tk script (about 80 lines) and 1 minute to embed + it in an HTML page." + + p "Stopwatch is not intended for timing less than one second + or longer than 99 hours. It's easy to make make it show more + but the code doesn't do it as distributed and I have no + interest in adding more and more features until it reads mail. + It's just a nice, convenient stopwatch." + + h3 "For more info" + + cgi_bullet_list { + cgi_li "Stopwatch [cgi_link homepage]." + cgi_li "Stopwatch [cgi_link source] and [cgi_link gz]." + cgi_li "[cgi_link moreplugins]." + } + } +} + + diff --git a/web/src/cgi.tcl-1.10/example/unimail.cgi b/web/src/cgi.tcl-1.10/example/unimail.cgi new file mode 100755 index 00000000..9fca7cb0 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/unimail.cgi @@ -0,0 +1,58 @@ +#!/depot/path/tclsh + +# This script is a universal mail backend. It's handy for creating +# forms that simply email all their elements to someone else. You +# wouldn't use it in a fancy application, but non-programmers like it +# since they can use it to process forms with no CGI scripting at all. +# +# To use, make your form look something like this: +# +# <form action="http://ats.nist.gov/cgi-bin/cgi.tcl/unimail.cgi" method=post> +# <input type=hidden name=mailto value="YOUR EMAIL ADDRESS HERE"> +# ...rest of your form... +# </form> +# +# Note: You can use our action URL to try this out, but please switch +# to using your own local unimail script for production use. Thanks! +# +# Author: Don Libes, NIST + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "Universal mail backend" + + cgi_body { + if {[catch cgi_input errormsg]} { + h2 "Form Error" + p "An error was detected in the form. Please send the + following diagnostics to the form author." + cgi_preformatted {puts $errormsg} + return + } + if {[catch {cgi_import mailto}]} { + h2 "Error: No mailto variable in form." + return + } + if {![info exists env(HTTP_REFERER)]} { + set env(HTTP_REFERER) "unknown" + } + cgi_mail_start $mailto + cgi_mail_add "Subject: submission from web form: $env(HTTP_REFERER)" + cgi_mail_add + catch {cgi_mail_add "Remote addr: $env(REMOTE_ADDR)"} + catch {cgi_mail_add "Remote host: $env(REMOTE_HOST)"} + + foreach item [cgi_import_list] { + cgi_mail_add "$item: [cgi_import $item]" + } + cgi_mail_end + + if {[catch {cgi_import thanks}]} { + set thanks [cgi_buffer {h2 "Thanks for your submission."}] + } + cgi_put $thanks + } +} diff --git a/web/src/cgi.tcl-1.10/example/upload.cgi b/web/src/cgi.tcl-1.10/example/upload.cgi new file mode 100755 index 00000000..9841aa97 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/upload.cgi @@ -0,0 +1,59 @@ +#!/depot/path/tclsh + +# This is a CGI script that demonstrates file uploading. + +package require cgi + +cgi_eval { + source example.tcl + + proc showfile {v} { + catch { + set server [cgi_import_file -server $v] + set client [cgi_import_file -client $v] + set type [cgi_import_file -type $v] + if {[string length $client]} { + h4 "Uploaded: $client" + if {0 != [string compare $type ""]} { + h4 "Content-type: $type" + } + cgi_import showList + foreach show $showList { + switch $show { + "od -c" - "cat" { + h5 "Contents shown using $show" + cgi_preformatted {puts [eval exec $show [list $server]]} + } + } + } + } + exec /bin/rm -f $server + } + } + + cgi_input + + cgi_head { + cgi_title "File upload demo" + } + cgi_body { + if {[info tcl] < 8.1} { + h4 "Warning: This script can not perform binary uploads because the server is running a pre-8.1 Tcl ([info tcl])." + } + + showfile file1 + showfile file2 + + cgi_form upload enctype=multipart/form-data { + p "Select up to two files to upload" + cgi_file_button file1; br + cgi_file_button file2; br + checkbox "showList=cat" checked; + put "show contents using cat" ;br + checkbox "showList=od -c" + put "show contents using od -c" ;br + cgi_submit_button =Upload + } + } +} + diff --git a/web/src/cgi.tcl-1.10/example/utf.cgi b/web/src/cgi.tcl-1.10/example/utf.cgi new file mode 100644 index 00000000..1a5a1243 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/utf.cgi @@ -0,0 +1,17 @@ +#!/local/bin/tclsh + +# Test UTF encoding + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "Study utf encoding" + cgi_html { + cgi_body { + p "I'm going to be living on the Straüße." + } + } +} + diff --git a/web/src/cgi.tcl-1.10/example/validate.cgi b/web/src/cgi.tcl-1.10/example/validate.cgi new file mode 100755 index 00000000..c104b7b5 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/validate.cgi @@ -0,0 +1,76 @@ +#!/depot/path/tclsh + +# This CGI script uses JavaScript to validate a form before submission. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + cgi_head { + title "Using JavaScript to validate a form before submission" + + javascript { + puts { + function odd(num) { + if (num.value % 2 == 0) { + alert("Please enter an odd number!") + num.value = "" + return false + } + return true + } + } + } + noscript { + puts "Sorry - your browser doesn't understand JavaScript." + } + } + + set rownum 0 + proc row {msg {event {}}} { + global rownum + + incr rownum + table_row { + table_data nowrap { + put "Odd number: " + text num$rownum= size=4 $event + } + table_data { + puts $msg + } + } + } + + cgi_body { + set more "" + if {0 == [catch {import num3}]} { + set count [scan $num3 %d num] + if {($count != 1) || ($num % 2 == 0)} { + p "Hey, you didn't enter an odd number!" + } else { + p "Thanks for entering odd numbers!" + set more " more" + } + } + + puts "Please enter$more odd numbers - thanks!" + + cgi_form validate "onSubmit=return odd(this.num2)" { + table { + row "This number will be validated when it is entered." onChange=odd(this.form.num1) + row "This number will be validated when the form is submitted." + row "This number will be validated after the form is submitted." + } + submit_button =Submit + } + + h5 "Note: JavaScript validation should always be accompanied + by validation in the backend (CGI script) since browsers + cannot be relied upon to have JavaScript enabled (or supported + in the first place). Sigh." + } +} diff --git a/web/src/cgi.tcl-1.10/example/vclock-src-frame.cgi b/web/src/cgi.tcl-1.10/example/vclock-src-frame.cgi new file mode 100755 index 00000000..37cd6d4b --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/vclock-src-frame.cgi @@ -0,0 +1,23 @@ +#!/depot/path/tclsh + +# This CGI script displays the Tcl and Perl vclock source side by side. + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "Comparison of vclock source" + + cgi_frameset cols=50%,* { + cgi_frame =[cgi_cgi display scriptname=vclock.cgi] + cgi_frame =[cgi_cgi display scriptname=vclock.pl] + } + cgi_noframes { + cgi_h1 "uh oh" + + p "This document is designed to be viewed by a Frames-capable + browser. If you see this message your browser is not + Frames-capable." + } +} diff --git a/web/src/cgi.tcl-1.10/example/vclock.cgi b/web/src/cgi.tcl-1.10/example/vclock.cgi new file mode 100755 index 00000000..4b925b9f --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/vclock.cgi @@ -0,0 +1,73 @@ +#!/depot/path/tclsh + +# This script implements the "Virtual Clock" used as the example in the +# paper describing CGI.pm, a perl module for generating CGI. +# Stein, L., "CGI.pm: A Perl Module for Creating Dynamic HTML Documents +# with CGI Scripts", SANS 96, May '96. + +# Do you think it is more readable than the other version? +# (If you remove the comments and blank lines, it's exactly +# the same number of lines.) See other comments after script. - Don + +package require cgi + +cgi_eval { + source example.tcl + + cgi_input + + set format "" + if {[llength [cgi_import_list]]} { + if 0==[catch {cgi_import time}] { + append format [expr {[cgi_import type] == "12-hour"?"%r ":"%T "}] + } + catch {cgi_import day; append format "%A "} + catch {cgi_import month; append format "%B "} + catch {cgi_import day-of-month; append format "%d "} + catch {cgi_import year; append format "%Y "} + } else { + append format "%r %A %B %d %Y" + } + + set time [clock format [clock seconds] -format $format] + + cgi_title "Virtual Clock" + + cgi_body { + puts "At the tone, the time will be [strong $time]" + hr + h2 "Set Clock Format" + + cgi_form vclock { + puts "Show: " + foreach x {time day month day-of-month year} { + cgi_checkbox $x checked + put $x + } + br + puts "Time style: " + cgi_radio_button type=12-hour checked;put "12-hour" + cgi_radio_button type=24-hour ;put "24-hour" + br + cgi_reset_button + cgi_submit_button =Set + } + } +} + +# Notes: + +# Time/date generation is built-in to Tcl. Thus, no extra processes +# are necessary and the result is portable. In contrast, CGI.pm +# only runs on UNIX. + +# Displaying checkboxes side by side the way that CGI.pm does by +# default is awful. The problem is that with enough buttons, it's not +# immediately clear if the button goes with the label on the right or +# left. So cgi.tcl does not supply a proc to generate such a +# grouping. I've followed CGI.pm's style here only to show that it's +# trivial to get the same affect, but the formatting in any real form +# is more wisely left to the user. + +# Footer generation (<hr><address>... at end of CGI.pm) is replaced +# by "source example.tcl". Both take one line. diff --git a/web/src/cgi.tcl-1.10/example/vclock.pl b/web/src/cgi.tcl-1.10/example/vclock.pl new file mode 100644 index 00000000..0605f0c7 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/vclock.pl @@ -0,0 +1,59 @@ +#!/usr/local/bin/perl + +# This script is the "Virtual Clock" example in the seminal +# paper describing CGI.pm, a perl module for generating CGI. +# Stein, L., "CGI.pm: A Perl Module for Creating Dynamic HTML Documents +# with CGI Scripts", SANS 96, May '96. + +# Do you think it is more readable than the other version? +# (If you remove the comments and blank lines, it's exactly +# the same number of lines.) - Don + +use CGI; +$q = new CGI; + +if ($q->param) { + if ($q->param('time')) { + $format = ($q->param('type') eq '12-hour') ? '%r ' : '%T'; + } + + $format .= '%A ' if $q->param('day'); + $format .= '%B ' if $q->param('month'); + $format .= '%d ' if $q->param('day-of-month'); + $format .= '%Y ' if $q->param('year'); +} else { + $format = '%r %A %B %d %Y'; +} + +$time = `date '+$format'`; + +# print the HTTP header and the HTML document +print $q->header; +print $q->start_html('Virtual Clock'); +print <<END; +<H1>Virtual Clock</H1> +At the tone, the time will be <STRONG>$time</STRONG>. +END + +print <<END; +<HR> +<H2>Set Clock Format</H2> +END + +# Create the clock settings form +print $q->start_form; +print "Show: "; +print $q->checkbox(-name->'time',-checked=>1); +print $q->checkbox(-name->'day',-checked=>1); +print $q->checkbox(-name->'month',-checked=>1); +print $q->checkbox(-name->'day-of-month',-checked=>1); +print $q->checkbox(-name->'year',-checked=>1); +print "<P>Time style:"; +print $q->radio_group(-name=>'type', + -values=>['12-hour','24-hour']),"<P>"; +print $q->reset(-name=>'Reset'), + $q->submit(-name=>'Set'); +print $q->end_form; + +print '<HR><ADDRESS>webmaster@ferrets.com</ADDRESS>' +print $q->end_html; diff --git a/web/src/cgi.tcl-1.10/example/version.cgi b/web/src/cgi.tcl-1.10/example/version.cgi new file mode 100644 index 00000000..b266acfb --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/version.cgi @@ -0,0 +1,30 @@ +#!/depot/path/tclsh + +# This is a CGI script that displays some version information that I +# find useful for debugging. + +set v [package require cgi] + +proc row {var val} { + table_row { + td $var + td $val + } +} + +cgi_eval { + source example.tcl + + title "Version info" + + cgi_body { + table border=2 { + row "cgi.tcl" $v + row "Tcl" [info patchlevel] + row "uname -a" [exec uname -a] + catch {row "SERVER_SOFTWARE" $env(SERVER_SOFTWARE)} + catch {row "HTTP_USER_AGENT" $env(HTTP_USER_AGENT)} + catch {row "SERVER_PROTOCOL" $env(SERVER_PROTOCOL)} + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/visitor.cgi b/web/src/cgi.tcl-1.10/example/visitor.cgi new file mode 100755 index 00000000..ee73922e --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/visitor.cgi @@ -0,0 +1,30 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + + cgi_title "Visitor count example" + + cgi_body { + cgi_put "This page demonstrates how easy it is to do visitor counts." + + cgi_uid_check http + + cgi_form visitor { + set cfname "$DATADIR/visitor.cnt" + + if {[catch {set fid [open $cfname r+]} errormsg]} { + h4 "Couldn't open $cfname to maintain visitor count: $errormsg" + return + } + gets $fid count + seek $fid 0 start + puts $fid [incr count] + close $fid + h4 "You are visitor $count. Revisit soon!" + cgi_submit_button "=Revisit" + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/visitor.cnt b/web/src/cgi.tcl-1.10/example/visitor.cnt new file mode 100755 index 00000000..5595fa46 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/visitor.cnt @@ -0,0 +1 @@ +95 diff --git a/web/src/cgi.tcl-1.10/example/vote.cgi b/web/src/cgi.tcl-1.10/example/vote.cgi new file mode 100755 index 00000000..6d06b977 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/vote.cgi @@ -0,0 +1,190 @@ +#!/depot/path/tclsh + +package require cgi + +cgi_eval { + source example.tcl + cgi_input + + cgi_title "Vote for a t-shirt design!" + + cgi_uid_check http + + set BarURL $EXPECT_ART/pink.gif + + set Q(filename) "$DATADIR/vote.cnt" + + proc votes_read {} { + global Q + + set Q(Max) 0 + set Q(Votes) 0 + set Q(Indices) "" + + set fid [open $Q(filename) r] + while {-1!=[gets $fid i]} { + gets $fid buf + foreach "Q(Votes,$i) Q(Entry,$i) Q(Name,$i) Q(Email,$i)" $buf {} + lappend Q(Indices) $i + set Q(Unvotable,$i) [catch {incr Q(Votes) $Q(Votes,$i)}] + set Q(Max) $i + } + close $fid + } + + proc votes_write {} { + global Q + + # No file locking (or real database) handy so we can't guarantee that + # simultaneous votes aren't dropped, but we'll at least avoid + # corruption of the vote file by working on a private copy. + set tmpfile $Q(filename).[pid] + set fid [open $tmpfile w] + foreach i $Q(Indices) { + set data [list $Q(Votes,$i) $Q(Entry,$i) $Q(Name,$i) $Q(Email,$i)] + # simplify votes_read by making each entry a single line + regsub -all \n $data <br> data + puts $fid $i\n$data + } + close $fid + exec mv $tmpfile $Q(filename) + } + + proc vote_other_show {} { + global Q + + h3 "Other suggestions" + table border=2 { + table_row { + th width=300 "Entry" + th width=300 "Judge's Comments" + } + foreach i $Q(Indices) { + if {!$Q(Unvotable,$i)} continue + table_row { + td width=300 "$Q(Entry,$i)" + td width=300 "$Q(Votes,$i)" + } + } + } + } + + + cgi_body { + votes_read + + if {[regexp "Vote(\[0-9]+)" [cgi_import_list] dummy i]} { + if {[catch {incr Q(Votes,$i)}]} { + user_error "There is no such entry to vote for." + } + incr Q(Votes) + votes_write + + h3 "Thanks for voting! See you at the next Tcl conference!" + set ShowVotes 1 + } + catch {cgi_import ShowVotes} + if {[info exists ShowVotes]} { + table border=2 { + table_row { + th width=300 "Entry" + th "Votes" + th width=140 "Percent" ;# 100 + room for pct + } + foreach i $Q(Indices) { + if {!$Q(Unvotable,$i)} { + table_row { + td width=300 "$Q(Entry,$i)" + td align=right "$Q(Votes,$i)" + table_data width=140 { + table { + table_row { + set pct [expr 100*$Q(Votes,$i)/$Q(Votes)] + # avoid 0-width Netscape bug + set pct_bar [expr $pct==0?1:$pct] + td [img $BarURL align=left width=$pct_bar height=15] + td $pct + } + } + } + } + } + } + } + form vote { + submit_button "=Submit entry or vote" + submit_button "ShowVotes=Show votes" + } + vote_other_show + return + } + + if 0==[catch {import Entry}] { + if {[string length $Entry] == 0} { + user_error "No entry found." + } + if {[string length $Entry] > 500} { + user_error "Your entry is too long. Keep it under 500 characters!" + } + set Name "" + catch {import Name} + if 0==[string length $Name] { + user_error "You must supply your name. How are we going to know who you are if you win?" + } + set Email "" + catch {import Email} + if 0==[string length $Email] { + user_error "You must supply your email. How are we going to contact you if you win?" + } + + set i [incr Q(Max)] + set Q(Entry,$i) $Entry + set Q(Name,$i) $Name + set Q(Email,$i) $Email + set Q(Votes,$i) 1 + lappend Q(Indices) $i + + votes_write + + h3 "Thanks for your new entry!" + p "No need to go back and vote for it - a vote has already + been recorded for you." + form vote { + submit_button "=Submit another entry or vote" + submit_button "ShowVotes=Show votes" + } + return + } + + p "Vote for what will go on the next Tcl conference t-shirt! (Feel free to vote for several entries.)" + + cgi_form vote { + table border=2 { + foreach i $Q(Indices) { + if {$Q(Unvotable,$i)} continue + table_row { + table_data { + cgi_submit_button Vote$i=Vote + } + td "$Q(Entry,$i)" + } + } + } + br + cgi_submit_button "ShowVotes=Just show me the votes" + hr + p "The author of the winning entry gets fame and glory (and a free t-shirt)! Submit a new entry:" + cgi_text Entry= size=80 + p "Entries may use embedded HTML. Images or concepts are fine - for artwork, we have the same artist who did the [url "'96 conference shirt" $MSID_STAFF/libes/t.html]). The [url judges mailto:tclchairs@usenix.org] reserve the right to delete entries. (Do us a favor and use common sense and good taste!)" + puts "Name: " + cgi_text Name= + br + puts "Email: " + cgi_text Email= + br + cgi_submit_button "=Submit new entry" + + vote_other_show + } + } +} diff --git a/web/src/cgi.tcl-1.10/example/vote.cnt b/web/src/cgi.tcl-1.10/example/vote.cnt new file mode 100644 index 00000000..73bc9061 --- /dev/null +++ b/web/src/cgi.tcl-1.10/example/vote.cnt @@ -0,0 +1,30 @@ +1 +179 {Tcl/Tk: The best-kept secret in the software industry} {Michael McLennan} mmc +2 +{it's got potential, needs more work} {Tcl/Tk: Saving the world one proc at a time} {Michael McLennan} mmc +3 +24 {Tcl/Tk: Programmers by day, heros by the end of the quarter} {Michael McLennan} mmc +4 +39 {Tcl/Tk: The struggle between good and eval} {Michael McLennan} mmc +6 +{already dated} {I love Tcl...but <i>puleeez</i> don't call me Elmo!} {mark pernal} mpernal@sprintmail.com +7 +{surely we have more imagination?} spec-TCL-ular {Joerg Reiberg} reiberg@uni-muenster.de +8 +48 {Tcl/Tk: Less Code, More Results} {Bob Jackson} jackson@stsci.edu +9 +{committed alright} {True Committed Lover} {Stephan Uyttebroeck} stephan@frontierd.com +12 +{may we suggest you invest five minutes reading the manual...} {Tcl/Tk: Welcome to string quoting hell!} {Harry Bovik} bovik+junk@cs.cmu.edu +13 +{We'll make up a special one-of-a-kind t-shirt for you, ok?} {I'd rather be hacking Perl.} psu psu@jprc.com +15 +{has potential but needs more work} {Tcl/Tk: A Rabid Prototyping Language} {Ralph Melton} ralph@cs.cmu.edu +16 +{the important thing is, you were using it!} {Tcl/Tk: If at first you don't succeed, you must have been using it} {Dushyanth Narayanan} bumba=roc_tcltk@cs.cmu.edu +17 +{the Howard Stern / People Magazine version} {perl: the angry drunken scripting language} {John Prevost} visigoth+www@cs.cmu.edu +18 +{already taken by Perl, shucks} {Perl: a fast and powerful tool for creating completely inconsistent, incoherent, and unmaintainable code.} {Don} don@libes.com +19 +{ok, enough Perl bashing!} {Perl: an awesome collection of special cases, side-effects, neato punctuation, and enough ambiguity to make a Ouija board blush.} {Don} don@libes.com |