#@package: www_cgi_interface cgi_import_form neo_cgi_import_form

#
# Copyright (C) 1992-1997 NeoSoft.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  NeoSoft makes no 
# representations about the suitability of this software for any purpose.
# It is provided "as is" without express or implied warranty.

# $Id: http-helpers.tcl,v 1.1.1.1 1999/03/31 20:34:38 damon Exp $

# Hoarked around from web-found tcl-proc-args.tar.Z

#arguments are passed on command line. '&' separates assignments
#assignments have the form name=value
#'+'s are spaces and spaces separating words on command line are
#actually part of the word
#In our environment, if argument starts with /, then pathname
#components are assignments

# global variable artype(i) defines what type ar(i) should be.  Currently,
# list or not.

proc cgi_subhex {v} {
    set nv $v
    while {[regexp {%[0-9A-Fa-f][0-9A-Fa-f]} $v blah]} {
	scan $blah "%%%x" cv
	if {[ctype char $cv]=="&"} {
	    regsub -all $blah $v \\& nv
	} else {
	    regsub -all $blah $v [ctype char $cv] nv
	}
	set v $nv
    }
    return $v
}

#makes URL extended pathname to encode current state
proc cgi_pkg_attrs {var attrs} {
    upvar $var ar
    set al ""
    foreach i $attrs {
        if [info exists ar($i)] {
            regsub { } $ar($i) {+} att
            set al "$al/$i=$att"
        }
    }
    return $al
}

proc cgi_import_form {argArrayName argTypeArrayName responseArrayName} {
    upvar $argArrayName ar
    upvar $argTypeArrayName artype
    upvar $responseArrayName response
    global env
    set bigarg ""
    #join words with +'s
    if [info exists env(PATH_INFO)] {
	set args [split [crange $env(PATH_INFO) 1 end] /]
    } else {
	set args {}
    }
    if [info exists env(QUERY_STRING)] {
	set bigarg [split $env(QUERY_STRING) &]
    } else {
	set bigarg {}
    }

    foreach arg [concat $bigarg $args] {
	if [regexp {(.*)=(.*)} $arg foo name value] {
	    set name [cgi_subhex $name]
	    if ![info exists argcount($name)] {
		set argcount($name) 1
	    } else {
		incr argcount($name)
	    }
	}
    }
	    
    #split assignments on the '&' 
    foreach arg [concat $bigarg $args] {
	if [regexp {(.*)=(.*)} $arg foo name value] {
	    regsub -all {\+} $value { } newval
	    set name [cgi_subhex $name]
	    set val [cgi_subhex $newval]
	    if ![info exists ar($name)] {
		if [info exists artype($name)] {
		    if {$artype($name)=="list"} {
			if {$val!=""} {
			    set ar($name) [list $val]
			} else {
			    set ar($name) {}
			}
		    } else {
			set ar($name) $val
		    }
		} else {
		    set ar($name) $val
		}
	    } else {
		# multiple selection
		lappend ar($name) $val
	    }
	}
    }

    if [info exists env(CONTENT_LENGTH)] {
        set message [split [read stdin $env(CONTENT_LENGTH)] &]
        foreach pair $message {
	    lassign [split $pair =] name val
	    regsub -all {\+} [cgi_subhex $val] { } val
	    set response($name) $val
        }
    }
}

proc neo_cgi_import_form {argArrayName argTypeArrayName responseArrayName {fieldOrderVarName ""}} {
    upvar $argArrayName ar
    upvar $argTypeArrayName artype
    upvar $responseArrayName response
    if {$fieldOrderVarName != ""} {upvar $fieldOrderVarName fieldOrder}
    set fieldOrder ""
    global env
    set bigarg ""
    #join words with +'s
    if [info exists env(PATH_INFO)] {
	set args [split [crange $env(PATH_INFO) 1 end] /]
    } else {
	set args {}
    }
    if [info exists env(QUERY_STRING)] {
	set bigarg [split $env(QUERY_STRING) &]
    } else {
	set bigarg {}
    }

    foreach arg [concat $bigarg $args] {
	if [regexp {(.*)=(.*)} $arg foo name value] {
	    set name [www_unescape_string $name]
	    if ![info exists argcount($name)] {
		set argcount($name) 1
	    } else {
		incr argcount($name)
	    }
	}
    }
	    
    #split assignments on the '&' 
    foreach arg [concat $bigarg $args] {
	if [regexp {(.*)=(.*)} $arg foo name value] {
	    regsub -all {\+} $value { } newval
	    set name [www_unescape_string $name]
	    lappend fieldOrder $name
	    set val [www_unescape_string $newval]
	    if ![info exists ar($name)] {
		if [info exists artype($name)] {
		    if {$artype($name)=="list"} {
			if {$val!=""} {
			    set ar($name) [list $val]
			} else {
			    set ar($name) {}
			}
		    } else {
			set ar($name) $val
		    }
		} else {
		    set ar($name) $val
		}
	    } else {
		# multiple selection
		lappend ar($name) $val
	    }
	}
    }

    if [info exists env(CONTENT_LENGTH)] {
        set message [split [read stdin $env(CONTENT_LENGTH)] &]
        foreach pair $message {
	    lassign [split $pair =] name val
	    set response($name) [www_unescape_string $val]
	    lappend fieldOrder $name
        }
    }
}

