$Header: /cvsroot/aolserver/aolserver.com/docs/devel/tcl/tcl-examples.html,v 1.1 2002/03/07 19:15:35 kriston Exp $
Example 1: hello
The following example script implements a simple request procedure
which returns 'Hello World'.
# Example 1: Hello World
#
# This simple operation just returns a plain text message.
#
# Things to notice:
#
# * ns_register_proc takes as arguments:
# * the HTTP method
# * the URL that the procedure handles
# * the procedure that is executed
#
# * ns_return takes as arguments:
# * the passed in connection
# * a return status, in this case 200 for success
# * a MIME type
# * the actual string to return
#
# * ns_return properly formats the HTTP response for you.
ns_register_proc GET /example/hello hello
proc hello {conn context} {
ns_return $conn 200 text/plain "Hello World"}
Example 2: showhdrs
The following example script shows how to access the HTTP headers sent
by the client within a Tcl script.
# Example 2: Show header data
#
# Things to notice:
#
# * The same function is registered for two different URLs
# with different context.
#
# * The headers are pulled out of the conn using the
# ns_conn function.
#
# * The value for a particular header line is extracted
# with "ns_set iget", the case insensitive counterpart to
# "ns_set get".
ns_register_proc GET /example/showbrowser showheader USER-AGENT
ns_register_proc GET /example/showrefer showheader REFERER
proc showheader {conn key} {
set value [ns_set iget [ns_conn headers $conn] $key]
ns_return $conn 200 text/plain "$key: $value"
}
Example 3a: genstory
The following example script provides two request procedures. The
first procedure returns an HTML page for collecting a few fields of
data from the user. The second procedure utilizes the data to generate
a short story.
# Example 3a: Form generation and handling
#
# Two functions are registered. One generates and
# returns an HTML form, and the other processes
# the data in the form.
#
# Things to notice:
#
# * Different functions are registered to the same
# URL with different methods. Note that some browsers
# do not cache results properly when you do this.
#
# * The genstory function returns an error status
# (500) if the client doesn't pass in any form data.
#
# * Form data is stored in an ns_set, and accessed
# like any other set (e.g., header data).
#
# * A counter is used to loop through all the key
# value pairs in the form.
ns_register_proc GET /example/genstory genstoryform
ns_register_proc POST /example/genstory genstory
proc genstoryform {conn context} {
ns_return $conn 200 text/html \
"<HTML>
<HEAD>
<TITLE>Automatic Story Generator</TITLE>
</HEAD>
<BODY>
<H1>
Automatic Story Generator
</H1>
<FORM ACTION=http:/example/genstory
METHOD=POST>
Noun: <INPUT TYPE=text NAME=noun1><BR>
Noun: <INPUT TYPE=text NAME=noun2><BR>
Name: <INPUT TYPE=text NAME=name1><BR>
Name: <INPUT TYPE=text NAME=name2><BR>
Adjective: <INPUT TYPE=text NAME=adjective1><BR>
Adjective: <INPUT TYPE=text NAME=adjective2><BR>
Verb: <INPUT TYPE=text NAME=verb1><BR>
Verb: <INPUT TYPE=text NAME=verb2><BR>
<P><INPUT TYPE=submit VALUE=\"Generate\">
</FORM>
<P>
</BODY></HTML>
"}
proc genstory {conn ignore} {
set formdata [ns_conn form $conn]
if {$formdata == ""} {
ns_return $conn 200 text/plain "Need form data!"
return
}
# Build up a human-readable representation of the form data.
set hrformdata "<dl>"
set size [ns_set size $formdata]
for {set i 0} {$i < $size} {incr i} {
append hrformdata "<dt>[ns_set key $formdata $i]</dt>\
<dd>[ns_set value $formdata $i]</dd>"
}
append hrformdata "</dl>"
ns_return $conn 200 text/html \
"<HTML>
<HEAD>
<TITLE>The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]</TITLE>
</HEAD>
<BODY>
<H1>
The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]
</H1>
<P>Once upon a time [ns_set get $formdata name1] and
[ns_set get $formdata name2] went for a
walk in the woods looking for a [ns_set get $formdata noun1].
[ns_set get $formdata name1] was
feeling [ns_set get $formdata adjective1] because
[ns_set get $formdata name2] was so
[ns_set get $formdata adjective2]. So
[ns_set get $formdata name1] decided to
[ns_set get $formdata verb1] [ns_set get $formdata name2]
with a [ns_set get $formdata noun2]. This made
[ns_set get $formdata name2] [ns_set get $formdata verb2]
[ns_set get $formdata name1].
<P><CENTER>The End</CENTER>
The form data that made this possible:<BR>
$hrformdata
</BODY></HTML>"
}
Example 3b: pagetcl/genstory
The following example script implements the same story generating
function of genstory (the previous example) but is implemented as a
page Tcl script instead of a library Tcl script. Note that the
associated HTML file (genstory.htm) is also included after the Tcl
script.
# Example 3b: Form generation and handling
#
# This operation generates a story based on the
# form data submitted from the form genstory.htm.
#
# Things to notice:
#
# * This file should be stored with the HTML pages
# of the server. When a client requests the URL corresponding
# to the file, the AOLserver sets the "conn" variable and
# evaluates the Tcl.
#
# * An error status (500) is returned if the client doesn't
# doesn't pass in any form data.
#
# * Form data is stored in an ns_set, and accessed
# like any other set (e.g., header data).
#
# * A counter is used to loop through all the key
# value pairs in the form.
set formdata [ns_conn form $conn]
if {$formdata == ""} {
ns_return $conn 200 text/plain "Need form data!"
return
}
# Build up a human-readable representation of the form data.
set hrformdata "<dl>"
set size [ns_set size $formdata]
for {set i 0} {$i < $size} {incr i} {
append hrformdata "<dt>[ns_set key $formdata $i]</dt>\
<dd>[ns_set value $formdata $i]</dd>"
}
append hrformdata "</dl>"
ns_return $conn 200 text/html \
"<HTML>
<HEAD>
<TITLE>The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]</TITLE>
</HEAD>
<BODY>
<H1>
The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]
</H1>
<P>Once upon a time [ns_set get $formdata name1] and
[ns_set get $formdata name2] went for a
walk in the woods looking for a [ns_set get $formdata noun1].
[ns_set get $formdata name1] was
feeling [ns_set get $formdata adjective1] because
[ns_set get $formdata name2] was so
[ns_set get $formdata adjective2]. So
[ns_set get $formdata name1] decided to
[ns_set get $formdata verb1] [ns_set get $formdata name2]
with a [ns_set get $formdata noun2]. This made
[ns_set get $formdata name2] [ns_set get $formdata verb2]
[ns_set get $formdata name1].
<P><CENTER>The End</CENTER>
The form data that made this possible:<BR>
$hrformdata
</BODY></HTML>"
Here's the associated HTML file:
<HTML>
<HEAD>
<TITLE>Automatic Story Generator</TITLE>
</HEAD>
<BODY>
<H1>
Automatic Story Generator
</H1>
<FORM ACTION=genstory.tcl METHOD=POST>
Noun: <INPUT TYPE=text NAME=noun1><BR>
Noun: <INPUT TYPE=text NAME=noun2><BR>
Name: <INPUT TYPE=text NAME=name1><BR>
Name: <INPUT TYPE=text NAME=name2><BR>
Adjective: <INPUT TYPE=text NAME=adjective1><BR>
Adjective: <INPUT TYPE=text NAME=adjective2><BR>
Verb: <INPUT TYPE=text NAME=verb1><BR>
Verb: <INPUT TYPE=text NAME=verb2><BR>
<P><INPUT TYPE=submit VALUE="Generate">
</FORM>
<P>
</BODY></HTML>
Example 4: redirect
The following example script shows how to use an AOLserver simple
response command (in this case, ns_returnredirect) and the equivalent
code when sending raw data to the client.
# Example 4: Implementing redirects with ns_respond and
# ns_write
#
# /example/not_here uses ns_respond to return an HTTP
# redirect to /example/finaldest.
# /example/not_here2 does the same thing using ns_write
# /example/not_here3 does the same thing with
# ns_returnredirect
#
# Things to notice:
#
# * When you use ns_write, you need to compose the
# entire response.
#
# * "ns_conn location" returns the http://hostname
# part of the URL that you can use to generate
# fully qualified URLs.
#
# * ns_returnredirect is a lot simpler than either
# ns_respond or ns_write.
ns_register_proc GET /example/finaldest finaldest
ns_register_proc GET /example/not_here not_here
ns_register_proc GET /example/not_here2 not_here2
ns_register_proc GET /example/not_here3 not_here3
proc not_here {conn ignore} {
set headers [ns_set new myheaders]
ns_set put $headers Location \
[ns_conn location $conn]/example/finaldest
ns_respond $conn -status 302 -type text/plain \
-string "Redirection" -headers $headers
}
proc not_here2 {conn context} {
set content \
"<HTML><HEAD><TITLE>Redirection</TITLE></HEAD><BODY>
<H1>Redirection</H1>The actual location of what
you were looking for is
<A HREF=\"[ns_conn location $conn]/example/finaldest\">
here.</A>
</BODY></HTML>"
ns_write $conn \
"HTTP/1.0 302 Document follows
MIME-Version: 1.0
Content-Type: text/html
Content-Length: [string length $content]
Location: [ns_conn location $conn]/example/finaldest
$content"
}
proc finaldest {conn context} {
ns_return $conn 200 text/plain \
"You have arrived at the final destination."
}
proc not_here3 {conn context} {
ns_returnredirect $conn \
[ns_conn location $conn]/example/finaldest
}
Example 5: desctable
The following example script provides a request procedure which
describes the columns of a database table using the AOLserver
"ns_tableinfo" command .
# Example 5: Describing a database table
#
# /example/describetable prints out a column-by-column
# description of a database table. The database
# pool name and table name are specified at the end
# of the URL -- e.g.,
#
# /example/describetable/nsdbpool/ns_users
#
# Note: You must have the ns_db module loaded into your virtual
# server for this example to work.
#
# Things to notice:
#
# * ns_returnbadrequest returns a nicely formatted message
# telling the client they submitted an invalid request.
#
# * "ns_conn urlv" returns a Tcl array whose elements are the
# slash-delimited parts of the URL.
#
# * The describetable function loops through all the columns
# and uses "ns_column valuebyindex" to get the type of each
# one.
#
# * ns_returnnotice nicely formats the return value.
ns_register_proc GET /example/describetable describetable
proc describetable {conn ignore} {
if {[ns_conn urlc $conn] != 4} {
return [ns_returnbadrequest $conn \
"Missing table name and/or poolname"]
}
set pool [lindex [ns_conn urlv $conn] 2]
if {[lsearch $pool [ns_db pools]] == -1} {
return [ns_returnbadrequest $conn \
"Pool $pool does not exist"]
}
set db [ns_db gethandle $pool]
set table [lindex [ns_conn urlv $conn] 3]
set tinfo [ns_table info $db $table]
if {$tinfo == ""} {
return [ns_returnbadrequest $conn \
"Table $table does not exist"]
}
set output "<dl>"
set size [ns_column count $tinfo]
for {set i 0} {$i < $size} {incr i} {
append output "<dt>[ns_column name $tinfo $i] \
<dd>[ns_column typebyindex $tinfo $i]</dd>"
}
append output "</dl><hr>"
ns_returnnotice $conn 200 "Table $table in pool $pool" $output
}
Example 6: getemps
The following example script shows how to query a table in the
database.
# Example 6: Getting data from the database
#
# /example/getemps queries a database in the default
# pool and returns a list of all the employees listed
# in the employees table. It assumes a table called
# employees exists with the column emp_name. You can
# use the /NS/Db/Admin to create the table.
#
# Note: You must have the ns_db module loaded into your virtual
# server for this example to work.
#
# Things to notice:
#
# * Use "ns_db gethandle" to get a handle for the database
# from the default database pool of the virtual server.
#
# * Use "ns_db select" to query the database and
# "ns_db getrow" to retrieve data.
#
# * Rows are returned as ns_sets.
#
ns_register_proc GET /example/getemps getemps
proc getemps {conn context} {
set ul "<UL>"
set db [ns_db gethandle [ns_config [ns_dbconfigpath] "DefaultPool"]]
set row [ns_db select $db \
"select emp_name from employees order by emp_name;"]
while { [ns_db getrow $db $row] } {
append ul "<LI>[ns_set get $row emp_name] \n"
}
append ul "</UL>"
ns_returnnotice $conn 200 "Employee list" $ul
}
Example 7: wincgi
The following example script is a simple emulation of the WebSite
WinCGI interface.
#
# Example 7: simple emulation of the WebSite WinCGI interface
#
# This Tcl script emulates the WinCGI interface of the WebSite server.
# To use, move this file to your Tcl library directory (normally the
# modules/tcl directory of the AOLserver directory), set the
# following nsd.ini variables in the [ns\server\<server-name>\wincgi]
# section, and restart the server.
#
# key default description
# --- ------- -----------
# prefix /cgi-win URL prefix for WinCGI.
# debug off Set to on to keep temp files for debugging.
# gmtoff 0 Minutes West of GMT for the "GMT Offset" variable.
# dir c:\wincgi Directory of WinCGI programs.
#
#
# Note: This script is unsupported and not a complete emulation of the
# WebSite WinCGI interface. In particular, not all the WinCGI variables
# are set. Full support for WinCGI will be incorporated into the nscgi
# module in a future AOLserver release.
#
#
# Fetch the variables from the configuration file.
#
global WinCGI
set WinCGI(section) "ns\\server\\[ns_info server]\\wincgi"
if {[set WinCGI(prefix) [ns_config $WinCGI(section) prefix]] == ""} {
set WinCGI(prefix) /cgi-win
}
if {[set WinCGI(dir) [ns_config $WinCGI(section) dir]] == ""} {
set WinCGI(dir) [ns_info home]/$WinCGI(prefix)
}
if {[set WinCGI(gmtoff) [ns_config $WinCGI(section) gmtoff]] == ""} {
set WinCGI(gmtoff) 0
}
if {[set WinCGI(debug) [ns_config -bool $WinCGI(section) debug]] == ""} {
set WinCGI(debug) 0
}
#
# Register the win-cgi procedure to handle requests for WinCGI executables.
#
ns_register_proc POST $WinCGI(prefix)/*.exe win-cgi
ns_register_proc GET $WinCGI(prefix)/*.exe win-cgi
#
# win-cgi - The Tcl request procedure which emulates WinCGI.
#
proc win-cgi {conn ignored} {
global WinCGI
# The program is the second part of the WinCGI URL.
set args [join [split [ns_conn query $conn] &]]
set pgm [lindex [ns_conn urlv $conn] 1]
regsub -all {\+} $args " " args
foreach e [split $WinCGI(dir)/$pgm /] {
if {$e != ""} {lappend exec $e}
}
set exec [join $exec \\]
if ![file executable $exec] {
return [ns_returnnotfound $conn]
}
# WinCGI requires a few temporary files.
set ini [ns_tmpnam]
set inp [ns_tmpnam]
set out [ns_tmpnam]
# Copy the request content to the input file.
set fp [open $inp w]
ns_writecontent $conn $fp
set len [tell $fp]
close $fp
# Create the WinCGI variables .ini file.
set fp [open $ini w]
puts $fp {[CGI]}
puts $fp \
"Request Protocol=HTTP/1.0
Request Method=[ns_conn method $conn]
Executable Path=$WinCGI(prefix)/$pgm
Server Software=[ns_info name]/[ns_info version]
Server Name=[ns_info name]
Server Port=[ns_info version]
Server Admin=[ns_config AOLserver WebMaster]
CGI Version=CGI/1.2 (Win)
Remote Address=[ns_conn peeraddr $conn]
Authentication Method=Basic
Authentication Realm=[ns_conn location $conn]
Content Type=application/x-www-form-urlencoded
Content Length=$len"
puts $fp ""
puts $fp {[System]}
puts $fp \
"GMT Offset=$WinCGI(gmtoff)
Debug Mode=Yes
Output File=$out
Content File=$inp"
# Set any POST or query form variables.
puts $fp ""
puts $fp {[Form Literal]}
set form [ns_conn form $conn]
if {$form != ""} {
for {set i 0} {$i < [ns_set size $form]} {incr i} {
set key [ns_set key $form $i]
set value [ns_set value $form $i]
puts $fp "$key=$value"
}
}
# Set the accept headers and accumulate the extra headers.
puts $fp ""
puts $fp {[Accept]}
set headers [ns_conn headers $conn]
set extras ""
for {set i 0} {$i < [ns_set size $headers]} {incr i} {
set key [ns_set key $headers $i]
set ukey [string toupper $key]
set value [ns_set value $headers $i]
if {$ukey == "ACCEPT"} {
puts $fp "$value=Yes"
} elseif {$key != "CONTENT-LENGTH" && $key != "CONTENT-TYPE"} {
append extras "$key=$value\n"
}
}
puts $fp ""
puts $fp {[Extra Headers]}
puts $fp $extras
close $fp
# Execute the WinCGI program.
# NB: "catch" the exec and open because a WinCGI
# program can be misbehaved, returning a non-zero
# exit status or not creating the output file.
catch {exec "$exec $ini $inp $out $args"}
if [catch {set fp [open $out]}] {
ns_returnerror $conn 500 "WinCGI exec failed"
} else {
set type text/html
set status 200
while {[gets $fp line] > 0} {
set line [string trim $line]
if {$line == ""} break
set head [split $line :]
set key [string tolower [string trim [lindex $head 0]]]
set value [string trim [lindex $head 1]]
if {$key == "content-type"} {
set type $value
} elseif {$key == "location"} {
set location $value
} elseif {$key == "status"} {
set status $status
}
}
set page [read $fp]
close $fp
if [info exists location] {
ns_returnredirect $conn $location
} else {
ns_return $conn $status $type $page
}
}
if $WinCGI(debug) {
ns_log Notice "CGI $pgm: ini: $ini, inp: $inp, out: $out"
} else {
ns_unlink -nocomplain $ini
ns_unlink -nocomplain $inp
ns_unlink -nocomplain $out
}
}