File: tcl-examples.html

package info (click to toggle)
aolserver4 4.5.1-15.1
links: PTS, VCS
area: main
in suites: wheezy
size: 11,772 kB
sloc: ansic: 45,120; tcl: 5,532; sh: 1,021; makefile: 380; pascal: 219; php: 13
file content (712 lines) | stat: -rw-r--r-- 19,479 bytes
parent folder | download | duplicates (8)
<html>
<head>
<title>AOLserver</title>
</head>
<body>

<h1>Tcl Examples</h1>

<p>
<small>
$Header: /cvsroot/aolserver/aolserver.com/docs/devel/tcl/tcl-examples.html,v 1.1 2002/03/07 19:15:35 kriston Exp $
</small>
<p>


<pre>

 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 \
"&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;Automatic Story Generator&lt;/TITLE&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;
Automatic Story Generator
&lt;/H1&gt;
&lt;FORM ACTION=http:/example/genstory
METHOD=POST&gt;
Noun: &lt;INPUT TYPE=text NAME=noun1&gt;&lt;BR&gt;
Noun: &lt;INPUT TYPE=text NAME=noun2&gt;&lt;BR&gt;
Name: &lt;INPUT TYPE=text NAME=name1&gt;&lt;BR&gt;
Name: &lt;INPUT TYPE=text NAME=name2&gt;&lt;BR&gt;
Adjective: &lt;INPUT TYPE=text NAME=adjective1&gt;&lt;BR&gt;
Adjective: &lt;INPUT TYPE=text NAME=adjective2&gt;&lt;BR&gt;
Verb: &lt;INPUT TYPE=text NAME=verb1&gt;&lt;BR&gt;
Verb: &lt;INPUT TYPE=text NAME=verb2&gt;&lt;BR&gt;
&lt;P&gt;&lt;INPUT TYPE=submit VALUE=\"Generate\"&gt;
&lt;/FORM&gt;
&lt;P&gt;
&lt;/BODY&gt;&lt;/HTML&gt;
"}

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 "&lt;dl&gt;"
  set size [ns_set size $formdata]
  for {set i 0} {$i &lt; $size} {incr i} {
    append hrformdata "&lt;dt&gt;[ns_set key $formdata $i]&lt;/dt&gt;\
     &lt;dd&gt;[ns_set value $formdata $i]&lt;/dd&gt;"
  }
  append hrformdata "&lt;/dl&gt;"

  ns_return $conn 200 text/html \
"&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]&lt;/TITLE&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;
The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]
&lt;/H1&gt;
&lt;P&gt;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].
&lt;P&gt;&lt;CENTER&gt;The End&lt;/CENTER&gt;
The form data that made this possible:&lt;BR&gt;
$hrformdata
&lt;/BODY&gt;&lt;/HTML&gt;"
}



            
              





 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 "&lt;dl&gt;"
set size [ns_set size $formdata]
for {set i 0} {$i &lt; $size} {incr i} {
    append hrformdata "&lt;dt&gt;[ns_set key $formdata $i]&lt;/dt&gt;\
        &lt;dd&gt;[ns_set value $formdata $i]&lt;/dd&gt;"
}
append hrformdata "&lt;/dl&gt;"

ns_return $conn 200 text/html \
"&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]&lt;/TITLE&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;
The story of [ns_set get $formdata name1] and
[ns_set get $formdata name2]
&lt;/H1&gt;
&lt;P&gt;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].
&lt;P&gt;&lt;CENTER&gt;The End&lt;/CENTER&gt;
The form data that made this possible:&lt;BR&gt;
$hrformdata
&lt;/BODY&gt;&lt;/HTML&gt;"

Here's the associated HTML file:

&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;Automatic Story Generator&lt;/TITLE&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;
Automatic Story Generator
&lt;/H1&gt;
&lt;FORM ACTION=genstory.tcl METHOD=POST&gt;
Noun: &lt;INPUT TYPE=text NAME=noun1&gt;&lt;BR&gt;
Noun: &lt;INPUT TYPE=text NAME=noun2&gt;&lt;BR&gt;
Name: &lt;INPUT TYPE=text NAME=name1&gt;&lt;BR&gt;
Name: &lt;INPUT TYPE=text NAME=name2&gt;&lt;BR&gt;
Adjective: &lt;INPUT TYPE=text NAME=adjective1&gt;&lt;BR&gt;
Adjective: &lt;INPUT TYPE=text NAME=adjective2&gt;&lt;BR&gt;
Verb: &lt;INPUT TYPE=text NAME=verb1&gt;&lt;BR&gt;
Verb: &lt;INPUT TYPE=text NAME=verb2&gt;&lt;BR&gt;
&lt;P&gt;&lt;INPUT TYPE=submit VALUE="Generate"&gt;
&lt;/FORM&gt;
&lt;P&gt;
&lt;/BODY&gt;&lt;/HTML&gt;



            
              





 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 \
"&lt;HTML&gt;&lt;HEAD&gt;&lt;TITLE&gt;Redirection&lt;/TITLE&gt;&lt;/HEAD&gt;&lt;BODY&gt;
&lt;H1&gt;Redirection&lt;/H1&gt;The actual location of what
you were looking for is
&lt;A HREF=\"[ns_conn location $conn]/example/finaldest\"&gt;
here.&lt;/A&gt;
&lt;/BODY&gt;&lt;/HTML&gt;"

  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 "&lt;dl&gt;"
    set size [ns_column count $tinfo]
    for {set i 0} {$i &lt; $size} {incr i} {
    append output "&lt;dt&gt;[ns_column name $tinfo $i] \
                &lt;dd&gt;[ns_column typebyindex $tinfo $i]&lt;/dd&gt;"
    }
    append output "&lt;/dl&gt;&lt;hr&gt;"
    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 "&lt;UL&gt;"
        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 "&lt;LI&gt;[ns_set get $row emp_name] \n"
        }
        append ul "&lt;/UL&gt;"
        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\&lt;server-name&gt;\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 &lt; [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 &lt; [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] &gt; 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
    }
}


</pre>


</body>
</html>