You are viewing a plain text version of this content. The canonical link for it is here.
Posted to site-cvs@tcl.apache.org by da...@apache.org on 2002/07/09 09:09:50 UTC
cvs commit: tcl-site/websh/examples checkbox_ws3.txt cookie_ws3.txt dispatch_1_ws3.txt emailform_ws3.txt helloworld_ws3.txt image_ws3.txt memory_ws3.txt session_form_ws3.txt upload_ws3.txt ws3tohtml.tcl
davidw 2002/07/09 00:09:50
Modified: websh/examples ws3tohtml.tcl
Added: websh/examples checkbox_ws3.txt cookie_ws3.txt
dispatch_1_ws3.txt emailform_ws3.txt
helloworld_ws3.txt image_ws3.txt memory_ws3.txt
session_form_ws3.txt upload_ws3.txt
Log:
Fixed up examples and links. Added .txt files to download...
Revision Changes Path
1.2 +2 -1 tcl-site/websh/examples/ws3tohtml.tcl
Index: ws3tohtml.tcl
===================================================================
RCS file: /home/cvs/tcl-site/websh/examples/ws3tohtml.tcl,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -r1.1 -r1.2
--- ws3tohtml.tcl 9 Jul 2002 06:54:53 -0000 1.1
+++ ws3tohtml.tcl 9 Jul 2002 07:09:49 -0000 1.2
@@ -3,4 +3,5 @@
catch {
exec /usr/bin/enscript -h -B -t [file root $ws3] --color -Etcl -B --language=html -o [file rootname $ws3].html $ws3
}
-}
\ No newline at end of file
+ file copy $ws3 "[file rootname $ws3]_ws3.txt"
+}
1.1 tcl-site/websh/examples/checkbox_ws3.txt
Index: checkbox_ws3.txt
===================================================================
#
# This Example shows you how to handle checkboxes in a form.
#
# set flag
set first_load "on"
# see confirmation form example
proc page {title code} {
web::putx {<html><head><title>{web::put $title}</title></head>
<body bgcolor="#ffffff" text="#000000">
<h3>{web::put $title}</h3>
}
uplevel $code
web::put "</body></html>\n"
}
# see confirmation form example
proc form {page code} {
web::put "<form enctype=\"text/html\" method=\"post\" action=\"[web::cmdurl $page]\">"
uplevel $code
web::put "</form>"
}
proc showForm {error} {
global first_load
# generate a page with Title "File upload example"
page "checkbox example" {
# generate a form with action "submit"
# the return value of a checkbox is no value or "on"
form "submit" {
# web::match is used to search the value "on" in the variables time_flag and firstload.
# If the value is found it returns a checked.
web::putx {
<br>Please choose the information that should be displayed.<br><br>
Time
<input name="time_flag" type="checkbox" {web::put [web::match "checked" [web::formvar time_flag $first_load] "on"]}>
Day
<input name="day_flag" type="checkbox" {web::put [web::match "checked" [web::formvar day_flag $first_load] "on"]}>
Date
<input name="date_flag" type="checkbox" {web::put [web::match "checked" [web::formvar date_flag $first_load] "on"]}>
<br>
{set output [web::match "%T " [web::formvar time_flag $first_load] "on"]}
{append output [web::match "%A " [web::formvar day_flag $first_load] "on"]}
{append output [web::match "%d.%m.%Y" [web::formvar date_flag $first_load] "on"]}
{web::put [clock format [clock seconds] -format $output]}
<br>
<input type="submit" name="ok" value="Send">
}
}
}
}
# see confirmation form example
web::command default {
showForm 0
}
# With the set first_load 0 we know that the showForm is not displayed
# the first time.
# See also confirmation form example.
web::command submit {
set first_load 0
showForm 0
}
#see dispatch example
web::dispatch
1.1 tcl-site/websh/examples/cookie_ws3.txt
Index: cookie_ws3.txt
===================================================================
# cookie example - store context in a cookie
#
# this example demonstrates how to use cookies with websh3
#
# create session context manager with the name "state"
web::cookiecontext state
# produce the page of this sample application
proc page {} {
# get current access counter from state ...
set cnt [state::cget cnt 0]
# ... and increment right away
#
# Note: cookie must be sent before the first "web::put" is used
# This is because a cookie must be sent as a HTTP header
set newcnt $cnt
incr newcnt
state::cset cnt $newcnt
# commit the changes on the state
state::commit
# now the html output
web::put "<html><head><title>Cookie Example</title></head>"
web::put "<body bgcolor=\"#FFFFFF\">"
# change welcome text depending on state
if { $cnt == 0 } {
# the first time a warm welcome
web::put "<h1>Welcome</h1>"
web::put "to the wonderful world of Websh"
} else {
# then just a hello
web::put "<h1>Hello</h1>"
web::put "looks like this is your visit Nr $cnt"
}
web::put "<p>"
# and give the user the change to:
# - invalidate the cookie
web::put "<a href=\"[web::cmdurl clearCookie]\">reset</a>"
web::put " | "
# - to move on to the next page of the application
# in this example, just go back to the same page
web::put "<a href=\"[web::cmdurl default]\">next visit</a>"
# properly close html code
web::put "</body></html>"
}
web::command clearCookie {
# get current cookie, if any
state::init mycookie
# ... and invalidate immediately
state::invalidate
# show page
page
}
web::command default {
# get current cookie, if any
state::init mycookie
# show page
page
}
# dispatch
web::dispatch
1.1 tcl-site/websh/examples/dispatch_1_ws3.txt
Index: dispatch_1_ws3.txt
===================================================================
# register the websh command "pricelist"
web::command pricelist {
# web::put sends string to the default output channel
# (stdout in the CGI case), including HTTP headers
web::put {<tt><h2>price list</h2></tt>}
# web::cmdurl produces a URL with querystring. In this case,
# we just want to switch back to "default", that's why we omit
# an explicit command name and just use ""
web::put "<a href=\"[web::cmdurl ""]\">back</a>"
}
# register the websh command "default"
web::command default {
# welcome note
web::put {<tt><h2>hello, customer</h2></tt>}
# link to an other HTML page of this application, the price list.
# We generate the URL using web::cmdurl and specify the command
# to be used: it is called pricelist and has been defined above.
web::put "<a href=\"[web::cmdurl pricelist]\">price list</a>"
}
# do the command dispatching
# this will switch into "pricelist" or "default" depending on
# the query_string
web::dispatch
1.1 tcl-site/websh/examples/emailform_ws3.txt
Index: emailform_ws3.txt
===================================================================
# "order" form example
#
# The "customer" fills out a form, say an order form.
# The form data is validated and a confirmation page
# displayed. ALso, a confirmation e-mail is sent to the
# customer.
#
# In addition, logging is used.
# turn on logging
#
# web::logfilter determines which log messages will be sent to the log
# destination. The rule here is: let all log messages pass which have
# facilities that match "*" and which have a level up to and including
# level "debug"
web::logfilter add *.-debug
# define where to send log messages to. Here we use a file
# and again define a log destination based filter, which is again
# "*.-debug" as above
web::logdest add *.-debug file ../../logs/emailform.log
# utility command to handle an HTML page
proc page {title code} {
web::putx {<html><head><title>{web::put $title}</title></head>
<body bgcolor="#ffffff" text="#000000">
<h1>{web::put $title}</h1>
}
uplevel $code
web::put "</body></html>\n"
}
# utility command to handle an html form
proc form {page code} {
web::put "<form method=\"post\" action=\"[web::cmdurl $page]\">"
uplevel $code
web::put "</form>"
}
# define the form where address is entered
proc showForm {error} {
# generate a page with Title "Form"
page "Order Form" {
# generate a form with action "submit"
form "submit" {
web::putx {
<dl>
<dt><b>Name:</b> {
# if "error" flag is set, show the red error message asking for input
if {$error == 1} {
web::put "<font color=\"\#990000\">Please enter your name</font>\n"
}
}
<dd><input type="text" name="name" value="{web::put [web::htmlify [web::formvar name]]}" size="30"><p>
<dt><b>Address:</b>
<dd><textarea name="addr" rows="4" cols="30" wrap="auto">{web::put [web::htmlify [web::formvar addr]]}</textarea><p>
<dt><b>E-Mail:</b> {
# if "error" flag is set, ask for valid e-mail address
if {$error == 2} {
web::put "<font color=\"\#990000\">Please enter a valid email addres</font>\n"
}
}
<dd><input type="text" name="email" value="{web::put [web::htmlify [web::formvar email]]}" size="30"><p>
</dl>
<input type="submit" name="ok" value="Send">
}
}
}
}
# validator:
#
# make sure we have a name of non-zero length.
# Also, make sure the e-mail address is not completely wrong.
proc checkFormData {} {
# check if a value is in the name field
if { [string length [web::formvar name]] < 1} {
# return error code
return 1
}
# log (facility: emailform, level: debug)
web::log emailform.debug {name [web::formvar name] is valid}
# check email
set email [web::formvar email]
# make sure we have alpha-numeric stuff separated by "@"
if {![regexp -nocase {^([a-z0-9]+)@([a-z0-9]+)\.+([a-z]+)$} \
$email email name domain]} {
# return error code
return 2
}
# check length of domain
if {[string length $domain] < 3} {
return 2
}
web::log emailform.debug {email [web::formvar email] is valid}
# looks good: no error
return 0
}
# sendEmail
#
# create the e-mail message and send it to the given e-mail address
proc sendEmail {} {
set emailtxt {
Thank you for your submission.
We have recieved the following information:}
append emailtxt "\nName:\n[web::formvar name]\n"
append emailtxt "Address:\n"
append emailtxt [web::formvar addr]
append emailtxt {
Find more information about Webshell at http://tcl.apache.org/websh/
The team.
}
# log message
web::log emailform.debug "e-mail: $emailtxt"
if { [catch {
# Open pipe for e-mail
set fh [open "| /usr/lib/sendmail [web::formvar email]" w]
puts $fh "From: info@tcl.apache.org"
puts $fh "Subject: websh3 sample application - sample confirmation"
puts $fh ""
puts $fh $emailtxt
close $fh
} cmsg ] } {
showErrorPage
}
}
proc showErrorPage {} {
page "Error" {
web::putx {
<h3>Error</h3>
An error occurred while processing your request.
Please {web::put <a href=\"[web::cmdurl default]\">try</a>} again
<br><br>
If the problem persists, please contact the
{web::put <a href=\"mailto:webmaster@tcl.apache.org\">webmaster</a>}.
}
}
}
proc showConfirmationPage {} {
page "Confirmation" {
web::putx {
<h3>Thank you for your order</h3>
We have recieved the following information:
<dl>
<dt><b>Name:</b>
<dd>{web::put [web::htmlify [web::formvar name]]}<p>
<dt><b>Address:</b>
<dd>{
# take care of linebreaks in address
regsub -all "\r\n" [web::htmlify [web::formvar addr]] "<br>" addr
web::put $addr
}<p>
<dt><b>E-Mail:</b>
<dd>{web::put [web::htmlify [web::formvar email]]}<p>
</dl>
You should recieve a confirmation by e-mail shortly.
<br>
{web::put <a href=\"[web::cmdurl default]\">Order more</a>}
cool stuff.
}
}
}
# register the "default" command
#
# This command will be used whenever no specific command has been specified.
# We use it to show an empty form for address submission.
web::command default {
showForm 0
}
# register command "submit"
#
# This is the "action" of our form. The form data is validated. If
# the formdata is incomplete or invalid, the form is re-displayed with
# an error info, where the original input is displayed as well.
#
# If the data is valid, the confirmation page is shown and
# an e-mail is sent to the specified address.
web::command submit {
if { [set res [checkFormData]] == 0 } {
sendEmail
showConfirmationPage
} else {
showForm $res
}
}
web::dispatch
1.1 tcl-site/websh/examples/helloworld_ws3.txt
Index: helloworld_ws3.txt
===================================================================
# Hello world
web::put "Hello, world"
1.1 tcl-site/websh/examples/image_ws3.txt
Index: image_ws3.txt
===================================================================
# gif sample - return a image/gif instead of text/html
#
# this example demonstrates how to use cookies with websh3
#
web::command image {
set nr [format %2.2d [expr int(rand() * 13)]]
# open a file (JPEG is a binary format)
set fh [open [GetFileName [file join .. images memory $nr.jpg]] r]
fconfigure $fh -translation binary
set img [read $fh]
close $fh
# set HTTP header to "image/jpeg" instead of "text/html"
array set headers [web::response -set header]
set headers(Content-Type) image/jpeg
web::response -set header [array get headers]
# because we return a img, change to binary again
fconfigure [web::response] -translation binary
# output
web::put $img
}
# produce the page of this sample application
proc page {} {
web::put "<html><head><title>Image Example</title></head>"
web::put "<body bgcolor=\"#FFFFFF\">"
# the images: returned by the same app, but a different command
web::put "<img src=\"[web::cmdurl image]\" width=\"50\" height=\"50\"\"><br>"
web::put "<a href=\"[web::cmdurl default]\">next</a>"
# properly close html code
web::put "</body></html>"
}
web::command default {
page
}
# dispatch (see "dispatch_example")
web::dispatch
1.1 tcl-site/websh/examples/memory_ws3.txt
Index: memory_ws3.txt
===================================================================
#
# short intro
#
# game "memory": the player is supposed N pairs of pictures with the
# least possible amount of tries. We thus keep track of:
# s the current status of the pictures
# 0 backside up
# 1 front up
# 2 permanently open
# i the array of pictures used for this game
# (varies with each reshufflement)
# l the current level (translates into N)
# h which pictures have been "hit", ie selected by the player
# r the refresh rate
#
# the application needs to
# * reshuffle --> generate new i
# * find matching --> check/modify status
# * change level --> keep track of l and reshuffle
# * show help text
# * change refresh rate
# * keep track of best player
#
# turn logging on
web::logfilter add memory.-debug
web::logdest add memory.-debug file [file join / tmp memory.log]
# config: map level number to X-Y dimensions
set _levels(1) [list 1 2]
set _levels(2) [list 1 4]
set _levels(3) [list 2 5]
set _levels(4) [list 3 6]
set _levels(5) [list 4 7]
set _levels(6) [list 5 8]
set _levels(7) [list 6 9]
# setup file context
web::filecontext mctx -path [file join / tmp %s.ctx]
# formatLink -- helper function to generate hrefs
proc formatLink {url {show ""}} {
if {$show == ""} { set show $url }
return "<a href=\"$url\">$show</a>"
}
# putLink -- helper function to output links
proc putLink {url {show ""}} {
web::put [formatLink $url $show]
}
# putLinkHtmlified -- helper function to output links
proc putLinkHtmlified {url show} {
web::put [formatLink $url [web::htmlify $show]]
}
# commandList -- add "commands" line to HTML page
proc commandList {} {
web::put "<tt>"
putLinkHtmlified [web::cmdurl decrementLevel] "<"
web::put " | "
putLinkHtmlified [web::cmdurl incrementLevel] ">"
web::put " | "
putLinkHtmlified [web::cmdurl reset] "x"
web::put " | "
putLinkHtmlified [web::cmdurl new] new
web::put " | "
putLinkHtmlified [web::cmdurl help] "?"
web::put " | "
putLinkHtmlified [web::cmdurl incrRefreshTime] "+"
web::put " | "
putLinkHtmlified [web::cmdurl decrRefreshTime] "-"
# load hall of fame
mctx::init memory
# get the lowest number of tries for this level from the session context
# why do I use web::cmdurlcfg here instead of web::param ?
# I do not want to bother about the level when I generate a URL
# using web::cmdurl - I keep it in the static parameters (managed
# by web::cmdurlcfg).
set best [mctx::cget hof([web::cmdurlcfg l]) "n/a"]
web::put " (level: [web::cmdurlcfg l], [web::cmdurlcfg c] tries, best: $best)"
web::put "</tt>\n"
web::put "<br>\n"
}
# page -- helper function to produce an HTML page
proc page {title code} {
# HTML header stuff
web::put "
<html>
<head>
<title>$title</title>
</head>
<body bgcolor=\"#ffffff\">
"
web::put "<br>\n"
# depends on the caller
uplevel 1 $code
# add list of commands
web::put "<hr>\n"
commandList
# footer and end-of-HTML
web::put "
<hr><font size=\"-2\"><tt>
[web::copyright -version]</tt></font><br>
</BODY>
</HTML>
"
}
# table -- helper function to output a HTML table
proc table {code} {
web::put {<table border="0" cellspacing="0" cellpadding="0">}
web::put "\n"
uplevel 1 $code
web::put "\n</table>\n"
}
# tablerow --
proc tablerow {code {bgcolor {}}} {
if {[string length $bgcolor] } {
web::put "<tr bgcolor=\"$bgcolor\">\n"
} else {
web::put "<tr>\n"
}
uplevel 1 $code
web::put "\n</tr>\n"
}
# tablecell --
proc tablecell {code} {
web::put "<td>\n"
uplevel 1 $code
web::put "\n</td>\n"
}
# image --
proc image {gif} {
set res "<img src=\"/websh/images/memory/$gif\" width=\"50\" height=\"50\" vspace=\"0\" hspace=\"0\""
append res "border=\"1\" ALIGN=\"middle\">"
return $res
}
# validateImg -- check current game status
proc validateImg {vImg vStatus} {
global _levels
upvar $vImg img
upvar $vStatus status
# no images - this calls for a new game. Reshuffle.
if { [string length $img] < 2} {
# reset try counter
web::cmdurlcfg -set c 0
# get current level
set tmp $_levels([web::cmdurlcfg l])
# reshuffle (number of images depends on level)
set numImg [expr ([lindex $tmp 0] * [lindex $tmp 1]) / 2]
for {set i 0} {$i < $numImg} {incr i} {
set timg [format %2.2d $i]
# for this image, generate two random numbers which will
# determine the position of the image in the game
while {1} {
set r1 [expr rand()]
if { ![info exists shuffle($r1)] } { break }
}
while {1} {
set r2 [expr rand()]
if { ![info exists shuffle($r2)] } { break }
}
set shuffle($r1) $timg
set shuffle($r2) $timg
}
# compile string which describes game outline
set img ""
foreach tmp [array names shuffle] {
append img $shuffle($tmp)
}
# and set status of every image to "closed"
set status [string repeat "0" [expr {$numImg * 2}]]
}
}
# listOpen -- helper function to list currently open pictures
proc listOpen {vStatus {val 1}} {
upvar $vStatus status
set i 0
set res ""
foreach tmp [split $status ""] {
if { $tmp == $val } {lappend res $i}
incr i
}
return $res
}
# countOpen -- helper to count all pictures that have a given status
proc countOpen {vStatus {val 1}} {
upvar $vStatus status
set res [listOpen status $val]
return [llength $res]
}
# doMatch -- helper to decide if two selected images match
proc doMatch {vImg vOpens} {
upvar $vImg img
upvar $vOpens opens
set img1 [getImageFromArray img [lindex $opens 0]]
set img2 [getImageFromArray img [lindex $opens 1]]
if {[string equal $img1 $img2]} {
set res [list 1]
lappend res [lindex $opens 0]
lappend res [lindex $opens 1]
} else {
set res [list 0]
lappend res [lindex $opens 0]
lappend res [lindex $opens 1]
}
return $res
}
# getImageFromArray -- helper to extract two letters from string
proc getImageFromArray {vImg pos} {
upvar $vImg img
return [string range $img [expr $pos*2] [expr $pos*2 + 1]]
}
# getStat -- helper to pick status for a given picture
proc getStat {vStatus pos} {
upvar $vStatus status
return [string index $status $pos]
}
# setStat -- set status
proc setStat {vStatus pos {new 0}} {
upvar $vStatus status
set res [string range $status 0 [expr $pos - 1]]
set res $res$new
set res $res[string range \
$status [expr $pos + 1] [string length $status]]
set status $res
}
# toggleStat -- toggle status: switch 0->1 or 1->0, but keep 2 at 2
proc toggleStat {vStatus pos} {
upvar $vStatus status
set cur [getStat status $pos]
if {$cur == 0} {
setStat status $pos 1
} elseif { $cur == 2 } {
setStat status $pos 2
} else {
setStat status $pos 0
}
}
# findMatching -- see if the user did find two matching images
proc findMatching {vImg vStatus} {
upvar $vImg img
upvar $vStatus status
# in case only one is open, we prevent closing it again
set tmp [listOpen status 1]
set onlyone -1
if { [llength $tmp] == 1 } {
set onlyone [lindex $tmp 0]
}
# which ones are selected ?
set hitlst [web::param h]
foreach tmp $hitlst {
# if it is not the single one that is already open, flip it
if {$tmp != $onlyone} {
toggleStat status $tmp
}
}
# now, how many are open, really ?
set opens [listOpen status]
set Nopen [llength $opens]
# more than two open ? (no tricks !)
if { $Nopen > 2 } {
foreach tmp $opens {
setStat status $tmp 0
}
} elseif { $Nopen == 2 } {
# get current try counter (or 0 if not set) ...
set tmp [web::cmdurlcfg c 0]
# ... and increment it and store it back as static parameter
web::cmdurlcfg -set c [incr tmp]
# do the two selected pictures match ?
set tmp [doMatch img opens]
if { [lindex $tmp 0] == 1 } {
# yes, open permanently
setStat status [lindex $tmp 1] 2
setStat status [lindex $tmp 2] 2
} else {
# no. use the refresh feature
set opens [listOpen status]
# add img and status as static parameters
# (ensure that we have status and img in the URL)
web::cmdurlcfg -set s $status
web::cmdurlcfg -set i $img
# for refresh: simulate clicks on the two open pictures
# that will close them
set tmp [web::cmdurl "" [list h [lindex $opens 0] h [lindex $opens 1]]]
# add the HTTP "refresh" header, using the parameter r for the
# refresh time (using 2 sec as default)
web::response -set Refresh "[web::cmdurlcfg r 2];URL=$tmp"
}
}
# add img and status as static parameters
# (ensure that we have status and img in the URL)
web::cmdurlcfg -set s $status
web::cmdurlcfg -set i $img
}
# display table with memory
proc showMemory {} {
global _levels
global _cache
# get current status from URL
set status [web::param s]
# get current game outline from URL
set img [web::param i]
# asses status of game
validateImg img status
# do we have any matching images ?
findMatching img status
# no more closed ? --> game over --> perhaps we need to update hof
if { [countOpen status 0] == 0} {
mctx::init memory
set best [mctx::cget hof([web::cmdurlcfg l]) -1]
if { ($best == -1) ||
([web::cmdurlcfg c] < $best) } {
mctx::cset hof([web::cmdurlcfg l]) [web::cmdurlcfg c]
mctx::commit
}
}
# get X-Y dimension for game outline from level
set tmp $_levels([web::cmdurlcfg l 5])
set numX [lindex $tmp 0]
set numY [lindex $tmp 1]
# output HTML page
page "memory game" {
# output HTML table
table {
# table rows
for {set i 0} {$i < $numX} {incr i} {
tablerow {
for {set j 0} {$j < $numY} {incr j} {
set tmpCnt [expr $i * $numY + $j]
set timg [getImageFromArray img $tmpCnt]
set curImgStat [getStat status $tmpCnt]
# table cells
tablecell {
if {$curImgStat == 0} {
# show backside
#
# actually, it is a link back to the CGI app,
# recursion of some sort.
#
# from parameter h, showMemory will know which
# picture the player did select
putLink [web::cmdurl "" h $tmpCnt] \
[image back.gif]
} elseif {$curImgStat == 2} {
# two matching found - no link any more, just the image
web::put [image $timg.jpg]
} else {
# show front side
putLink [web::cmdurl "" h $tmpCnt] \
[image $timg.jpg]
}
}
}
}
}
}
}
}
# web::command help -- display help text
web::command help {
page "memory game - help text" {
web::put "<tt>"
web::put "Memory -- find the matching images."
web::put "<p>"
web::put "You can see the hidden image by clicking on its back side. "
web::put "When you have found two matching images, they will remain open "
web::put "from then on. If two images do not match, they will be "
web::put "closed again."
web::put "<p>"
web::put "If the images close again too quickly on your system, "
web::put "you can make the images stay open longer with the "
web::put ""+" command ("-" to close them "
web::put "more quickly)."
web::put "<p>"
web::put ""new" shuffels the images again. "
web::put ""×" restarts the game from the beginning."
web::put "</tt><p>"
}
}
# web::command decrementLevel -- reduce level and show game
web::command decrementLevel {
# I do not want to have to bother about the level when I generate
# URLs using web::cmdurl. So, I put level to the static parameters
# and let web::dispatch track it.
# That's why web::cmdurlcfg is used here, instead of web::param.
set level [web::cmdurlcfg l 5]
if {$level > 1} {incr level -1}
web::cmdurlcfg -set l $level
# changing the level implies resetting the game
web::param -set i ""
showMemory
}
# web::command incrementLevel -- increase level and show game
web::command incrementLevel {
set level [web::cmdurlcfg l 5]
if {$level < 7} {incr level}
web::cmdurlcfg -set l $level
# changing the level implies resetting the game
web::param -set i ""
showMemory
}
# web::command incrRefreshTime -- increase refresh time
web::command incrRefreshTime {
set r [web::cmdurlcfg r 2]
if {$r < 30} {incr r 2}
web::cmdurlcfg -set r $r
showMemory
}
# web::command decrRefreshTime -- decrease refresh time
web::command decrRefreshTime {
set r [web::cmdurlcfg r 2]
if {$r > 2} {incr r -2}
web::cmdurlcfg -set r $r
showMemory
}
# web::command new -- new game on the same level (reshuffle)
web::command new {
web::param -set i ""
showMemory
}
# web::command reset -- back to the defaults
web::command reset {
web::param -set i ""
web::cmdurlcfg -set l 5
showMemory
}
# web::command default -- if nothing is specified, use this one
web::command default {
showMemory
}
# web::dispatch -- decide which command to call
#
# here, we use the tracking feature of dispatch. Whenever dispatch
# finds a parameter from the -track list, it copies it over to the
# static parameters
#
# also, we use -hook to execute code just before web::dispatch will
# call the web::command command. Here, we set the default level to 5
# if it is not yet known.
web::dispatch -track [list l c r] -hook {
web::cmdurlcfg -set l [web::cmdurlcfg l 5]
}
1.1 tcl-site/websh/examples/session_form_ws3.txt
Index: session_form_ws3.txt
===================================================================
# This example shows how persistent sessions can be stored
# on the server.
# It shows two HTML forms which have one input field each.
# You can switch between these two forms using the submit
# buttons. All data given in the form
# Define a memory context to hold some configuration variables.
# The next statement makes a context called 'config' to hold
# these data. It is a cleaner way than making global variables
# because it declares them clearly to be configuration vars.
web::context config
# Now set some configuration variables. Usually put the session
# state files in a directory not accessible through the Web server.
config::cset stateDirectory /tmp/webshstate/
# Create a file counter that generates the session ids. We take
# here an easy number generator, which produces sequential numbers
# and stores the actual counter value in a file
web::filecounter idGenerator -filename [file join [config::cget stateDirectory] counter]
# Create a file context named 'state'. The option '-path' defines
# where the session contexts are stored. '-attachto' defines an
# URL parameter name that might contain an existing session.
# (This parameter name could in fact be extracted using
# 'web::param sid' whenever the session is initalized.)
web::filecontext state -path [file join [config::cget stateDirectory] %s] -attachto sid -idgen "idGenerator nextval"
# Make sure the session state directory exists
file mkdir [config::cget stateDirectory]
proc form {page code} {
# Produces a HTML FORM tag. Nested form variables must be output
# in 'code'.
# The 'page' parameter describes the web::command to call when
# the form is submitted.
web::put "<html><head><title>Session Example</title></head>"
web::put "<body bgcolor=\"#FFFFFF\">"
# form starts here
web::put "<form method=\"POST\" action=\"[web::cmdurl $page]\">"
uplevel $code
web::put "</form>"
web::put "</body></html>"
}
proc putErrorMessage {msg} {
# emit an error message in red.
web::put "<p><font color=\"\#ff0000\">[web::htmlify $msg]</font></p>"
}
proc pageOne {{errorMessage ""}} {
# Display page one of our HTML form.
form processPageOne {
if {[string length $errorMessage]} {
putErrorMessage $errorMessage
}
web::put "Numbers only: <input type=\"text\" name=\"a\" value=\"[web::htmlify [state::cget a]]\">"
web::put "<input type=\"submit\" value=\"Page 2\">"
}
}
proc pageTwo {{errorMessage ""}} {
# Display page two of our HTML form.
form processPageTwo {
if {[string length $errorMessage]} {
putErrorMessage $errorMessage
}
web::put "Not empty: <input type=\"text\" name=\"b\" value=\"[web::htmlify [state::cget b]]\">"
web::put "<input type=\"submit\" value=\"Page 1\">"
}
}
proc saveAllFields {} {
# Save all form fields to state context.
# web::formvar without parameters returns a list of HTML form
# variables sent to this script. web::formvar with the name
# of a field returns its value, if the field does not exist
# it returns an empty list (or an optional 2nd parameter 'default
# value').
# For clarity, we do not handle multiple fields with the same
# name correctly here. If a HTML field is given twice or more
# 'web::formvar -count <fieldname>' would give us the field count
# 'web::formvar <fieldname>' returns then a list of n values.
foreach field [web::formvar names] {
state::cset $field [web::formvar $field]
}
}
# Define two dispatched commands to each show one page of the
# (mini) form. The names of theses application commands will
# be used in the submit action of the form with 'web::cmdurl'.
web::command processPageOne {
state::init
if {![regexp {^[0-9]+$} [web::formvar a]]} {
# The input field does not contain only digits, so show page one again
# including an error message.
pageOne "Please enter a number."
} else {
# Everything ok, so save the form field to persistant session
# and proceed with page two.
saveAllFields
state::commit
pageTwo
}
}
web::command processPageTwo {
state::init
if {![string length [web::formvar b]]} {
# The input field is empty, so show page two again
# including an error message.
pageTwo "Please fill in field."
} else {
# Everything ok, so save the form field to persistant session
# and proceed with page one.
saveAllFields
state::commit
pageOne
}
}
# Define the default command to show page one.
web::command default {
# Initialize a fresh state.
state::init
# Show page one initially.
pageOne
}
# Dispatch to one of the web::commands according to a parameter in the
# URL. This parameter was set using 'web::cmdurl' in the FORM tag in
# procedure 'form'.
# At the very beginning we don't have a command in the URL. Then the
# web::command default is called.
# The '-track' parameter is used to take over the URL parameter 'sid'
# from "incoming" URLs to "outgoing" URLs. This parameters holds
# the session id and makes a session survive
# web::dispatch processes the URL - i.e. extracts parameters from the
# URL - and handles HTML form input sent to this script.
web::dispatch -track sid
1.1 tcl-site/websh/examples/upload_ws3.txt
Index: upload_ws3.txt
===================================================================
# This example demonstrates you how "file upload": sending
# a file to the server thru a html form.
# allow file upload
# uploadfilesize defines the maximum file size upload
# in this case 100 bytes
web::config uploadfilesize 100
# utility command to handle an HTML page
proc page {title code} {
web::putx {<html><head><title>{web::put $title}</title></head>
<body bgcolor="#ffffff" text="#000000">
<h3>{web::put $title}</h3>
}
uplevel $code
web::put "</body></html>\n"
}
# utility command to handle an html form
proc form {page code} {
web::put "<form enctype=\"multipart/form-data\" method=\"post\" action=\"[web::cmdurl $page]\">"
uplevel $code
web::put "</form>"
}
proc showForm {error} {
# generate a page with Title "File upload example"
page "File upload example" {
# generate a form with action "submit"
form "submit" {
web::putx {{
# if "error" flag is set, show the red error message asking for input
if {$error == 1} {
web::put "<font color=\"\#990000\">If you'd like to upload a file,\n you have to insert the path and file name <br></font>"
}
}
<b>File:</b> <input type="file" size="30" name="upload" value="{web::put [web::formvar upload]}"> <input type="submit" name="ok" value="Send">
}
}
}
}
# validator:
#
# make sure we have a name that is more than 1.
proc checkFormData {} {
# string lenght gets the lenght
# "lindex [...] 1" is getting the first line from the list in the variable
if { [string length [lindex [web::formvar upload] 1]] < 1} {
# return error code
return 1
}
# looks good: no error
return 0
}
proc showConfirmationPage {} {
# gets return value from list upload
set localname [lindex [web::formvar upload] 0]
set remotename [lindex [web::formvar upload] 1]
set NumBytesTruncated [lindex [web::formvar upload] 2]
# open pipe for reading uploaded file
set fh [open $localname r]
set chunk [read $fh 10]
close $fh
page "File upload example" {
web::putx {
<b>We have received your file. Thank you.<br><br>
Technical information:</b>
<br>
<table border="0" width="300">
<tr>
<td width="100">
File-path:</td><td width="200">{web::put [web::htmlify $localname]}</td></tr>
<tr>
<td width="100">
Localpath:</td><td width="200">{web::put [web::htmlify $remotename]}</td></tr>
<tr>
<td width="300" colspan="2">
We have configured websh3 to allow a maximum file size of 100 bytes. Therefore
we have truncated the received file by {web::put $NumBytesTruncated} bytes.
</td></tr>
<tr>
<td width="100">Start of content:</td><td width="200">{web::put [web::htmlify $chunk]}</td></tr></table>
<a href="upload">upload another file</a>
}
}
}
# register the "default" command
#
# See confirmation form example.
web::command default {
showForm 0
}
# register command "submit"
#
# This is the "action" of our form. See confirmation form example.
web::command submit {
if { [set res [checkFormData]] == 0 } {
showConfirmationPage
} else {
showForm $res
}
}
#see dispatch example
web::dispatch
---------------------------------------------------------------------
To unsubscribe, e-mail: tcl-site-cvs-unsubscribe@tcl.apache.org
For additional commands, e-mail: tcl-site-cvs-help@tcl.apache.org