AOLserver

# Tcl Examples

$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
        }
    }