This file is indexed.

/usr/share/saods9/src/xmlrpc.tcl is in saods9-data 7.2+dfsg-4.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
# xmlrpc0.3
# Written by Eric Yeh
#
# Server API:
#	xmlrpc::serve
#	Note: all callable functions should be defined in the global scope
#
# Client API:
#	xmlrpc::call url methodName params
#		url is of the form "http://hostname:port"
#		methodName is the name of the method to call
#		and params is a list of arguments to the method
#		where each argument is a "typed tcl" value defined below
#	xmlrpc::buildRequest
#		return an XML-RPC client request
#	xmlrpc::marshall
#		return a marshalled "typed tcl" value
#	xmlrpc::unmarshall
#		return an unmarshalled "typed tcl" value
#	xmlrpc::assoc
#		return a cons of a list if the key matches
#
# Typed Tcl values:
# 	Because Tcl has no types for variables, all values will be represented
# 	as a 2 element tuple of the form:
# 	{type, value} where value is the original value
# 	and type is a string describing its type.
# 	Valid types (case sensitive, must be lowercase):
#		int
#		boolean
#		string
#		double
#		dateTime.iso8601
#		base64
#		struct
#		array
#	Note:
#		When marshalling dictionaries(tcl arrays), tcl has no
#		way of creating unnamed dictionaries.  Therefore,
#		the way to use a dictionary is to create it as normal,
#		and refer to its name in the "tcl type".
#		For example:
#			set dict(first) {string eric}
#			xmlrpc::marshall {struct dict}
#
#		the marshall procedure will attempt to "find" dict
#		using upvar(yuck!) and checking the global scope.
#
# Unmarshalling of a dictionary results in a 2 element
# list of the form (remaining, alist)
# where remaining is unused marshalled data (should be empty)
# and alist is an A-list.
# An A-list has the form:
# {key, datum} where key is the key and datum is its value.
# The method "assoc" is provided to access information from
# this data structure.  It behaves like the LISP assoc, in that
# it will return the (key, datum) pair if a match is found.

# TODO:
# -currently server functions can't return dictionaries
# -add more error handling
# -Check for [{}] in unmarshalling
# -Empty dictionaries

package provide xmlrpc 0.3

namespace eval xmlrpc {
	namespace	export call buildRequest marshall unmarshall assoc
	namespace	export serve

	variable	READSIZE 4096;		# read size

	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
}

# Given a port, create a new socket
# and start listening on it
#
proc xmlrpc::serve {port} {
	variable	acceptfd

	set acceptfd [socket -server xmlrpc::serveOnce $port]
    return $acceptfd
}

# Accept a new connection
#
proc xmlrpc::serveOnce {sock addr port} {
	variable	READSIZE

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

# Given a socket,
# Handle an XML-RPC request
#
proc xmlrpc::doRequest {sock} {
	variable	WS

	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]

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

# Given a "typed tcl" value,
# build an XML-RPC response
#
proc buildResponse {result} {
	# 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]
}

# Given an error code (integer)
# and an errmsg (string)
# build an XML-RPC fault
#
proc buildFault {errcode errmsg} {
	set err(faultCode) [list int $errcode]
	set err(faultString) [list string $errmsg]

	# 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"

	set response "$header\n$body"
	return [string trim $response]
}

# send an XML-RPC request
#
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"]
	}
}

# Given a socket to read on,
# get and parse the response from the server
#
proc xmlrpc::getResponse {sock} {
	variable	response
	global		readdone

	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
}

# Given a socket to read on,
# a string of header information
# and a string, body,
# return a string representing the entire body
#
proc xmlrpc::getBody {sock header body} {
	set res [parseHTTPHeaders $header]
	set headersl [lindex $res 1];		# A-list of headers

	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
}

# Given a socket to read on,
# Return a 2 element list of the form:
# {header, body} where both are strings
# Note: header will include the first line which is the status
#
proc xmlrpc::readHeader {sock} {
	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
		}
	}
	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]
}

# Given the body buffer,
# the number of bytes expected in the body (Content-Length)
# and a socket to read on,
# return the entire body buffer
#
proc xmlrpc::readBody {body expLen sock} {
	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"]
		}
	}
	return $newbody
}

# Given a string, str,
# check the HTTP status
# and return the unused portion of str
#
proc xmlrpc::parseHTTPCode {str} {
	variable	DIGIT

	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
}

# Given a string, str,
# return a 2 element list of the form:
# {remaining, alist}
# where remaining is the unused portion of str
# and alist is an A-list of header information
#
proc xmlrpc::parseHTTPHeaders {str} {
	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]
}

# Given a string, str
# parse the response from the server
# returning the unmarshalled data
#
proc xmlrpc::parseResponse {str} {
	variable	WS

	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]} {
		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"]
		}
	}
	set result [unmarshall $value]
	return $result
}

# Given a non-blocking file descriptor, fd
# do a read
#
proc xmlrpc::nbRead {fd} {
	variable	READSIZE

	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
}

# Given a methodName,
# and a list of parameters,
# return an XML-RPC request
#
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"]

	set request "$header\r\n$body"
	return $request
}

# Given a "typed tcl" value
# return the marshalled representation
#
proc xmlrpc::marshall {param {ntabs 0} {distance 1}} {
	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"]
	}
}

# Given a value param,
# return 1 if it a valid parameter
# return 0 if not
# A valid parameter is a 2 element tuple
#
proc xmlrpc::validParam {param} {
	if {[llength $param] != 2} {
		return 0
	}
	return 1
}

# Given a marshalled value,
# unmarshall it and return it
#
proc xmlrpc::unmarshall {str} {
	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"
	|| $btag == "i4"} {
		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]
	    } else {
		return [errReturn "Unknown type: $str"]
	    }
	}

	set rest [lindex $res 0]
	set val [lindex $res 1]

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

proc xmlrpc::umInt {str} {
	variable	WS
	variable	DIGIT

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

proc xmlrpc::umBool {str} {
	variable	WS

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

proc xmlrpc::umString {str} {
	variable	WS

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

proc xmlrpc::umDouble {str} {
	variable	WS
	variable	DIGIT

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

proc xmlrpc::umDateTime {str} {
	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

	if {![regexp $RE $str {} dateTime rest]} {
		return [errReturn "Invalid DateTime"]
	}
	set rest [string trim $rest]
	return [list $rest $dateTime]
}

proc xmlrpc::umBase64 {str} {
	variable	WS

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

proc xmlrpc::umArray {str} {
	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

	if {![regexp $REAREND $rest {} leftover]} {
		return [errReturn "Invalid End Array"]
	}
	return [list $leftover $l]
}

proc xmlrpc::umStruct {str} {
	variable	WS
	variable	W

	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>"} {
		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 {[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]
}

# Given a key, and a list of elements where each element is of the form:
# {key, datum}, return {key, datum} if the requested key matches
# a key in the list.
# Returns the first match found in the list.
# Return {} on failure
#
proc xmlrpc::assoc {key list} {
	foreach {cons} $list {
		set tkey [lindex $cons 0]
		if {$key == $tkey} {
			return $cons
		}
	}
	return {}
}

proc xmlrpc::warn {msg} {
	puts stderr $msg
}

proc xmlrpc::debug {msg} {
	variable	DEBUG

	if {$DEBUG} {
		puts "$msg"
	}
}

proc xmlrpc::errReturn {msg} {
	warn $msg
	return -code error
}

proc xmlrpc::test {} {
	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]
}

proc bgerror {error} {
	global xmlcall

	if {$xmlcall} {
		global readdone
		set readdone -1
		set xmlcall 0
	}
}

#xmlrpc::test