home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / ncgi / ncgi.tcl next >
Encoding:
Text File  |  2001-08-17  |  24.4 KB  |  943 lines

  1. # ncgi.tcl
  2. #
  3. # Basic support for CGI programs
  4. #
  5. # Copyright (c) 2000 Ajuba Solutions.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9.  
  10.  
  11. # Please note that Don Libes' has a "cgi.tcl" that implements version 1.0
  12. # of the cgi package.  That implementation provides a bunch of cgi_ procedures
  13. # (it doesn't use the ::cgi:: namespace) and has a wealth of procedures for
  14. # generating HTML.  In contract, the package provided here is primarly
  15. # concerned with processing input to CGI programs.  I have tried to mirror his
  16. # API's where possible.  So, ncgi::input is equivalent to cgi_input, and so
  17. # on.  There are also some different APIs for accessing values (ncgi::list,
  18. # ncgi::parse and ncgi::value come to mind)
  19.  
  20. # Note, I use the term "query data" to refer to the data that is passed in
  21. # to a CGI program.  Typically this comes from a Form in an HTML browser.
  22. # The query data is composed of names and values, and the names can be
  23. # repeated.  The names and values are encoded, and this module takes care
  24. # of decoding them.
  25.  
  26. # We use newer string routines
  27. package require Tcl 8.2
  28.  
  29. package provide ncgi 1.1
  30.  
  31. namespace eval ncgi {
  32.  
  33.     # "query" holds the raw query (i.e., form) data
  34.     # This is treated as a cache, too, so you can call ncgi::query more than
  35.     # once
  36.  
  37.     variable query
  38.  
  39.     # This is the content-type which affects how the query is parsed
  40.  
  41.     variable contenttype
  42.  
  43.     # value is an array of parsed query data.  Each array element is a list
  44.     # of values, and the array index is the form element name.
  45.     # See the differences among ncgi::parse, ncgi::input, ncgi::value
  46.     # and ncgi::valuelist for the various approaches to handling these values.
  47.  
  48.     variable value
  49.  
  50.     # This lists the names that appear in the query data
  51.  
  52.     variable varlist
  53.  
  54.     # This holds the URL coresponding to the current request
  55.     # This does not include the server name.
  56.  
  57.     variable urlStub
  58.  
  59.     # This flags compatibility with Don Libes cgi.tcl when dealing with
  60.     # form values that appear more than once.  This bit gets flipped when
  61.     # you use the ncgi::input procedure to parse inputs.
  62.  
  63.     variable listRestrict 0
  64.  
  65.     # This is the set of cookies that are pending for output
  66.  
  67.     variable cookieOutput
  68.  
  69.     # Support for x-www-urlencoded character mapping
  70.     # The spec says: "non-alphanumeric characters are replaced by '%HH'"
  71.  
  72.     variable i
  73.     variable c
  74.     variable map
  75.  
  76.     for {set i 1} {$i <= 256} {incr i} {
  77.     set c [format %c $i]
  78.     if {![string match \[a-zA-Z0-9\] $c]} {
  79.         set map($c) %[format %.2X $i]
  80.     }
  81.     }
  82.      
  83.     # These are handled specially
  84.     array set map {
  85.     " " +   \n %0D%0A
  86.     }
  87.  
  88.     # I don't like importing, but this makes everything show up in 
  89.     # pkgIndex.tcl
  90.  
  91.     namespace export *
  92. }
  93.  
  94. # ncgi::reset
  95. #
  96. #    This resets the state of the CGI input processor.  This is primarily
  97. #    used for tests, although it is also designed so that TclHttpd can
  98. #    call this with the current query data
  99. #    so the ncgi package can be shared among TclHttpd and CGI scripts.
  100. #
  101. #    DO NOT CALL this in a standard cgi environment if you have not
  102. #    yet processed the query data, which will not be used after a
  103. #    call to ncgi::reset is made.  Instead, just call ncgi::parse
  104. #
  105. # Arguments:
  106. #    newquery    The query data to be used instead of external CGI.
  107. #    newtype        The raw content type.
  108. #
  109. # Side Effects:
  110. #    Resets the cached query data and wipes any environment variables
  111. #    associated with CGI inputs (like QUERY_STRING)
  112.  
  113. proc ncgi::reset {args} {
  114.     global env
  115.     variable query
  116.     variable contenttype
  117.     variable cookieOutput
  118.  
  119.     set cookieOutput {}
  120.     if {[llength $args] == 0} {
  121.  
  122.     # We use and test args here so we can detect the
  123.     # difference between empty query data and a full reset.
  124.  
  125.     if {[info exist query]} {
  126.         unset query
  127.     }
  128.     if {[info exist contenttype]} {
  129.         unset contenttype
  130.     }
  131.     } else {
  132.     set query [lindex $args 0]
  133.     set contenttype [lindex $args 1]
  134.     }
  135. }
  136.  
  137. # ncgi::urlStub
  138. #
  139. #    Set or return the URL associated with the current page.
  140. #    This is for use by TclHttpd to override the default value
  141. #    that otherwise comes from the CGI environment
  142. #
  143. # Arguments:
  144. #    url    (option) The url of the page, not counting the server name.
  145. #        If not specified, the current urlStub is returned
  146. #
  147. # Side Effects:
  148. #    May affects future calls to ncgi::urlStub
  149.  
  150. proc ncgi::urlStub {{url {}}} {
  151.     variable urlStub
  152.     if {[string length $url]} {
  153.     set urlStub $url
  154.     return ""
  155.     } elseif {[info exist urlStub]} {
  156.     return $urlStub
  157.     } elseif {[info exist env(SCRIPT_NAME)]} {
  158.     set urlStub $env(SCRIPT_NAME)
  159.     return $urlStub
  160.     } else {
  161.     return ""
  162.     }
  163. }
  164.  
  165. # ncgi::query
  166. #
  167. #    This reads the query data from the appropriate location, which depends
  168. #    on if it is a POST or GET request.
  169. #
  170. # Arguments:
  171. #    none
  172. #
  173. # Results:
  174. #    The raw query data.
  175.  
  176. proc ncgi::query {} {
  177.     global env
  178.     variable query
  179.  
  180.     if {[info exist query]} {
  181.     # This ensures you can call ncgi::query more than once,
  182.     # and that you can use it with ncgi::reset
  183.     return $query
  184.     }
  185.  
  186.     set query ""
  187.     if {[info exist env(REQUEST_METHOD)]} {
  188.     if {$env(REQUEST_METHOD) == "GET"} {
  189.         if {[info exists env(QUERY_STRING)]} {
  190.         set query $env(QUERY_STRING)
  191.         }
  192.     } elseif {$env(REQUEST_METHOD) == "POST"} {
  193.         if {[info exists env(CONTENT_LENGTH)] &&
  194.             [string length $env(CONTENT_LENGTH)] != 0} {
  195.         set query [read stdin $env(CONTENT_LENGTH)]
  196.         }
  197.     }
  198.     }
  199.     return $query
  200. }
  201.  
  202. # ncgi::type
  203. #
  204. #    This returns the content type of the query data.
  205. #
  206. # Arguments:
  207. #    none
  208. #
  209. # Results:
  210. #    The content type of the query data.
  211.  
  212. proc ncgi::type {} {
  213.     global env
  214.     variable contenttype
  215.  
  216.     if {![info exist contenttype]} {
  217.     if {[info exist env(CONTENT_TYPE)]} {
  218.         set contenttype $env(CONTENT_TYPE)
  219.     } else {
  220.         return ""
  221.     }
  222.     }
  223.     return $contenttype
  224. }
  225.  
  226. # ncgi::decode
  227. #
  228. #    This decodes data in www-url-encoded format.
  229. #
  230. # Arguments:
  231. #    An encoded value
  232. #
  233. # Results:
  234. #    The decoded value
  235.  
  236. proc ncgi::decode {str} {
  237.     # rewrite "+" back to space
  238.     # protect \ from quoting another '\'
  239.     set str [string map [list + { } "\\" "\\\\"] $str]
  240.  
  241.     # prepare to process all %-escapes
  242.     regsub -all -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str
  243.  
  244.     # process \u unicode mapped chars
  245.     return [subst -novar -nocommand $str]
  246. }
  247.  
  248. # ncgi::encode
  249. #
  250. #    This encodes data in www-url-encoded format.
  251. #
  252. # Arguments:
  253. #    A string
  254. #
  255. # Results:
  256. #    The encoded value
  257.  
  258. proc ncgi::encode {string} {
  259.     variable map
  260.  
  261.     # 1 leave alphanumerics characters alone
  262.     # 2 Convert every other character to an array lookup
  263.     # 3 Escape constructs that are "special" to the tcl parser
  264.     # 4 "subst" the result, doing all the array substitutions
  265.  
  266.     regsub -all -- \[^a-zA-Z0-9\] $string {$map(&)} string
  267.     # This quotes cases like $map([) or $map($) => $map(\[) ...
  268.     regsub -all -- {[][{})\\]\)} $string {\\&} string
  269.     return [subst -nocommand $string]
  270. }
  271.  
  272.  
  273. # ncgi::nvlist
  274. #
  275. #    This parses the query data and returns it as a name, value list
  276. #
  277. #     Note: If you use ncgi::setValue or ncgi::setDefaultValue, this
  278. #    nvlist procedure doesn't see the effect of that.
  279. #
  280. # Arguments:
  281. #    none
  282. #
  283. # Results:
  284. #    An alternating list of names and values
  285.  
  286. proc ncgi::nvlist {} {
  287.     set query [ncgi::query]
  288.     set type [ncgi::type]
  289.     switch -glob -- $type {
  290.     "" -
  291.     application/x-www-form-urlencoded -
  292.     application/x-www-urlencoded {
  293.         set result {}
  294.  
  295.         # Any whitespace at the beginning or end of urlencoded data is not
  296.         # considered to be part of that data, so we trim it off.  One special
  297.         # case in which post data is preceded by a \n occurs when posting
  298.         # with HTTPS in Netscape.
  299.  
  300.         foreach {x} [split [string trim $query] &] {
  301.         # Turns out you might not get an = sign,
  302.         # especially with <isindex> forms.
  303.         if {![regexp -- (.*)=(.*) $x dummy varname val]} {
  304.             set varname anonymous
  305.             set val $x
  306.         }
  307.         lappend result [ncgi::decode $varname] [ncgi::decode $val]
  308.         }
  309.         return $result
  310.     }
  311.     multipart/* {
  312.         return [ncgi::multipart $type $query]
  313.     }
  314.     default {
  315.         return -code error "Unknown Content-Type: $type"
  316.     }
  317.     }
  318. }
  319.  
  320. # ncgi::parse
  321. #
  322. #    The parses the query data and stores it into an array for later retrieval.
  323. #    You should use the ncgi::value or ncgi::valueList procedures to get those
  324. #    values, or you are allowed to access the ncgi::value array directly.
  325. #
  326. #    Note - all values have a level of list structure associated with them
  327. #    to allow for multiple values for a given form element (e.g., a checkbox)
  328. #
  329. # Arguments:
  330. #    none
  331. #
  332. # Results:
  333. #    A list of names of the query values
  334.  
  335. proc ncgi::parse {} {
  336.     variable value
  337.     variable listRestrict 0
  338.     variable varlist {}
  339.     if {[info exist value]} {
  340.     unset value
  341.     }
  342.     foreach {name val} [ncgi::nvlist] {
  343.     if {![info exist value($name)]} {
  344.         lappend varlist $name
  345.     }
  346.     lappend value($name) $val
  347.     }
  348.     return $varlist
  349.  
  350. # ncgi::input
  351. #
  352. #    Like ncgi::parse, but with Don Libes cgi.tcl semantics.
  353. #    Form elements must have a trailing "List" in their name to be
  354. #    listified, otherwise this raises errors if an element appears twice.
  355. #
  356. # Arguments:
  357. #    fakeinput    See ncgi::reset
  358. #    fakecookie    The raw cookie string to use when testing.
  359. #
  360. # Results:
  361. #    The list of element names in the form
  362.  
  363. proc ncgi::input {{fakeinput {}} {fakecookie {}}} {
  364.     variable value
  365.     variable varlist {}
  366.     variable listRestrict 1
  367.     if {[info exist value]} {
  368.     unset value
  369.     }
  370.     if {[string length $fakeinput]} {
  371.     ncgi::reset $fakeinput
  372.     }
  373.     foreach {name val} [ncgi::nvlist] {
  374.     set exists [info exist value($name)]
  375.     if {!$exists} {
  376.         lappend varlist $name
  377.     }
  378.     if {[regexp -- List$ $name]} {
  379.         # Accumulate a list of values for this name
  380.         lappend value($name) $val
  381.     } elseif {$exists} {
  382.         error "Multiple definitions of $name encountered in input.\
  383.         If you're trying to do this intentionally (such as with select),\
  384.         the variable must have a \"List\" suffix."
  385.     } else {
  386.         # Capture value with no list structure
  387.         set value($name) $val
  388.     }
  389.     }
  390.     return $varlist
  391.  
  392. # ncgi::value
  393. #
  394. #    Return the value of a named query element, or the empty string if
  395. #    it was not not specified.  This only returns the first value of
  396. #    associated with the name.  If you want them all (like all values
  397. #    of a checkbox), use ncgi::valueList
  398. #
  399. # Arguments:
  400. #    key    The name of the query element
  401. #    default    The value to return if the value is not present
  402. #
  403. # Results:
  404. #    The first value of the named element, or the default
  405.  
  406. proc ncgi::value {key {default {}}} {
  407.     variable value
  408.     variable listRestrict
  409.     variable contenttype
  410.     if {[info exists value($key)]} {
  411.     if {$listRestrict} {
  412.         
  413.         # ncgi::input was called, and it already figured out if the
  414.         # user wants list structure or not.
  415.  
  416.         set val $value($key)
  417.     } else {
  418.  
  419.         # Undo the level of list structure done by ncgi::parse
  420.  
  421.         set val [lindex $value($key) 0]
  422.     }
  423.     if {[string match multipart/* [ncgi::type]]} {
  424.         
  425.         # Drop the meta-data information associated with each part
  426.  
  427.         set val [lindex $val 1]
  428.     }
  429.     return $val
  430.     } else {
  431.     return $default
  432.     }
  433. }
  434.  
  435. # ncgi::valueList
  436. #
  437. #    Return all the values of a named query element as a list, or
  438. #    the empty list if it was not not specified.  This always returns
  439. #    lists - if you do not want the extra level of listification, use
  440. #    ncgi::value instead.
  441. #
  442. # Arguments:
  443. #    key    The name of the query element
  444. #
  445. # Results:
  446. #    The first value of the named element, or ""
  447.  
  448. proc ncgi::valueList {key {default {}}} {
  449.     variable value
  450.     if {[info exists value($key)]} {
  451.     return $value($key)
  452.     } else {
  453.     return $default
  454.     }
  455. }
  456.  
  457. # ncgi::setValue
  458. #
  459. #    Jam a new value into the CGI environment.  This is handy for preliminary
  460. #    processing that does data validation and cleanup.
  461. #
  462. # Arguments:
  463. #    key    The name of the query element
  464. #    value    This is a single value, and this procedure wraps it up in a list
  465. #        for compatibility with the ncgi::value array usage.  If you
  466. #        want a list of values, use ngci::setValueList
  467. #        
  468. #
  469. # Side Effects:
  470. #    Alters the ncgi::value and possibly the ncgi::valueList variables
  471.  
  472. proc ncgi::setValue {key value} {
  473.     variable listRestrict
  474.     if {$listRestrict} {
  475.     ncgi::setValueList $key $value
  476.     } else {
  477.     ncgi::setValueList $key [list $value]
  478.     }
  479. }
  480.  
  481. # ncgi::setValueList
  482. #
  483. #    Jam a list of new values into the CGI environment.
  484. #
  485. # Arguments:
  486. #    key        The name of the query element
  487. #    valuelist    This is a list of values, e.g., for checkbox or multiple
  488. #            selections sets.
  489. #        
  490. # Side Effects:
  491. #    Alters the ncgi::value and possibly the ncgi::valueList variables
  492.  
  493. proc ncgi::setValueList {key valuelist} {
  494.     variable value
  495.     variable varlist
  496.     if {![info exist value($key)]} {
  497.     lappend varlist $key
  498.     }
  499.     set value($key) $valuelist
  500.     return ""
  501. }
  502.  
  503. # ncgi::setDefaultValue
  504. #
  505. #    Set a new value into the CGI environment if there is not already one there.
  506. #
  507. # Arguments:
  508. #    key    The name of the query element
  509. #    value    This is a single value, and this procedure wraps it up in a list
  510. #        for compatibility with the ncgi::value array usage.
  511. #        
  512. #
  513. # Side Effects:
  514. #    Alters the ncgi::value and possibly the ncgi::valueList variables
  515.  
  516. proc ncgi::setDefaultValue {key value} {
  517.     ncgi::setDefaultValueList $key [list $value]
  518. }
  519.  
  520. # ncgi::setDefaultValueList
  521. #
  522. #    Jam a list of new values into the CGI environment if the CGI value
  523. #    is not already defined.
  524. #
  525. # Arguments:
  526. #    key        The name of the query element
  527. #    valuelist    This is a list of values, e.g., for checkbox or multiple
  528. #            selections sets.
  529. #        
  530. # Side Effects:
  531. #    Alters the ncgi::value and possibly the ncgi::valueList variables
  532.  
  533. proc ncgi::setDefaultValueList {key valuelist} {
  534.     variable value
  535.     if {![info exist value($key)]} {
  536.     ncgi::setValueList $key $valuelist
  537.     return ""
  538.     } else {
  539.     return ""
  540.     }
  541. }
  542.  
  543. # ncgi::empty --
  544. #
  545. #    Return true if the CGI variable doesn't exist or is an empty string
  546. #
  547. # Arguments:
  548. #    name    Name of the CGI variable
  549. #
  550. # Results:
  551. #    1 if the variable doesn't exist or has the empty value
  552.  
  553. proc ncgi::empty {name} {
  554.     return [expr {[string length [string trim [ncgi::value $name]]] == 0}]
  555. }
  556.  
  557. # ncgi::import
  558. #
  559. #    Map a CGI input into a Tcl variable.  This creates a Tcl variable in
  560. #    the callers scope that has the value of the CGI input.  An alternate
  561. #    name for the Tcl variable can be specified.
  562. #
  563. # Arguments:
  564. #    cginame        The name of the form element
  565. #    tclname        If present, an alternate name for the Tcl variable,
  566. #            otherwise it is the same as the form element name
  567.  
  568. proc ncgi::import {cginame {tclname {}}} {
  569.     if {[string length $tclname]} {
  570.     upvar 1 $tclname var
  571.     } else {
  572.     upvar 1 $cginame var
  573.     }
  574.     set var [ncgi::value $cginame]
  575. }
  576.  
  577. # ncgi::importAll
  578. #
  579. #    Map a CGI input into a Tcl variable.  This creates a Tcl variable in
  580. #    the callers scope for every CGI value, or just for those named values.
  581. #
  582. # Arguments:
  583. #    args    A list of form element names.  If this is empty,
  584. #        then all form value are imported.
  585.  
  586. proc ncgi::importAll {args} {
  587.     variable varlist
  588.     if {[llength $args] == 0} {
  589.     set args $varlist
  590.     }
  591.     foreach cginame $args {
  592.     upvar 1 $cginame var
  593.     set var [ncgi::value $cginame]
  594.     }
  595. }
  596.  
  597. # ncgi::redirect
  598. #
  599. #    Generate a redirect by returning a header that has a Location: field.
  600. #    If the URL is not absolute, this automatically qualifies it to
  601. #    the current server
  602. #
  603. # Arguments:
  604. #    url        The url to which to redirect
  605. #
  606. # Side Effects:
  607. #    Outputs a redirect header
  608.  
  609. proc ncgi::redirect {url} {
  610.     global env
  611.  
  612.     if {![regexp -- {^[^:]+://} $url]} {
  613.  
  614.     # The url is relative (no protocol/server spec in it), so
  615.     # here we create a canonical URL.
  616.  
  617.     # request_uri    The current URL used when dealing with relative URLs.  
  618.     # proto        http or https
  619.     # server     The server, which we are careful to match with the
  620.     #        current one in base Basic Authentication is being used.
  621.     # port        This is set if it is not the default port.
  622.  
  623.     if {[info exist env(REQUEST_URI)]} {
  624.         # Not all servers have the leading protocol spec
  625.         regsub -- {^https?://[^/]*/} $env(REQUEST_URI) / request_uri
  626.     } elseif {[info exist env(SCRIPT_NAME)]} {
  627.         set request_uri $env(SCRIPT_NAME)
  628.     } else {
  629.         set request_uri /
  630.     }
  631.  
  632.     set port ""
  633.     if {[info exist env(HTTPS)] && $env(HTTPS) == "on"} {
  634.         set proto https
  635.         if {$env(SERVER_PORT) != 443} {
  636.         set port :$env(SERVER_PORT)
  637.         }
  638.     } else {
  639.         set proto http
  640.         if {$env(SERVER_PORT) != 80} {
  641.         set port :$env(SERVER_PORT)
  642.         }
  643.     }
  644.     # Pick the server from REQUEST_URI so it matches the current
  645.     # URL.  Otherwise use SERVER_NAME.  These could be different, e.g.,
  646.     # "pop.scriptics.com" vs. "pop"
  647.  
  648.     if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
  649.         set server $env(SERVER_NAME)
  650.     }
  651.     if {[string match /* $url]} {
  652.         set url $proto://$server$port$url
  653.     } else {
  654.         regexp -- {^(.*/)[^/]*$} $request_uri match dirname
  655.         set url $proto://$server$port$dirname$url
  656.     }
  657.     }
  658.     ncgi::header text/html Location $url
  659.     puts "Please go to <a href=\"$url\">$url</a>"
  660. }
  661.  
  662. # ncgi:header
  663. #
  664. #    Output the Content-Type header.
  665. #
  666. # Arguments:
  667. #    type    The MIME content type
  668. #    args    Additional name, value pairs to specifiy output headers
  669. #
  670. # Side Effects:
  671. #    Outputs a normal header
  672.  
  673. proc ncgi::header {{type text/html} args} {
  674.     variable cookieOutput
  675.     puts "Content-Type: $type"
  676.     foreach {n v} $args {
  677.     puts "$n: $v"
  678.     }
  679.     if {[info exist cookieOutput]} {
  680.     foreach line $cookieOutput {
  681.         puts "Set-Cookie: $line"
  682.     }
  683.     }
  684.     puts ""
  685.     flush stdout
  686. }
  687.  
  688. # ncgi::parseMimeValue
  689. #
  690. #    Parse a MIME header value, which has the form
  691. #    value; param=value; param2="value2"; param3='value3'
  692. #
  693. # Arguments:
  694. #    value    The mime header value.  This does not include the mime
  695. #        header field name, but everything after it.
  696. #
  697. # Results:
  698. #    A two-element list, the first is the primary value,
  699. #    the second is in turn a name-value list corresponding to the
  700. #    parameters.  Given the above example, the return value is
  701. #    {
  702. #        value
  703. #        {param value param2 value param3 value3}
  704. #    }
  705.  
  706. proc ncgi::parseMimeValue {value} {
  707.     set parts [split $value \;]
  708.     set results [list [string trim [lindex $parts 0]]]
  709.     set paramList [list]
  710.     foreach sub [lrange $parts 1 end] {
  711.     if {[regexp -- {([^=]+)=(.+)} $sub match key val]} {
  712.             set key [string trim [string tolower $key]]
  713.             set val [string trim $val]
  714.             # Allow single as well as double quotes
  715.             if {[regexp -- {^["']} $val quote]} { ;# need a " for balance
  716.                 if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} {
  717.                     # Trim quotes and any extra crap after close quote
  718.                     set val $val2
  719.                 }
  720.             }
  721.             lappend paramList $key $val
  722.     }
  723.     }
  724.     if {[llength $paramList]} {
  725.     lappend results $paramList
  726.     }
  727.     return $results
  728. }
  729.  
  730. # ncgi::multipart
  731. #
  732. #    This parses multipart form data.
  733. #    Based on work by Steve Ball for TclHttpd, but re-written to use
  734. #    string first with an offset to iterate through the data instead
  735. #    of using a regsub/subst combo.
  736. #
  737. # Arguments:
  738. #    type    The Content-Type, because we need boundary options
  739. #    query    The raw multipart query data
  740. #
  741. # Results:
  742. #    An alternating list of names and values
  743. #    In this case, the value is a two element list:
  744. #        headers, which in turn is a list names and values
  745. #        content, which is the main value of the element
  746. #    The header name/value pairs come primarily from the MIME headers
  747. #    like Content-Type that appear in each part.  However, the
  748. #    Content-Disposition header is handled specially.  It has several
  749. #    parameters like "name" and "filename" that are important, so they
  750. #    are promoted to to the same level as Content-Type.  Otherwise,
  751. #    if a header like Content-Type has parameters, they appear as a list
  752. #    after the primary value of the header.  For example, if the
  753. #    part has these two headers:
  754. #
  755. #    Content-Disposition: form-data; name="Foo"; filename="/a/b/C.txt"
  756. #    Content-Type: text/html; charset="iso-8859-1"; mumble='extra'
  757. #    
  758. #    Then the header list will have this structure:
  759. #    {
  760. #        content-disposition form-data
  761. #        name Foo
  762. #        filename /a/b/C.txt
  763. #        content-type {text/html {charset iso-8859-1 mumble extra}}
  764. #    }
  765. #    Note that the header names are mapped to all lowercase.  You can
  766. #    use "array set" on the header list to easily find things like the
  767. #    filename or content-type.  You should always use [lindex $value 0]
  768. #    to account for values that have parameters, like the content-type
  769. #    example above.  Finally, not that if the value has a second element,
  770. #    which are the parameters, you can "array set" that as well.
  771. #    
  772. proc ncgi::multipart {type query} {
  773.  
  774.     set parsedType [ncgi::parseMimeValue $type]
  775.     if {![string match multipart/* [lindex $parsedType 0]]} {
  776.     return -code error "Not a multipart Content-Type: [lindex $parsedType 0]"
  777.     }
  778.     array set options [lindex $parsedType 1]
  779.     if {![info exists options(boundary)]} {
  780.     return -code error "No boundary given for multipart document"
  781.     }
  782.     set boundary $options(boundary)
  783.  
  784.     # The query data is typically read in binary mode, which preserves
  785.     # the \r\n sequence from a Windows-based browser.  
  786.     # Also, binary data may contain \r\n sequences.
  787.  
  788.     if {[regexp -- $boundary\r\n $query]} {
  789.         set lineDelim "\r\n"
  790. puts "DELIM"
  791.     } else {
  792.         set lineDelim "\n"
  793. puts "NO"
  794.     }
  795.  
  796.     # Iterate over the boundary string and chop into parts
  797.  
  798.     set len [string length $query]
  799.     # [string length $lineDelim]+2 is for "$lineDelim--"
  800.     set blen [expr {[string length $lineDelim] + 2 + \
  801.             [string length $boundary]}]
  802.     set first 1
  803.     set results [list]
  804.     set offset 0
  805.  
  806.     # Ensuring the query data starts
  807.     # with a newline makes the string first test simpler
  808.     if {[string first $lineDelim $query 0]!=0} {
  809.         set query $lineDelim$query
  810.     }
  811.     while {[set offset [string first $lineDelim--$boundary $query $offset]] \
  812.             >= 0} {
  813.     if {!$first} {
  814.         lappend results $formName [list $headers \
  815.         [string range $query $off2 [expr {$offset -1}]]]
  816.     } else {
  817.         set first 0
  818.     }
  819.     incr offset $blen
  820.  
  821.     # Check for the ending boundary, which is signaled by --$boundary--
  822.  
  823.     if {[string equal "--" \
  824.         [string range $query $offset [expr {$offset + 1}]]]} {
  825.         break
  826.     }
  827.  
  828.     # Split headers out from content
  829.     # The headers become a nested list structure:
  830.     #    {header-name {
  831.     #        value {
  832.     #            paramname paramvalue ... }
  833.     #        }
  834.     #    }
  835.  
  836.         set off2 [string first "$lineDelim$lineDelim" $query $offset]
  837.     set headers [list]
  838.     set formName ""
  839.         foreach line [split [string range $query $offset $off2] $lineDelim] {
  840.         if {[regexp -- {([^:     ]+):(.*)$} $line x hdrname value]} {
  841.         set hdrname [string tolower $hdrname]
  842.         set valueList [parseMimeValue $value]
  843.         if {[string equal $hdrname "content-disposition"]} {
  844.  
  845.             # Promote Conent-Disposition parameters up to headers,
  846.             # and look for the "name" that identifies the form element
  847.  
  848.             lappend headers $hdrname [lindex $valueList 0]
  849.             foreach {n v} [lindex $valueList 1] {
  850.             lappend headers $n $v
  851.             if {[string equal $n "name"]} {
  852.                 set formName $v
  853.             }
  854.             }
  855.         } else {
  856.             lappend headers $hdrname $valueList
  857.         }
  858.         }
  859.     }
  860.  
  861.     if {$off2 > 0} {
  862.             # +[string length "$lineDelim$lineDelim"] for the
  863.             # $lineDelim$lineDelim
  864.             incr off2 [string length "$lineDelim$lineDelim"]
  865.         set offset $off2
  866.     } else {
  867.         break
  868.     }
  869.     }
  870.     return $results
  871. }
  872.  
  873. # ncgi::cookie
  874. #
  875. #    Return a *list* of cookie values, if present, else ""
  876. #    It is possible for multiple cookies with the same key
  877. #    to be present, so we return a list.
  878. #
  879. # Arguments:
  880. #    cookie    The name of the cookie (the key)
  881. #
  882. # Results:
  883. #    A list of values for the cookie
  884.  
  885. proc ncgi::cookie {cookie} {
  886.     global env
  887.     set result ""
  888.     if {[info exist env(HTTP_COOKIE)]} {
  889.     foreach pair [split $env(HTTP_COOKIE) \;] {
  890.         foreach {key value} [split [string trim $pair] =] { break ;# lassign }
  891.         if {[string compare $cookie $key] == 0} {
  892.         lappend result $value
  893.         }
  894.     }
  895.     }
  896.     return $result
  897. }
  898.  
  899. # ncgi::setCookie
  900. #
  901. #    Set a return cookie.  You must call this before you call
  902. #    ncgi::header or ncgi::redirect
  903. #
  904. # Arguments:
  905. #    args    Name value pairs, where the names are:
  906. #        -name    Cookie name
  907. #        -value    Cookie value
  908. #        -path    Path restriction
  909. #        -domain    domain restriction
  910. #        -expires    Time restriction
  911. #
  912. # Side Effects:
  913. #    Formats and stores the Set-Cookie header for the reply.
  914.  
  915. proc ncgi::setCookie {args} {
  916.     variable cookieOutput
  917.     array set opt $args
  918.     set line "$opt(-name)=$opt(-value) ;"
  919.     foreach extra {path domain} {
  920.     if {[info exist opt(-$extra)]} {
  921.         append line " $extra=$opt(-$extra) ;"
  922.     }
  923.     }
  924.     if {[info exist opt(-expires)]} {
  925.     switch -glob -- $opt(-expires) {
  926.         *GMT {
  927.         set expires $opt(-expires)
  928.         }
  929.         default {
  930.         set expires [clock format [clock scan $opt(-expires)] \
  931.             -format "%A, %d-%b-%Y %H:%M:%S GMT" -gmt 1]
  932.         }
  933.     }
  934.     append line " expires=$expires ;"
  935.     }
  936.     if {[info exist opt(-secure)]} {
  937.     append line " secure "
  938.     }
  939.     lappend cookieOutput $line
  940. }
  941.