Index: xmlrpc.tcl
===================================================================
RCS file: /proj/rd/cvsroot/saods9/xmlrpc-0.3/xmlrpc.tcl,v
retrieving revision 1.1
retrieving revision 1.8
diff -r1.1 -r1.8
68,69c68,69
< 	namespace	export call buildRequest marshall unmarshall assoc
< 	namespace	export serve
---
>     namespace	export call buildRequest marshall unmarshall assoc
>     namespace	export serve
71c71
< 	variable	READSIZE 4096;		# read size
---
>     variable	READSIZE 4096;		# read size
73,79c73,79
< 	variable	WS	"\[ |\n|\t\|\r]";	# WhiteSpace
< 	variable	W	"\[^ |\n|\t\]";		# a word with no spaces
< 	variable	DIGIT	"\[0-9\]";		# Digit
< 
< 	variable	response	"";		# response to return
< 	variable	acceptfd	"";		# socket to listen on
< 	variable	DEBUG		1;		# debug
---
>     variable	WS	"\[ |\n|\t\|\r]";	# WhiteSpace
>     variable	W	"\[^ |\n|\t\]";		# a word with no spaces
>     variable	DIGIT	"\[0-9\]";		# Digit
> 
>     variable	response	"";		# response to return
>     variable	acceptfd	"";		# socket to listen on
>     variable	DEBUG		0;		# debug
86c86
< 	variable	acceptfd
---
>     variable	acceptfd
88c88,89
< 	set acceptfd [socket -server xmlrpc::serveOnce $port]
---
>     set acceptfd [socket -server xmlrpc::serveOnce $port]
>     return $acceptfd
94c95
< 	variable	READSIZE
---
>     variable	READSIZE
96,100c97,101
< 	debug "in serveOnce: addr: $addr"
< 	debug "in serveOnce: port: $port"
< 	fconfigure $sock -translation {lf lf} -buffersize $READSIZE
< 	fconfigure $sock -blocking off
< 	fileevent $sock readable [list xmlrpc::doRequest $sock]
---
>     debug "in serveOnce: addr: $addr"
>     debug "in serveOnce: port: $port"
>     fconfigure $sock -translation {lf lf} -buffersize $READSIZE
>     fconfigure $sock -blocking off
>     fileevent $sock readable [list xmlrpc::doRequest $sock]
107c108
< 	variable	WS
---
>     variable	WS
109,127c110,139
< 	set res [readHeader $sock]
< 	set headerStatus [lindex $res 0];	# Header + Status
< 	set body [lindex $res 1];		# Body, if any
< 
< 	set RE "\[^\n\]+\n(.*)"
< 	if {![regexp $RE $headerStatus {} header]} {
< 		return [errReturn "Malformed Request"]
< 	}
< 
< 	set body [getBody $sock $header $body]
< 
< 	set	RE "<\?xml.version=.";			# xml version
< 	append	RE "\[^\?\]+.\?>$WS*";			# version number
< 	append	RE "<methodCall>$WS*";			# methodCall tag
< 	append	RE "<methodName>";			# methodName tag
< 	append	RE "(\[a-zA-Z0-9_:\/\\.\]+)";		# method Name
< 	append	RE "</methodName>$WS*";			# end methodName tag
< 	append	RE "(.*)";				# parameters, if any
< 	append	RE "</methodCall>.*";			# end methodCall tag
---
>     set res [readHeader $sock]
>     set headerStatus [lindex $res 0];	# Header + Status
>     set body [lindex $res 1];		# Body, if any
> 
>     set RE "\[^\n\]+\n(.*)"
>     if {![regexp $RE $headerStatus {} header]} {
> 	return [errReturn "Malformed Request"]
>     }
> 
>     set body [getBody $sock $header $body]
> 
>     set	RE "<\?xml.version=.";			# xml version
>     append	RE "\[^\?\]+.\?>$WS*";			# version number
>     append	RE "<methodCall>$WS*";			# methodCall tag
>     append	RE "<methodName>";			# methodName tag
>     append	RE "(\[a-zA-Z0-9_:\/\\.\]+)";		# method Name
>     append	RE "</methodName>$WS*";			# end methodName tag
>     append	RE "(.*)";				# parameters, if any
>     append	RE "</methodCall>.*";			# end methodCall tag
> 
>     if {![regexp $RE $body {} mname params]} {
> 	return [errReturn "Malformed methodCall"]
>     }
> 
>     set args {}
>     set param [string range $params 8 end]
>     set param [string trim $param]
>     while {[string range $param 0 6] == "<param>"} {
> 	set param [string range $param 7 end]
> 	set param [string trim $param]
129,130c141,146
< 	if {![regexp $RE $body {} mname params]} {
< 		return [errReturn "Malformed methodCall"]
---
> 	set res [unmarshall $param]
> 	set param [lindex $res 0]
> 	set el [lindex $res 1]
> 	lappend args $el
> 	if {[string range $param 0 7] != "</param>"} {
> 	    return [errReturn "Invalid End Param"]
132,134c148
< 
< 	set args {}
< 	set param [string range $params 8 end]
---
> 	set param [string range $param 8 end]
136,161c150,162
< 	while {[string range $param 0 6] == "<param>"} {
< 		set param [string range $param 7 end]
< 		set param [string trim $param]
< 
< 		set res [unmarshall $param]
< 		set param [lindex $res 0]
< 		set el [lindex $res 1]
< 		lappend args $el
< 		if {[string range $param 0 7] != "</param>"} {
< 			return [errReturn "Invalid End Param"]
< 		}
< 		set param [string range $param 8 end]
< 		set param [string trim $param]
< 	}
< 	if {$param != "</params>"} {
< 		return [errReturn "Invalid End Params"]
< 	}
< 	if {[catch {set result [eval ::$mname $args]}]} {
< 		set response [buildFault 100 "eval() failed"]
< 	} else {
< 		set response [buildResponse $result]
< 	}
< 	debug "in doRequest: response:\n$response"
< 	puts -nonewline $sock $response
< 	flush $sock
< 	catch {close $sock}
---
>     }
>     if {$param != "</params>"} {
> 	return [errReturn "Invalid End Params"]
>     }
>     if {[catch {set result [eval ::$mname $args]}]} {
> 	set response [buildFault 100 "eval() failed"]
>     } else {
> 	set response [buildResponse $result]
>     }
>     debug "in doRequest: response:\n$response"
>     puts -nonewline $sock $response
>     flush $sock
>     catch {close $sock}
168,187c169,188
< 	# build the body
< 	set	body "<?xml version=\"1.0\"?>\n"
< 	append	body "<methodResponse>\n"
< 	append	body "\t<params>\n"
< 	append	body "\t\t<param>\n"
< 	append	body [xmlrpc::marshall $result 3 2]
< 	append	body "\n\t\t</param>\n"
< 	append	body "\t</params>\n"
< 	append	body "</methodResponse>\n"
< 
< 	set lenbod [string length $body]
< 
< 	# build the header
< 	set	header "HTTP/1.1 200 OK\n"
< 	append	header "Content-Type: text/xml\n"
< 	append	header "Content-length: $lenbod\n"
< 
< 	set response "$header\n$body"
< 	return $response
< 	#return [string trim $response]
---
>     # build the body
>     set	body "<?xml version=\"1.0\"?>\n"
>     append	body "<methodResponse>\n"
>     append	body "\t<params>\n"
>     append	body "\t\t<param>\n"
>     append	body [xmlrpc::marshall $result 3 2]
>     append	body "\n\t\t</param>\n"
>     append	body "\t</params>\n"
>     append	body "</methodResponse>\n"
> 
>     set lenbod [string length $body]
> 
>     # build the header
>     set	header "HTTP/1.1 200 OK\n"
>     append	header "Content-Type: text/xml\n"
>     append	header "Content-length: $lenbod\n"
> 
>     set response "$header\n$body"
>     return $response
>     #return [string trim $response]
195,196c196,197
< 	set err(faultCode) [list int $errcode]
< 	set err(faultString) [list string $errmsg]
---
>     set err(faultCode) [list int $errcode]
>     set err(faultString) [list string $errmsg]
198,211c199,212
< 	# build the body
< 	set	body "<?xml version=\"1.0\"?>\n"
< 	append	body "<methodResponse>\n"
< 	append	body "\t<fault>\n"
< 	append	body [xmlrpc::marshall {struct err} 2]
< 	append	body "\t</fault>\n"
< 	append	body "</methodResponse>\n"
< 
< 	set lenbod [string length $body]
< 
< 	# build the header
< 	set	header "HTTP/1.1 200 OK\n"
< 	append	header "Content-Type: text/xml\n"
< 	append	header "Content-length: $lenbod\n"
---
>     # build the body
>     set	body "<?xml version=\"1.0\"?>\n"
>     append	body "<methodResponse>\n"
>     append	body "\t<fault>\n"
>     append	body [xmlrpc::marshall {struct err} 2]
>     append	body "\t</fault>\n"
>     append	body "</methodResponse>\n"
> 
>     set lenbod [string length $body]
> 
>     # build the header
>     set	header "HTTP/1.1 200 OK\n"
>     append	header "Content-Type: text/xml\n"
>     append	header "Content-length: $lenbod\n"
213,214c214,215
< 	set response "$header\n$body"
< 	return [string trim $response]
---
>     set response "$header\n$body"
>     return [string trim $response]
219,247c220,248
< proc xmlrpc::call {url methodName params {ntabs 4} {distance 3}} {
< 	variable	READSIZE
< 	variable	response
< 	global		readdone
< 	global		xmlcall
< 
< 	set readdone 0
< 	set xmlcall 1
< 	set RE {http://([^:]+):([0-9]+)}
< 	if {![regexp $RE $url {} host port]} {
< 		return [errReturn "Malformed URL"]
< 	}
< 
< 	set sock [socket $host $port]
< 	fconfigure $sock -translation {lf lf} -buffersize $READSIZE
< 	fconfigure $sock -blocking off
< 	if {[catch {set request [buildRequest $methodName $params $ntabs $distance]}]} {
< 		return
< 	}
< 	puts -nonewline $sock $request
< 	flush $sock
< 	fileevent $sock readable [list xmlrpc::getResponse $sock]
< 	vwait readdone
< 	catch {close $sock}
< 	if {$readdone > 0} {
< 		return $response
< 	} else {
< 		return [errReturn "xmlrpc::call failed"]
< 	}
---
> proc xmlrpc::call {url method methodName params {ntabs 4} {distance 3}} {
>     variable	READSIZE
>     variable	response
>     global		readdone
>     global		xmlcall
> 
>     set readdone 0
>     set xmlcall 1
>     set RE {http://([^:]+):([0-9]+)}
>     if {![regexp $RE $url {} host port]} {
> 	return [errReturn "Malformed URL"]
>     }
> 
>     set sock [socket $host $port]
>     fconfigure $sock -translation {lf lf} -buffersize $READSIZE
>     fconfigure $sock -blocking off
>     if {[catch {set request [buildRequest $method $methodName $params $ntabs $distance]}]} {
> 	return
>     }
>     puts -nonewline $sock $request
>     flush $sock
>     fileevent $sock readable [list xmlrpc::getResponse $sock]
>     vwait readdone
>     catch {close $sock}
>     if {$readdone > 0} {
> 	return $response
>     } else {
> 	return [errReturn "xmlrpc::call failed"]
>     }
254,255c255,256
< 	variable	response
< 	global		readdone
---
>     variable	response
>     global		readdone
257,264c258,265
< 	set res [readHeader $sock]
< 	set headerStatus [lindex $res 0];	# Header + Status
< 	set body [lindex $res 1];		# Body, if any
< 
< 	set header [parseHTTPCode $headerStatus]
< 	set body [getBody $sock $header $body]
< 	set response [parseResponse $body]
< 	set readdone 1
---
>     set res [readHeader $sock]
>     set headerStatus [lindex $res 0];	# Header + Status
>     set body [lindex $res 1];		# Body, if any
> 
>     set header [parseHTTPCode $headerStatus]
>     set body [getBody $sock $header $body]
>     set response [parseResponse $body]
>     set readdone 1
273,274c274,275
< 	set res [parseHTTPHeaders $header]
< 	set headersl [lindex $res 1];		# A-list of headers
---
>     set res [parseHTTPHeaders $header]
>     set headersl [lindex $res 1];		# A-list of headers
276,285c277,283
< 	set expLenl [assoc "Content-Length" $headersl]
< 	if {$expLenl == {}} {
< 		set expLenl [assoc "Content-length" $headersl]
< 		if {$expLenl == {}} {
< 			return [errReturn "No Content-length found"]
< 		}
< 	}
< 	set expLen [lindex $expLenl 1]
< 	set body [readBody $body $expLen $sock]
< 	return $body
---
>     set expLenl [assoc "Content-Length" $headersl]
>     if {$expLenl == {}} {
> 	return [errReturn "No Content-Length found"]
>     }
>     set expLen [lindex $expLenl 1]
>     set body [readBody $body $expLen $sock]
>     return $body
294,307c292,295
< 	set buffer ""
< 	while {1} {
< 		if {[catch {set buff [nbRead $sock]}]} {
< 			return [errReturn "Premature eof"]
< 		}
< 		append buffer $buff
< 		set nindex [string first "\n\n" $buffer]
< 		if {$nindex > 0} {
< 			break
< 		}
< 		set bindex [string first "\r\n\r\n" $buffer]
< 		if {$bindex > 0} {
< 			break
< 		}
---
>     set buffer ""
>     while {1} {
> 	if {[catch {set buff [nbRead $sock]}]} {
> 	    return [errReturn "Premature eof"]
308a297,298
> 	append buffer $buff
> 	set nindex [string first "\n\n" $buffer]
310,314c300
< 		set header [string range $buffer 0 [expr $nindex - 1]]
< 		set body [string range $buffer [expr $nindex + 2] end]
< 	} elseif {$bindex > 0} {
< 		set header [string range $buffer 0 [expr $bindex - 1]]
< 		set body [string range $buffer [expr $bindex + 4] end]
---
> 	    break
316c302,314
< 	return [list $header $body]
---
> 	set bindex [string first "\r\n\r\n" $buffer]
> 	if {$bindex > 0} {
> 	    break
> 	}
>     }
>     if {$nindex > 0} {
> 	set header [string range $buffer 0 [expr $nindex - 1]]
> 	set body [string range $buffer [expr $nindex + 2] end]
>     } elseif {$bindex > 0} {
> 	set header [string range $buffer 0 [expr $bindex - 1]]
> 	set body [string range $buffer [expr $bindex + 4] end]
>     }
>     return [list $header $body]
325,336c323,333
< 	set newbody $body
< 	while {1} {
< 		if {[catch {set buff [nbRead $sock]}]} {
< 			return [errReturn "Premature eof"]
< 		}
< 		append newbody $buff
< 		set bodLen [string length $newbody]
< 		if {$bodLen == $expLen} {
< 			break
< 		} elseif {$bodLen > $expLen} {
< 			return [errReturn "Content-length:$expLen does not match Body Length:$bodLen"]
< 		}
---
>     set newbody $body
>     while {1} {
> 	if {[catch {set buff [nbRead $sock]}]} {
> 	    return [errReturn "Premature eof"]
> 	}
> 	append newbody $buff
> 	set bodLen [string length $newbody]
> 	if {$bodLen == $expLen} {
> 	    break
> 	} elseif {$bodLen > $expLen} {
> 	    return [errReturn "Content-length:$expLen does not match Body Length:$bodLen"]
338c335,336
< 	return $newbody
---
>     }
>     return $newbody
346c344
< 	variable	DIGIT
---
>     variable	DIGIT
348,359c346,357
< 	set	RE "HTTP/";				# HTTP message
< 	append	RE "($DIGIT+\\.*$DIGIT*).";		# version
< 	append	RE "($DIGIT+).";			# status code
< 	append	RE "(\[^\n\]+)\n(.*)";			# status message
< 
< 	if {![regexp $RE $str {} vern status code rest]} {
< 		return [errReturn "Unrecognized HTTP code:\n$str"]
< 	}
< 	if {$status != "200"} {
< 		return [errReturn "Bad HTTP status: $status"]
< 	}
< 	return $rest
---
>     set	RE "HTTP/";				# HTTP message
>     append	RE "($DIGIT+\\.*$DIGIT*).";		# version
>     append	RE "($DIGIT+).";			# status code
>     append	RE "(\[^\n\]+)\n(.*)";			# status message
> 
>     if {![regexp $RE $str {} vern status code rest]} {
> 	return [errReturn "Unrecognized HTTP code:\n$str"]
>     }
>     if {$status != "200"} {
> 	return [errReturn "Bad HTTP status: $status"]
>     }
>     return $rest
369,392c367,390
< 	set headers {}
< 	set remain {}
< 	set remainp 0
< 	set RE {([^:]+):(.*)}
< 
< 	set parts [split $str "\n"]
< 	foreach {part} $parts {
< 		if {$part == ""
< 		&& !$remainp} {
< 			set remainp 1
< 			continue
< 		}
< 		if {$remainp} {
< 			lappend remain $part
< 			continue
< 		}
< 		if {![regexp $RE $part {} key value]} {
< 			return [errReturn "Unrecognized HTTP Header format: $part"]
< 		}
< 		set value [string trim $value]
< 		lappend headers [list $key $value]
< 	}
< 	set rest [join $remain "\n"]
< 	return [list $rest $headers]
---
>     set headers {}
>     set remain {}
>     set remainp 0
>     set RE {([^:]+):(.*)}
> 
>     set parts [split $str "\n"]
>     foreach {part} $parts {
> 	if {$part == ""
> 	    && !$remainp} {
> 	    set remainp 1
> 	    continue
> 	}
> 	if {$remainp} {
> 	    lappend remain $part
> 	    continue
> 	}
> 	if {![regexp $RE $part {} key value]} {
> 	    return [errReturn "Unrecognized HTTP Header format: $part"]
> 	}
> 	set value [string trim $value]
> 	lappend headers [list $key $value]
>     }
>     set rest [join $remain "\n"]
>     return [list $rest $headers]
400c398
< 	variable	WS
---
>     variable	WS
401a400,410
>     set	RE "<\?xml.version=.";		# xml version
>     append	RE "(\[^\?\]+).\?>$WS*";	# version number
>     append	RE "<methodResponse>$WS*";	# method response tag
>     append	RE "<params>$WS*";		# params tag
>     append	RE "<param>$WS*";		# param tag
>     append	RE "(<value>.*)";		# value
>     append	RE "</param>$WS*";		# end param tag
>     append	RE "</params>$WS*";		# end params tag
>     append	RE "</methodResponse>";		# end method response tag
> 
>     if {![regexp $RE $str {} vern value]} {
405,409c414,416
< 	append	RE "<params>$WS*";		# params tag
< 	append	RE "<param>$WS*";		# param tag
< 	append	RE "(<value>.*)";		# value
< 	append	RE "</param>$WS*";		# end param tag
< 	append	RE "</params>$WS*";		# end params tag
---
> 	append	RE "<fault>$WS*";		# fault tag
> 	append	RE "(.*)$WS*";			# fault values
> 	append	RE "</fault>$WS*";		# end fault tag
413,423c420
< 		set	RE "<\?xml.version=.";		# xml version
< 		append	RE "(\[^\?\]+).\?>$WS*";	# version number
< 		append	RE "<methodResponse>$WS*";	# method response tag
< 		append	RE "<fault>$WS*";		# fault tag
< 		append	RE "(.*)$WS*";			# fault values
< 		append	RE "</fault>$WS*";		# end fault tag
< 		append	RE "</methodResponse>";		# end method response tag
< 
< 		if {![regexp $RE $str {} vern value]} {
< 			return [errReturn "Unrecognized response from server"]
< 		}
---
> 	    return [errReturn "Unrecognized response from server"]
425,426c422,424
< 	set result [unmarshall $value]
< 	return $result
---
>     }
>     set result [unmarshall $value]
>     return $result
433c431
< 	variable	READSIZE
---
>     variable	READSIZE
435,448c433,446
< 	fileevent $fd readable ""
< 	set buffer ""
< 	while {1} {
< 		if {[eof $fd]} {
< 			catch {close $fd}
< 			break
< 		}
< 		set temp [read $fd $READSIZE]
< 		if {$temp == ""} {
< 			break
< 		}
< 		append buffer $temp
< 	}
< 	return $buffer
---
>     fileevent $fd readable ""
>     set buffer ""
>     while {1} {
> 	if {[eof $fd]} {
> 	    catch {close $fd}
> 	    break
> 	}
> 	set temp [read $fd $READSIZE]
> 	if {$temp == ""} {
> 	    break
> 	}
> 	append buffer $temp
>     }
>     return $buffer
455,475c453,475
< proc xmlrpc::buildRequest {methodName params {ntabs 4} {distance 2}} {
< 	# build the body
< 	set	body "<?xml version=\"1.0\"?>\n"
< 	append	body "<methodCall>\n"
< 	append	body "\t<methodName>$methodName</methodName>\n"
< 	if {$params != {}} {
< 		append body "\t\t<params>\n"
< 		foreach {param} $params {
< 			append body "\t\t\t<param>\n"
< 			append body [xmlrpc::marshall $param $ntabs $distance]
< 			append body "\n\t\t\t</param>\n"
< 		}
< 		append body "\t\t</params>\n"
< 	}
< 	append	body "</methodCall>\n"
< 	set lenbod [string length $body]
< 
< 	# build the header
< 	set	header "POST /RPC2 HTTP/1.0\n"
< 	append	header "Content-Type: text/xml\n"
< 	append	header "Content-length: $lenbod\n"
---
> proc xmlrpc::buildRequest {method methodName params {ntabs 4} {distance 2}} {
>     # build the body
>     set	body "<?xml version=\"1.0\"?>\n"
>     append	body "<methodCall>\n"
>     append	body "\t<methodName>$methodName</methodName>\n"
>     if {$params != {}} {
> 	append body "\t\t<params>\n"
> 	foreach {param} $params {
> 	    append body "\t\t\t<param>\n"
> 	    append body [xmlrpc::marshall $param $ntabs $distance]
> 	    append body "\n\t\t\t</param>\n"
> 	}
> 	append body "\t\t</params>\n"
>     }
>     append	body "</methodCall>\n"
>     set body [regsub -all "\n" $body "\r\n"]
>     set lenbod [string length $body]
> 
>     # build the header
>     set	header "POST /$method HTTP/1.0\n"
>     append	header "Content-Type: text/xml\n"
>     append	header "Content-length: $lenbod\n"
>     set header [regsub -all "\n" $header "\r\n"]
477,478c477,478
< 	set request "$header\n$body"
< 	return $request
---
>     set request "$header\r\n$body"
>     return $request
485,544c485,544
< 	if {![validParam $param]} {
< 		return [errReturn "Malformed Parameter: $param"]
< 	}
< 
< 	set strtabs ""
< 	for {set x 0} {$x < $ntabs} {incr x} {
< 		append strtabs "\t"
< 	}
< 
< 	set type [lindex $param 0]
< 	set val [lindex $param 1]
< 
< 	if {$type == "int"} {
< 		return "$strtabs<value><int>$val</int></value>"
< 	} elseif {$type == "i4"} {
< 		return "$strtabs<value><i4>$val</i4></value>"
< 	} elseif {$type == "boolean"} {
< 		return "$strtabs<value><boolean>$val</boolean></value>"
< 	} elseif {$type == "string"} {
< 		return "$strtabs<value><string>$val</string></value>"
< 	} elseif {$type == "double"} {
< 		return "$strtabs<value><double>$val</double></value>"
< 	} elseif {$type == "dateTime.iso8601"} {
< 		return "$strtabs<value><dateTime.iso8601>$val</dateTime.iso8601></value>"
< 	} elseif {$type == "base64"} {
< 		return "$strtabs<value><base64>$val</base64></value>"
< 	} elseif {$type == "struct"} {
< 		# get the original caller's scope
< 		upvar $distance $val dict
< 		# try the global scope
< 		if {![array exists dict]} {
< 			upvar #0 $val dict
< 		}
< 
< 		set	str "$strtabs<value>\n"
< 		append	str "$strtabs\t<struct>\n"
< 		foreach {k v} [array get dict] {
< 			append 	str "$strtabs\t\t<member>\n"
< 			append	str "$strtabs\t\t\t<name>$k</name>\n"
< 			append 	str [marshall $v [expr $ntabs + 3] [expr $distance + 1]]
< 			append	str "\n$strtabs\t\t</member>\n"
< 		}
< 		append	str "$strtabs\t</struct>\n"
< 		append	str "$strtabs</value>\n"
< 		return $str
< 	} elseif {$type == "array"} {
< 		set	str "$strtabs<value>\n"
< 		append	str "$strtabs\t<array>\n"
< 		append	str "$strtabs\t\t<data>\n"
< 		foreach el $val {
< 			append	str [marshall $el [expr $ntabs + 3] [expr $distance + 1]]
< 			append	str "\n"
< 		}
< 		append	str "$strtabs\t\t</data>\n"
< 		append	str "$strtabs\t</array>\n"
< 		append	str "$strtabs</value>\n"
< 		return $str
< 	} else {
< 		return [errReturn "Unknown type: $type"]
< 	}
---
>     if {![validParam $param]} {
> 	return [errReturn "Malformed Parameter: $param"]
>     }
> 
>     set strtabs ""
>     for {set x 0} {$x < $ntabs} {incr x} {
> 	append strtabs "\t"
>     }
> 
>     set type [lindex $param 0]
>     set val [lindex $param 1]
> 
>     if {$type == "int"} {
> 	return "$strtabs<value><int>$val</int></value>"
>     } elseif {$type == "i4"} {
> 	return "$strtabs<value><i4>$val</i4></value>"
>     } elseif {$type == "boolean"} {
> 	return "$strtabs<value><boolean>$val</boolean></value>"
>     } elseif {$type == "string"} {
> 	return "$strtabs<value><string>$val</string></value>"
>     } elseif {$type == "double"} {
> 	return "$strtabs<value><double>$val</double></value>"
>     } elseif {$type == "dateTime.iso8601"} {
> 	return "$strtabs<value><dateTime.iso8601>$val</dateTime.iso8601></value>"
>     } elseif {$type == "base64"} {
> 	return "$strtabs<value><base64>$val</base64></value>"
>     } elseif {$type == "struct"} {
> 	# get the original caller's scope
> 	upvar $distance $val dict
> 	# try the global scope
> 	if {![array exists dict]} {
> 	    upvar #0 $val dict
> 	}
> 
> 	set	str "$strtabs<value>\n"
> 	append	str "$strtabs\t<struct>\n"
> 	foreach {k v} [array get dict] {
> 	    append 	str "$strtabs\t\t<member>\n"
> 	    append	str "$strtabs\t\t\t<name>$k</name>\n"
> 	    append 	str [marshall $v [expr $ntabs + 3] [expr $distance + 1]]
> 	    append	str "\n$strtabs\t\t</member>\n"
> 	}
> 	append	str "$strtabs\t</struct>\n"
> 	append	str "$strtabs</value>\n"
> 	return $str
>     } elseif {$type == "array"} {
> 	set	str "$strtabs<value>\n"
> 	append	str "$strtabs\t<array>\n"
> 	append	str "$strtabs\t\t<data>\n"
> 	foreach el $val {
> 	    append	str [marshall $el [expr $ntabs + 3] [expr $distance + 1]]
> 	    append	str "\n"
> 	}
> 	append	str "$strtabs\t\t</data>\n"
> 	append	str "$strtabs\t</array>\n"
> 	append	str "$strtabs</value>\n"
> 	return $str
>     } else {
> 	return [errReturn "Unknown type: $type"]
>     }
553,556c553,556
< 	if {[llength $param] != 2} {
< 		return 0
< 	}
< 	return 1
---
>     if {[llength $param] != 2} {
> 	return 0
>     }
>     return 1
563,574c563,574
< 	set str [string trim $str]
< 	if {[string range $str 0 6] != "<value>"} {
< 		return [errReturn "Bad value tag"]
< 	}
< 
< 	set str [string range $str 7 end]
< 	set str [string trimleft $str]
< 	set RE {<([^>]+)>}
< 	if {![regexp $RE $str {} btag]} {
< 		return [errReturn "No beginning tag found: $str"]
< 	}
< 	if {$btag == "int"
---
>     set str [string trim $str]
>     if {[string range $str 0 6] != "<value>"} {
> 	return [errReturn "Bad value tag"]
>     }
> 
>     set str [string range $str 7 end]
>     set str [string trimleft $str]
>     set RE {<([^>]+)>}
>     if {![regexp $RE $str {} btag]} {
> 	return [errReturn "No beginning tag found: $str"]
>     }
>     if {$btag == "int"
576,590c576,600
< 		set res [umInt $str]
< 	} elseif {$btag== "boolean"} {
< 		set res [umBool $str]
< 	} elseif {$btag == "string"} {
< 		set res [umString $str]
< 	} elseif {$btag == "double"} {
< 		set res [umDouble $str]
< 	} elseif {$btag == "dateTime.iso8601"} {
< 		set res [umDateTime $str]
< 	} elseif {$btag == "base64"} {
< 		set res [umBase64 $str]
< 	} elseif {$btag == "array"} {
< 		set res [umArray $str]
< 	} elseif {$btag == "struct"} {
< 		set res [umStruct $str]
---
> 	set res [umInt $str]
>     } elseif {$btag== "boolean"} {
> 	set res [umBool $str]
>     } elseif {$btag == "string"} {
> 	set res [umString $str]
>     } elseif {$btag == "double"} {
> 	set res [umDouble $str]
>     } elseif {$btag == "dateTime.iso8601"} {
> 	set res [umDateTime $str]
>     } elseif {$btag == "base64"} {
> 	set res [umBase64 $str]
>     } elseif {$btag == "array"} {
> 	set res [umArray $str]
>     } elseif {$btag == "struct"} {
> 	set res [umStruct $str]
>     } else {
> 	#		return [errReturn "Unknown type: $str"]
> 
> 	# assume string
> 	set id [string first "<" $str ]
> 	if {$id != -1} {
> 	    set vv [string range $str 0 [expr $id-1]]
> 	    set rr [string range $str $id end]
> 	    set str "<string>${vv}</string>${rr}"
> 	    set res [umString $str]
592c602
< 		return [errReturn "Unknown type: $str"]
---
> 	    return [errReturn "Unknown type: $str"]
593a604
>     }
595,596c606,607
< 	set rest [lindex $res 0]
< 	set val [lindex $res 1]
---
>     set rest [lindex $res 0]
>     set val [lindex $res 1]
598,603c609,614
< 	if {[string range $rest 0 7] != "</value>"} {
< 		return [errReturn "Invalid close of value tag"]
< 	}
< 	set rest [string range $rest 8 end]
< 	set rest [string trim $rest]
< 	return [list $rest $val]
---
>     if {[string range $rest 0 7] != "</value>"} {
> 	return [errReturn "Invalid close of value tag"]
>     }
>     set rest [string range $rest 8 end]
>     set rest [string trim $rest]
>     return [list $rest $val]
607,608c618,619
< 	variable	WS
< 	variable	DIGIT
---
>     variable	WS
>     variable	DIGIT
610,624c621,635
< 	set	RE "<(int|i4)>$WS*";	# int tag
< 	append	RE "(-*)($DIGIT+)$WS*";	# int value
< 	append	RE "</(int|i4)>$WS*";	# end int tag
< 	append	RE "(.*)";		# leftover
< 
< 	if {![regexp $RE $str {} tag negp digits engtag rest]} {
< 		return [errReturn "Invalid Integer"]
< 	}
< 	if {$negp != ""} {
< 		set digits [expr -1 * $digits]
< 	} else {
< 		set digits [expr 1 * $digits]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $digits]
---
>     set	RE "<(int|i4)>$WS*";	# int tag
>     append	RE "(-*)($DIGIT+)$WS*";	# int value
>     append	RE "</(int|i4)>$WS*";	# end int tag
>     append	RE "(.*)";		# leftover
> 
>     if {![regexp $RE $str {} tag negp digits engtag rest]} {
> 	return [errReturn "Invalid Integer"]
>     }
>     if {$negp != ""} {
> 	set digits [expr -1 * $digits]
>     } else {
> 	set digits [expr 1 * $digits]
>     }
>     set rest [string trim $rest]
>     return [list $rest $digits]
628c639
< 	variable	WS
---
>     variable	WS
630,639c641,650
< 	set	RE "<boolean>$WS*";	# boolean tag
< 	append	RE "(0|1)$WS*";		# boolean value
< 	append	RE "</boolean>$WS*";	# end boolean tag
< 	append	RE "(.*)";		# leftover
< 
< 	if {![regexp $RE $str {} bool rest]} {
< 		return [errReturn "Invalid Boolean"]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $bool]
---
>     set	RE "<boolean>$WS*";	# boolean tag
>     append	RE "(0|1)$WS*";		# boolean value
>     append	RE "</boolean>$WS*";	# end boolean tag
>     append	RE "(.*)";		# leftover
> 
>     if {![regexp $RE $str {} bool rest]} {
> 	return [errReturn "Invalid Boolean"]
>     }
>     set rest [string trim $rest]
>     return [list $rest $bool]
643c654
< 	variable	WS
---
>     variable	WS
645,654c656,665
< 	set	RE "<string>";		# string tag
< 	append	RE "(\[^<\]*)";		# string value
< 	append	RE "</string>$WS*";	# end string tag
< 	append	RE "(.*)";		# leftover
< 
< 	if {![regexp $RE $str {} s rest]} {
< 		return [errReturn "Invalid String"]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $s]
---
>     set	RE "<string>";		# string tag
>     append	RE "(\[^<\]*)";		# string value
>     append	RE "</string>$WS*";	# end string tag
>     append	RE "(.*)";		# leftover
> 
>     if {![regexp $RE $str {} s rest]} {
> 	return [errReturn "Invalid String"]
>     }
>     set rest [string trim $rest]
>     return [list $rest $s]
658,659c669,670
< 	variable	WS
< 	variable	DIGIT
---
>     variable	WS
>     variable	DIGIT
661,675c672,686
< 	set	RE "<double>$WS*";			# double tag
< 	append	RE "(-*)($DIGIT*\.?$DIGIT*)$WS*";	# double value
< 	append	RE "</double>$WS*";			# end double tag
< 	append	RE "(.*)";				# leftover
< 
< 	if {![regexp $RE $str {} negp d rest]} {
< 		return [errReturn "Invalid Double"]
< 	}
< 	if {$negp != ""} {
< 		set d [expr -1 * $d]
< 	} else {
< 		set d [expr 1 * $d]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $d]
---
>     set	RE "<double>$WS*";			# double tag
>     append	RE "(-*)($DIGIT*\.?$DIGIT*)$WS*";	# double value
>     append	RE "</double>$WS*";			# end double tag
>     append	RE "(.*)";				# leftover
> 
>     if {![regexp $RE $str {} negp d rest]} {
> 	return [errReturn "Invalid Double"]
>     }
>     if {$negp != ""} {
> 	set d [expr -1 * $d]
>     } else {
> 	set d [expr 1 * $d]
>     }
>     set rest [string trim $rest]
>     return [list $rest $d]
679,685c690,691
< 	variable	WS
< 	variable	DIGIT
< 
< 	set	RE "<dateTime\\.iso8601>$WS*";			# dateTime tag
< 	append	RE "($DIGIT+T$DIGIT+:$DIGIT+:$DIGIT+)$WS*";	# dateTime value
< 	append	RE "</dateTime\\.iso8601>$WS*";			# end string tag
< 	append	RE "(.*)";					# leftover
---
>     variable	WS
>     variable	DIGIT
687,691c693,702
< 	if {![regexp $RE $str {} dateTime rest]} {
< 		return [errReturn "Invalid DateTime"]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $dateTime]
---
>     set	RE "<dateTime\\.iso8601>$WS*";			# dateTime tag
>     append	RE "($DIGIT+T$DIGIT+:$DIGIT+:$DIGIT+)$WS*";	# dateTime value
>     append	RE "</dateTime\\.iso8601>$WS*";			# end string tag
>     append	RE "(.*)";					# leftover
> 
>     if {![regexp $RE $str {} dateTime rest]} {
> 	return [errReturn "Invalid DateTime"]
>     }
>     set rest [string trim $rest]
>     return [list $rest $dateTime]
695,700c706
< 	variable	WS
< 
< 	set	RE "<base64>";		# string tag
< 	append	RE "(\[^<\]*)";		# string value
< 	append	RE "</base64>$WS*";	# end string tag
< 	append	RE "(.*)";		# leftover
---
>     variable	WS
702,706c708,717
< 	if {![regexp $RE $str {} s rest]} {
< 		return [errReturn "Invalid Base64"]
< 	}
< 	set rest [string trim $rest]
< 	return [list $rest $s]
---
>     set	RE "<base64>";		# string tag
>     append	RE "(\[^<\]*)";		# string value
>     append	RE "</base64>$WS*";	# end string tag
>     append	RE "(.*)";		# leftover
> 
>     if {![regexp $RE $str {} s rest]} {
> 	return [errReturn "Invalid Base64"]
>     }
>     set rest [string trim $rest]
>     return [list $rest $s]
710,729c721
< 	variable	WS
< 
< 	set	RE "<array>$WS*";	# array tag
< 	append	RE "<data>$WS*";	# data tag
< 	append	RE "(.*)";		# leftover
< 
< 	if {![regexp $RE $str {} rest]} {
< 		return [errReturn "Invalid Array"]
< 	}
< 	set l {}
< 	while {[string range $rest 0 6] == "<value>"} {
< 		set res [unmarshall $rest]
< 		set rest [lindex $res 0]
< 		set el [lindex $res 1]
< 		lappend l $el
< 	}
< 
< 	set	REAREND "</data>$WS*";	# end data tag
< 	append	REAREND "</array>$WS*";	# end array tag
< 	append	REAREND "(.*)";		# leftover
---
>     variable	WS
731,734c723,745
< 	if {![regexp $REAREND $rest {} leftover]} {
< 		return [errReturn "Invalid End Array"]
< 	}
< 	return [list $leftover $l]
---
>     set	RE "<array>$WS*";	# array tag
>     append	RE "<data>$WS*";	# data tag
>     append	RE "(.*)";		# leftover
> 
>     if {![regexp $RE $str {} rest]} {
> 	return [errReturn "Invalid Array"]
>     }
>     set l {}
>     while {[string range $rest 0 6] == "<value>"} {
> 	set res [unmarshall $rest]
> 	set rest [lindex $res 0]
> 	set el [lindex $res 1]
> 	lappend l $el
>     }
> 
>     set	REAREND "</data>$WS*";	# end data tag
>     append	REAREND "</array>$WS*";	# end array tag
>     append	REAREND "(.*)";		# leftover
> 
>     if {![regexp $REAREND $rest {} leftover]} {
> 	return [errReturn "Invalid End Array"]
>     }
>     return [list $leftover $l]
738,743c749,750
< 	variable	WS
< 	variable	W
< 
< 	if {[string range $str 0 7] != "<struct>"} {
< 		return [errReturn "Invalid Struct"]
< 	}
---
>     variable	WS
>     variable	W
745,750c752,764
< 	set	RE "<name>$WS*";	# name tag
< 	append	RE "($W+)$WS*";		# key
< 	append	RE "</name>$WS*";	# end name tag
< 	append	RE "(<value>.*)";	# value tag
< 
< 	set l {}
---
>     if {[string range $str 0 7] != "<struct>"} {
> 	return [errReturn "Invalid Struct"]
>     }
> 
>     set	RE "<name>$WS*";	# name tag
>     append	RE "($W+?)$WS*";		# key
>     append	RE "</name>$WS*";	# end name tag
>     append	RE "(<value>.*)";	# value tag
> 
>     set l {}
>     set str [string range $str 8 end]
>     set str [string trim $str]
>     while {[string range $str 0 7] == "<member>"} {
753,767c767,768
< 	while {[string range $str 0 7] == "<member>"} {
< 		set str [string range $str 8 end]
< 		set str [string trim $str]
< 		if {![regexp $RE $str {} key val]} {
< 			return [errReturn "Invalid Struct Member"]
< 		}
< 		set res [unmarshall $val]
< 		set str [lindex $res 0]
< 		set el [lindex $res 1]
< 		lappend l [list $key $el]
< 		if {[string range $str 0 8] != "</member>"} {
< 			return [errReturn "Invalid End Struct Member"]
< 		}
< 		set str [string range $str 9 end]
< 		set str [string trim $str]
---
> 	if {![regexp $RE $str {} key val]} {
> 	    return [errReturn "Invalid Struct Member"]
769,770c770,775
< 	if {[string range $str 0 8] != "</struct>"} {
< 		return [errReturn "Invalid End Struct"]
---
> 	set res [unmarshall $val]
> 	set str [lindex $res 0]
> 	set el [lindex $res 1]
> 	lappend l [list $key $el]
> 	if {[string range $str 0 8] != "</member>"} {
> 	    return [errReturn "Invalid End Struct Member"]
774c779,785
< 	return [list $str $l]
---
>     }
>     if {[string range $str 0 8] != "</struct>"} {
> 	return [errReturn "Invalid End Struct"]
>     }
>     set str [string range $str 9 end]
>     set str [string trim $str]
>     return [list $str $l]
784,788c795,798
< 	foreach {cons} $list {
< 		set tkey [lindex $cons 0]
< 		if {$key == $tkey} {
< 			return $cons
< 		}
---
>     foreach {cons} $list {
> 	set tkey [lindex $cons 0]
> 	if {[string tolower $key] == [string tolower $tkey]} {
> 	    return $cons
790c800,801
< 	return {}
---
>     }
>     return {}
794c805
< 	puts stderr $msg
---
>     puts stderr $msg
798c809
< 	variable	DEBUG
---
>     variable	DEBUG
800,802c811,813
< 	if {$DEBUG} {
< 		puts "$msg"
< 	}
---
>     if {$DEBUG} {
> 	puts "$msg"
>     }
806,807c817,818
< 	warn $msg
< 	return -code error
---
>     warn $msg
>     return -code error
811,827c822,838
< 	set person(first) {string "eric m"}
< 	set person(last) {string yeh}
< 	set employed(programmer) {struct person}
< 
< 	#set xml [marshall {struct employed}]
< 	#set w [list {int 1}]
< 	#set q [list "array \{$w\}" {int 2} {string eric}]
< 	#puts [marshall "array \{$q\}"]
< 
< 	#set xml [marshall {array {{int 1} {string {hello everybody}}}}]
< 	set xml [marshall {struct person}]
< 	debug "xml:\n$xml"
< 	set data [unmarshall $xml]
< 	debug "data: $data"
< 	set data [lindex $data 1]
< 	debug "data: $data"
< 	puts [assoc "first" $data]
---
>     set person(first) {string "eric m"}
>     set person(last) {string yeh}
>     set employed(programmer) {struct person}
> 
>     #set xml [marshall {struct employed}]
>     #set w [list {int 1}]
>     #set q [list "array \{$w\}" {int 2} {string eric}]
>     #puts [marshall "array \{$q\}"]
> 
>     #set xml [marshall {array {{int 1} {string {hello everybody}}}}]
>     set xml [marshall {struct person}]
>     debug "xml:\n$xml"
>     set data [unmarshall $xml]
>     debug "data: $data"
>     set data [lindex $data 1]
>     debug "data: $data"
>     puts [assoc "first" $data]
831c842
< 	global xmlcall
---
>     global xmlcall
833,837c844,848
< 	if {$xmlcall} {
< 		global readdone
< 		set readdone -1
< 		set xmlcall 0
< 	}
---
>     if {$xmlcall} {
> 	global readdone
> 	set readdone -1
> 	set xmlcall 0
>     }
