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