#!/bin/sh

## "LDASJobH"
## Helper process for LDASJob asynchronous communication
## Written by Peter Shawhan, October-November 2001
## Globus interface by Mary Lei

## The next line tells sh to execute the script using tclshexe \
exec tclsh "$0" ${1+"$@"}

set ::version 3.0

;## time out this job if not heard from manager for 2 min
set  ::MANAGER_REPLY_TIMEOUT 120000

#==============================================================================
## vars to support tclglobus

;## desc=manager globus ports for receiving jobs via user cert
set ::TCLGLOBUS_USER_PORT 10031

;## desc=manager globus ports for receiving jobs via host cert
set ::TCLGLOBUS_HOST_PORT 10030

## desc=option to use globus tcl channel
set ::USE_GLOBUS_CHANNEL 1

;## desc=tcl globus lib directory
;## use VDT tclglobus first, default to /ldcg last
if  { [ info exist ::env(TCLGLOBUS_DIR) ] } {
    set  ::TCLGLOBUS_DIR $::env(TCLGLOBUS_DIR)
} elseif { [ info exist ::env(VDT_LOCATION) ] && \
	       [ file exist $::env(VDT_LOCATION)/tclglobus/lib ] } {
    set  ::TCLGLOBUS_DIR $::env(VDT_LOCATION)/tclglobus/lib
} elseif { $::tcl_platform(wordSize) == 8 && \
	       [ file exist /ldcg/lib/64/libtclglobus_module.so] } {
    set ::TCLGLOBUS_DIR /ldcg/lib/64
} elseif { $::tcl_platform(wordSize) == 8 && \
	       [ file exist /ldcg/lib64/libtclglobus_module.so] } {
    set ::TCLGLOBUS_DIR /ldcg/lib64
} elseif { [ file exist /ldcg/lib/libtclglobus_module.so] } {
    set ::TCLGLOBUS_DIR /ldcg/lib
} else {
    catch { unset ::TCLGLOBUS_DIR }
    set ::USE_GLOBUS_CHANNEL 0
}

;## desc=default user for gsi sockets
set ::GLOBUS_DEFAULT_USER Edward_Maros

;## desc=service for globus tcl channel
set ::SERVICE_NAME ldas

;## desc=enable gsi authenication in globus channel or disable (blanks)
set ::GSI_AUTH_ENABLED "-gsi_auth_enabled"

;## desc=verify via host or user cert
if	{ [ regexp -nocase -- {ldas|install} $::tcl_platform(user) ] } {
	set ::PROXY_TYPE "-host"
    set ::globus_manager_port $::TCLGLOBUS_HOST_PORT
} else {
	set ::globus_manager_port $::TCLGLOBUS_USER_PORT
}

## desc=option to use gsi authenication
set ::USE_GSI 1

set ::globuslibs [ list globus_module \
                  globus_error \
                  globus_object \
          gt_xio_socket_swig ]

;## override GSI and globus settings via env
if	{ [ info exist ::env(USE_GLOBUS_CHANNEL) ] } {
	set  ::USE_GLOBUS_CHANNEL [ set ::env(USE_GLOBUS_CHANNEL) ]
}

if	{ [ info exist ::env(USE_GSI) ] } {
	set  ::USE_GSI [ set ::env(USE_GSI) ]
}

set ::globusError ""

if	{ $::USE_GLOBUS_CHANNEL && [info exists ::TCLGLOBUS_DIR] } {
	foreach lib $::globuslibs {
		set lib [ file join $::TCLGLOBUS_DIR libtcl${lib}.so ]
		if	{ [ file exist $lib ] } {
			if	{ [ catch  {
				load $lib 
			} err ] } {
				append ::globusError "$lib error: $err\n"
			}
		} else {
			append ::globusError "$lib does not exist\n"
		}	
	# load [ eval file join $::TCLGLOBUS_DIR libtcl${lib}.so ]
	}
	set ::globusError [ string trim $::globusError \n ]
    if  { [ string length $::globusError ] } {
        set ::USE_GLOBUS_CHANNEL 0
    }
}

;## place timeout on tclglobus socket
set ::TCLGLOBUS_SOCKET_TIMEOUT 5

;## place timeout on job reply from manager if set by user
if	{ [ info exist ::env(MANAGER_REPLY_TIMEOUT) ] } {
	set  ::MANAGER_REPLY_TIMEOUT [ set ::env(MANAGER_REPLY_TIMEOUT) ]
}

;## need this if /etc/grid-security is not accessible
if	{ [ info exist ::env(X509_CERT_DIR) ] } {
	set  ::X509_CERT_DIR [ set ::env(X509_CERT_DIR) ]
}

#==============================================================================
## Name: Main

proc Main {} {

    ;##- Initialize some global variables
    set ::patchStatus ""
    set ::patchVersion ""

    ;##- Create the ~/.LDASJobH directory, if necessary
    set ::baseDir [file join ~ .LDASJobH]
    if { ! [file isdirectory $::baseDir] } {
	catch { file mkdir $::baseDir }
    }

    ;##- Hard-coded IP addresses:
    ;##-   www.ldas-sw.ligo.caltech.edu  131.215.115.247
    ;##-   www.ldas.ligo-wa.caltech.edu  198.129.208.245
    ;##-   www.ldas.ligo-la.caltech.edu  130.39.245.245
    ;##-   www-ldas.mit.edu              18.120.0.97
    ;##-   www.ldas-cit.ligo.caltech.edu 131.215.114.9

    set ::httpPatchHosts [list \
	    www.ldas-sw.ligo.caltech.edu \
	    www.ldas.ligo-wa.caltech.edu \
	    www.ldas.ligo-la.caltech.edu \
	    www-ldas.mit.edu \
	    www.ldas-cit.ligo.caltech.edu \
	    gateway ]
    set ::httpPatchDir "ligotools/ldasjob/patches"
    set ::httpPatchTimeout 30000

    #-- If running on one of the ldas-jobs machines, or if the user specified
    #-- "none" in the environment variable WEBPATCH_HOST, then just complete
    #-- the startup
    if { [regexp -nocase {^ldas-jobs} [info hostname]] || \
	    ( [info exists ::env(WEBPATCH_HOST)] \
	      && [string equal -nocase $::env(WEBPATCH_HOST) "none"] ) } {
	set ::patchStatus "no_check"
	Startup
	return
    }

    #-- Check whether user explicitly specified the web-patch host; if so,
    #-- override the default list.
    if { [info exists ::env(WEBPATCH_HOST)] } {
	set ::httpPatchHosts $::env(WEBPATCH_HOST)
    }

    ;##- Find a patch host that is alive, and determine our IP address from it
    set host ""
    set timeout [expr {int(30000/[llength $::httpPatchHosts])}]
    foreach tryhost $::httpPatchHosts {
	set ip [EchoMyIP $tryhost 80 $timeout]
	if { $ip != "" } {
	    set ::myIP $ip
	    set host $tryhost
	    break
	}
    }
    if { $host == "" } {
	;##- None of the hosts responded!
	;##- Try again to get patches from the first host, though it may fail
	;##- Defer setting ::myIP until we open a listening socket
	set host [lindex $::httpPatchHosts 0]
    }
    set ::patchHost $host

    ;##- Check web site for any needed patches
    set upURL "http://$host/$::httpPatchDir/LDASJobH${::version}_patches"
    if { [file exists ~] } {
	set patchfile [file join $::baseDir .LDASJobH${::version}_patches]
    } else {
	set patchfile ""
    }
    
    set ::patchStatus [WebPatchCheck $upURL $patchfile]
    if { [string match "no_file" $::patchStatus]} {
	set ::patchVersion $::version
    }
##- Comment this out, so that we can run even if the web server is down
#    if { $::patchVersion == "" } {
#	puts stderr "LDASJobH error: failed to check for patches.  Aborting"
#	exit 1
#    }

    ;##- Finish the startup process (with routines which may be web-patched)
    Startup

    return
}


##=========================================================================
## Name: EchoMyIP
##
## Description:
##   Attempts to connect to a host.  If successful, returns our IP address
##   (determined from the socket) for the network interface that made the
##   connection.  (This is useful in case we have more than one network
##   interface.)  If unsuccessful, returns ""
##
## Usage:
##   set ip [EchoMyIP ip port maxtime]
##
## Parameters:
##   ip - Host name or numeric IP address
##   port - Port number to try to connect to
##   maxtime - Maximum time to try to connect, in milliseconds
##
## Comments:
##   This routine is NOT web-patchable, since it is called prior to
##   calling WebPatchCheck.

proc EchoMyIP { ip port maxtime } {

    ;##- Do an asynchronous open so that we can implement our own
    ;##- timeout mechanism.

    set ::connectFlag pending
    set evtid [after $maxtime "set ::connectFlag timeout"]
    if { [catch {socket -async $ip $port} sid] } {
	after cancel $evtid
	unset ::connectFlag
	return ""
    }
    fileevent $sid w "set ::connectFlag connected"

    ;##- Now wait for a connection or timeout
    vwait ::connectFlag

    fileevent $sid w {}
    after cancel $evtid
    if { $::connectFlag == "timeout" } {
	unset ::connectFlag
	close $sid
	return ""
    }

    unset ::connectFlag
    set msg [fconfigure $sid -error]
    if { ! [string is space $msg] } {
	close $sid
	return ""
    }

    ;##- At this point, we know that the socket connection succeeded
    ;##- Determine our IP address from the socket connection
    set portinfo [fconfigure $sid -sockname]
    set myip [lindex $portinfo 0]

    ;##- Close the connection
    close $sid

    return $myip
}


##=========================================================================
## Name: WebPatchCheck
##
## Description:
##   Routine to download a file of Tcl code from a URL and eval it.
## 
## Parameters:
##   url -- URL to download
##
## Usage:
##   WebPatchCheck url
##
## Comments:
##   Returns one of the following:
##     1. "OK"
##     3. "no_file"
##     2. "no_connect"
##     1. "no_server"
## ;#ol

proc WebPatchCheck { url {patchfile ""} } {

    #-- We may need to loop, if there is URL redirection
    set origurl $url
    while { 1 } {

    if { [catch {http::geturl $url -timeout $::httpPatchTimeout} httpvar] } {
	set retcode "no_server"
    } else {
	#-- Parse the http response string
	upvar #0 $httpvar httpstate

	#-- Parse the "meta" array, if it exists
	if { [info exists httpstate(meta)] } {
	    array set httpmeta $httpstate(meta)
	} else {
	    set httpmeta(null) ""
	}

	if {[info exists httpstate(http)]} {
	    regexp -- {^([^\s]+)\s([^\s]+)\s(.*)$} $httpstate(http) \
		    match httpversion httpcode status
	    if {[info exists httpcode]} {
		if {$httpcode == "200"} {
		    set retcode "OK"
		} elseif { [string match "3*" $httpcode] && \
			       [info exists httpmeta(Location)] } {
		    #-- http redirection!
		    set url $httpmeta(Location)
		    unset $httpvar
		    continue
		} else {
		    set retcode "no_file"
		}
	    } else {
		set retcode "no_connect"
	    }
	} else {
	    set retcode "no_connect"
	}
    }

    break
    }
    #-- End while-loop to handle http redirection

    #-- Handle errors
    switch -- $retcode {
	"no_server" -
	"no_connect" {

	    ;##- See if the patch file is available on disk
	    if { [file readable $patchfile] } {
		catch {
		    set fhandle [open $patchfile r]
		    eval [read $fhandle]
		    close $fhandle
		    set retcode "locally_patched"
		}
	    }

	}

	"no_file" {
	}

	"OK" {
	    eval $httpstate(body)

	    ;##- Save patch file on disk for possible future use
	    if { ! [string equal $patchfile ""] } {
		catch {
		    set fhandle [open $patchfile w]
		    puts $fhandle $httpstate(body)
		    close $fhandle
		}
	    }
	}

    }
    http::cleanup $httpvar

    return $retcode
}


#==============================================================================
## Name: Startup
##
## Description:
##   Called by Main (after web-patching) to do rest of startup stuff.

proc Startup {} {

    if [info exists ::myIP] {
	MonMsg "my IP address is $::myIP"
    }
    MonMsg "base version is $::version"
    if [info exists ::patchHost] {
	MonMsg "web-patch host is $::patchHost"
    }
    MonMsg "web-patch status is $::patchStatus"
    MonMsg "patched version is $::patchVersion"

    ;##- Initialize some global variables
    set ::input ""
    set ::taskCounter 0
    set ::activeTasks {}
    set ::clientDir ""

    ;##- Set up the listening sockets
       if {[catch {
	set ::replySock [OpenListen network 0 ReplyConnect]
	set portinfo [fconfigure $::replySock -sockname]
	if { ! [info exists ::myIP] } {
	    set ::myIP [lindex $portinfo 0]
	    MonMsg "my IP address is $::myIP"
	}
	set ::replyPort [lindex $portinfo 2]
	MonMsg "Opened reply socket on port $::replyPort"
    } ]} {
	MonMsg "Error setting up reply socket"
	ShutDown error
    }
 
    if {[catch {
	set ::httpSock [OpenListen network 0 HttpConnect]
	set portinfo [fconfigure $::httpSock -sockname]
	set ::httpPort [lindex $portinfo 2]
	MonMsg "Opened http socket on port $::httpPort"
    } ]} {
	MonMsg "Error setting up http socket"
	ShutDown error
    }

    ;##- Start the periodic task to write a line to the log file
    after 3600000 LogHeartbeat

    ;##- Start listening for client input on stdin
    fileevent stdin readable ClientInput

    ;##- Start the event loop
    MonMsg "Entering event loop at [clock format [clock seconds]]"
    vwait ::SHUTDOWN

    ShutDown $::SHUTDOWN

}


##=========================================================================
## Name: OpenListen
##
## Description:
##   Proc to open a listening socket.
## 
## Parameters:
##   type -- Socket type ("network" or "local")
##   port -- Port number to use
##   connector -- Name of routine to call when a connection is made
##
## Usage:
##   set sock [OpenListen local 11892 ClientConnect]
##
## Comments:
##   .

proc OpenListen { type port connector } {

    switch $type {
	"local" { set hostname "localhost" }
	"network" {
	    if { [info exists ::myIP] } {
		set hostname $::myIP
	    } else {
		;##- Try to determine our hostname
		set hostname [info hostname]
		;##- For machines with multiple network interfaces, we need to
		;##- specify the hostname which is visible to the LDAS manager.
		;##- Unfortunately, sometimes the "primary" network interface
		;##- is on a Martian network.  So translate the known cases.
		switch -- $hostname {
		    gdsdmt0 { set hostname "sand" }
		    gdsdmt1 { set hostname "stone" }
		    gdsdmt { set hostname "delaronde" }
		}
	    }
	}
    }

###    MonMsg "hostname is $hostname"

    if { [catch {socket -server $connector -myaddr $hostname $port} lsock] } {
        return -code error ""
    }

    return $lsock
}


##=========================================================================
## Name: ClientInput

proc ClientInput {} {

    set close 0

    if { [eof stdin] } {
	MonMsg "Reached EOF on stdin"
	set close 1
    } elseif { [catch {gets stdin line} nchars] } {
	MonMsg "Error reading line from client stdin: $nchars"
	set close 1
    }

    ;##- If the socket data is complete, do something
    if { $close == 1 } {
	MonMsg "stdin was closed at [clock format [clock seconds]]"
	close stdin

	;##- See if we can shut down now
	ShutdownCheck

	return
    }

    ;##- If we get to this point, then we successfully read a line
    ;##- If line is blank, ignore it
    if { [string is space $line] } return
###    MonMsg "On stdin, received $line"

    ;##- Append this line to the input buffer
    append ::input "$line\n"

    ;##- If this is a complete input command, do something with it
    if { [info complete $::input] } {
	;##- Pass this to ClientCommand, after trimming off the end-of-line
	set retval [catch \
		{eval ClientCommand [string range $::input 0 end-1]} msg]

	switch $retval {

	    0 {	;##- Normal return
		catch { puts [list "ok" $msg]; flush stdout }
	    }

	    1 {	;##- Software error
	        MonMsg "Returning software error message to client: $msg"
		catch { puts [list "error" $msg]; flush stdout }
	    }

	    3 {	;##- "break" return code -- LDAS job failed
		catch { puts [list "fail" $msg]; flush stdout }
	    }

	    4 {	;##- "continue" return code -- don't send anything to stdout
	    }
	}

	set ::input ""
    }

    return
}


##=========================================================================
## Name: ClientCommand
##
## Returns with:
##   code=ok, value=<message> to send message back to the client
##   code=break, value=<message> to send message back to the client
##   code=continue, value=<null> if nothing should be sent back to client now
##   code=error, value=<error message> if some error occurred

proc ClientCommand { args } {
    MonMsg "ClientCommand $args"

    set oper [lindex $args 0]

    ;##- Handle some special cases here
    if { $oper == "protocol" } {
	set ::clientProtocol [lindex $args 1]
	if { $::clientProtocol == 2 } {
	    ;##- Return with successful code
	    return
	} else {
	    ;##- We cannot handle the client's communication protocol!
	    return -code error \
		    "This LDASJobH cannot handle protocol $::clientProtocol"
	}
    } elseif { $oper == "volatiles" } {
	;##- Send list of volatile array elements back to the client
	return [list "status" "done"]
    } elseif { $oper == "cwd" } {
	set ::clientDir [lindex $args 1]
	;##- Nothing should be sent back to client in response to this
	return -code continue
    }

    ;##- For most operations, get the job tag
    if { $oper != "shutdown" } {

	if { [llength $args] < 2 } {
	    return -code error "Job tag was not specified"
	}
	set jobtag [lindex $args 1]
	;##- Make sure a non-blank jobtag was passed
	if { [string is space $jobtag] } {
	    return -code error "Invalid job name"
	}

	;##- For most operations, make sure the job info array exists, look up
	;##- the internal task number, and get access to the task's state array
	if { $oper != "submit" && $oper != "usage" } {
	    if { [info exists ::jobtagToTask($jobtag)] } {
		set task $::jobtagToTask($jobtag)
		upvar #0 taskState$task tstate
	    } else {
		return -code error "Job $jobtag does not exist"
	    }
	}
    }

    switch -- $oper {

	"submit" {

	    ;##- Make sure there is not already an active job with this jobtag
	    if { [info exists ::jobtagToTask($jobtag)] } {
		return -code error "A job named $jobtag already exists"
	    }

	    ;##- Submit this LDAS job.  The return value will be 0 if
	    ;##- submission was successful and the job is now running,
	    ;##- 3 ("break") if the LDAS job failed during submission,
            ;##- or 1 if there was an internal software error.
	    set retval [catch {eval LDASSubmit [lindex $args 2]} task]
	    MonMsg "Return value from LDASSubmit is $retval"

	    if { $retval == 1 } {
		;##- Software error
		return -code error $task
	    }

	    ;##- At this point, we know that we have a valid task number
	    ;##- Index between the jobtag and the internal task number
	    set ::jobtagToTask($jobtag) $task
	    set ::taskToJobtag($task) $jobtag

	    ;##- Increment the retry counter if this is a resubmission
	    if { [llength $args] >= 4 && [lindex $args 3] == "resubmit" } {
		incr ::jobtagRetries($jobtag)
	    } else {
		set ::jobtagRetries($jobtag) 0
	    }

	    ;##- Get access to the state array for this task
	    upvar #0 taskState$task tstate

	    ;##- See whether LDAS job has failed already
	    if { $retval == 3 } {
		;##- LDAS job failed
		return -code break [StateDump $task]
	    }

	    ;##- Set up a callback to send job info back to the client when
	    ;##- the job has been submitted successfully, and return with the
	    ;##- "continue" code to make the client wait
	    MonMsg "Setting up client callback for when job is submitted"
	    set tstate(callback_when) "submitted"
	    set tstate(callback) "dump"
	    return -code continue
	}

	"usage" {
	    return [UsageInfo [lindex $args 1]]
	}

	"status" {
	    return $tstate(status)
	}

	"delete" {
	    ;##- Disconnect this jobtag from the internal task
	    unset ::jobtagToTask($jobtag)

	    ;##- Mark this task as having been "deleted" by the client, but
	    ;##- don't necessarily delete its state array, since the job might
	    ;##- actually still be running
	    set tstate(deleted) 1

	    ;##- If the task is no longer running, delete all record of it
	    if { $tstate(done) } {
		;##- (Any URLs assigned for this task have already been
		;##- removed [unless the -email option was used, in which case
		;##- we can't remove URLs since LDAS might not yet have read
		;##- them])
		MonMsg "Deleting state array for task $task"
		unset tstate
		unset ::taskToJobtag($task)
	    }

	    return
	}

	"fill" {
	    if { $tstate(status) == "error" } {
		return -code break [StateDump $task]
	    } else {
		return [StateDump $task]
	    }
	}

	"query" {
	    ;##- See what element is being queried
	    set element [lindex $args 2]
	    set retval [catch {ClientQuery $task $element} value]
	    return -code $retval $value
	}

	"wait" {
	    ;##- If job is already done, just return.  Otherwise, set up a
	    ;##- callback and return with the special "continue" code to make
	    ;##- the client wait.
	    #hack
	    MonMsg "Handling wait, done is $tstate(done) and status is $tstate(status)"
	    if { $tstate(done) } {
		if { $tstate(status) == "error" } {
		    return -code break [StateDump $task]
		} else {
		    return [StateDump $task]
		}
	    } else {
		MonMsg "Setting up client callback for when job is done"
		set tstate(callback_when) "done"
		set tstate(callback) "dump"
		return -code continue
	    }
	}

	"shutdown" {
	    set ::SHUTDOWN command
	    set ::whenShutdown { catch { puts "ok"; flush stdout } }
	    MonMsg "Waiting for shutdown to complete"
	    return -code continue
	}

	default {
	    return -code error "Invalid operation: $oper"
	}

    }
}


##=========================================================================
## Name: ClientQuery

proc ClientQuery { task element } {

    ;##- Get access to the state array for this task
    upvar #0 taskState$task tstate

    ;##- If the value of this element is already known, just return it,
    ;##- unless it is an "internal" element
    if { [info exists tstate($element)] } {
	switch $element {
	    password - pwprotocol - md5pw - opsock - callback - callback_when -
	    connectline - opTimeoutEvent - replyTimeoutEvent - submitArgs -
	    jobTimeoutEvent - infoBuf - deleted {}

	    default {
		return $tstate($element)
	    }
	}
    }

    ;##- If we get here, then we don't yet know the value

    ;##- Figure out at what point we can make a callback to return this value
    switch -glob $element {

	"command" -
	"user" -
	"email" -
	"manager" -
	"managerIP" -
	"managerPort" -
	"inputs" -
	"jobInfo" -
	"jobid" -
	"jobnum" -
	"LDASVersion" {
	    set when "submitted"
	}

	"jobReply" -
	"endTimeS" -
	"endTime" -
	"dbname:*" -
	"rows:*" -
	"jobTime" -
	"*Time" -
	"errorAPI" -
	"outputs" -
	"outputDir" -
	"error" {
	    set when "done"
	}

	default {
	    return -code error "$element is not a valid element of\
		    a job status array"
	}

    }

    ;##- If task is already done, the array element will never be filled
    if { $tstate(done) } {
	if { [info exists tstate(email)] } {
	    switch -- $tstate(status) {
		"submitted" { set descrip "Job submission completed" }
		"error" { set descrip "Job submission terminated\
			due to an error" }
		default { set descrip "Job submission terminated\
			(with status $tstate(status))" }
	    }
	} else {
	    switch -- $tstate(status) {
		"done" { set descrip "Job finished normally" }
		"error" { set descrip "Job was terminated due to an error" }
		default { set descrip "Job was terminated\
			(with status $tstate(status))" }
	    }
	}
	return -code break "$descrip without filling this array element"
    }

    MonMsg "Waiting until $when to send value of $element"

    set tstate(callback_when) $when
    set tstate(callback) "send $element"

    return -code continue
}


##=========================================================================
## Name: Resubmit

proc Resubmit { jobtag submitArgs } {

    set retval [catch \
	    [list ClientCommand submit $jobtag $submitArgs resubmit] \
	    msg]
    ;##- Note that a "submitted" callback has been set up at this point

    ;##- If an error occurred, send a message back to the user
    if { $retval == 1 } {
	MonMsg "Returning software error message to client: $msg"
	catch { puts [list "error" $msg]; flush stdout }
	return
    }

    set task $::jobtagToTask($jobtag)

    ;##- If LDAS job has failed already, send "fail" message back to client
    if { $retval == 3 } {
	catch { puts [list "fail" [StateDump $task]]; flush stdout }
	return
    }

    ;##- If we get to this point, then the first step of resubmitting the job
    ;##- has been successful.  Just return; the callback will fire when we
    ;##- know more.

    return
}


##=========================================================================
## Name: StateDump

proc StateDump { task } {

    ;##- Get access to the state array for this task
    upvar #0 taskState$task tstate

    ;##- Construct the return array, leaving out certain things
    set retarr {}
    foreach {elem value} [array get tstate] {
	switch -- $elem {
	    password - pwprotocol - md5pw - opsock - callback - callback_when -
	    connectline - opTimeoutEvent - replyTimeoutEvent - submitArgs -
	    jobTimeoutEvent - deleted {}

	    default {
		lappend retarr $elem $value
	    }
	}
    }

    return $retarr
}


##=========================================================================
## Name: StateCallback

proc StateCallback { task } {

    ;##- If state array does not exist for this task, just return
    if { ! [info exists ::taskState$task] } { return }

    ;##- Get access to the state array for this task
    upvar #0 taskState$task tstate

    ;##- Look up the type of callback to execute (if any)
    if { ! [info exists tstate(callback)] } { return }
    set cbtype $tstate(callback)

    ;##- Execute the appropriate callback
    switch -glob $cbtype {

	"dump" {
	    if { $tstate(status) == "error" } {
		set rettype "fail"
	    } else {
		set rettype "ok"
	    }
	    catch { puts [list $rettype [StateDump $task]]; flush stdout }
	}

	"send *" {
	    regexp {^send (.+)$} $cbtype match element
	    if { [info exists tstate($element)] } {
		catch { puts [list "ok" $tstate($element)]; flush stdout }
	    } else {
		;##- Construct an error message
		if { $tstate(done) } {
		    if { [info exists tstate(email)] } {
			switch -- $tstate(status) {
			    "submitted" { set descrip \
				    "Job submission completed" }
			    "error" { set descrip "Job submission terminated\
				    due to an error" }
			    default { set descrip "Job submission terminated\
				    (with status $tstate(status))" }
			}
		    } else {
			switch -- $tstate(status) {
			    "done" { set descrip "Job finished normally" }
			    "error" { set descrip "Job was terminated\
				    due to an error" }
			    default { set descrip "Job was terminated\
				    (with status $tstate(status))" }
			}
		    }
		    set errmsg "$descrip without filling this array element"
		} else {
		    set errmsg "Job has not filled this array element so far"
		}
		catch { puts [list "error" $errmsg]; flush stdout }
	    }
	}

    }

    ;##- Clear the callback
    unset tstate(callback) tstate(callback_when)

    return
}


##=========================================================================
## Name: UsageInfo

proc UsageInfo { command } {

    switch $command {

	"LJrun" { set msg {
Usage:  LJrun <jobtag> [<options>] <command>

By default, this submits an LDAS job and returns when the job has finished.
Information about the job (LDAS job ID, execution time, outputs, etc.) may be
accessed via elements of a global array with the same name as the jobtag.
Options, if any, must be placed between the jobtag (the first argument) and
the LDAS command (the last argument).  Valid options:

   -manager <manager>
       The address of the LDAS manager.  The "standard" LDAS systems may be
       referred to by shorthand names (llo, lho, uwm, dev, etc.), or you may
       specify an explicit address of the form <host> or <host>:<port>.  The
       default port is 10001.  If the '-manager' option is not used, then the
       value of the LDASMANAGER environment variable is used.

   -user <username>
       The LDAS username to use when submitting the job.  If omitted, the
       first username listed in your ~/.ldaspw file will be used. 

   -email <user>@<host>
   -email <host>:<port>
   -email
       Normally, the ldasjob library code receives a message from LDAS when a
       job finishes, and uses it to fill elements of the job info array.
       The -email option overrides this behavior, so that LDAS sends the
       job-finished message either to an email address (first form) or to
       a socket at a specific host and port (second form).  If the email
       address is not specified (third form), it is taken from the LDASEMAIL
       environment variable.

   -log
   -log <logcmd>
       Causes a command to be executed as soon as (and only if) an LDAS job
       is successfully submitted, typically to print a log message.  The
       command is executed in the scope of the routine which calls LJrun.
       If <logcmd> is omitted, or is the string 'default', then a standard
       message with the job tag and LDAS job ID is printed to standard
       output.  As a convenience, the <logcmd> may use 'this' to refer to
       the job info array of the job just submitted.  For example,
            -log {puts "Job ID is $this(jobid)"}
       prints the job ID of the LDAS job which has just been started, while
            -log "puts $fid \"Job ID is \$this(jobid)\""
       prints the same message to a file opened with file descriptor $fid.
       (The quoting in the latter example causes $fid to be substituted in
       the scope of the routine which calls LJrun, before the command is
       passed to LJrun.)

   -nowait
       The command returns as soon as the LDAS job has been submitted,
       without waiting for it to finish.  This allows you to run more than
       one job concurrently, if appropriate.
       
    -globus <0/1>
    	Use gsi socket for connection to manager if true.
        
    -gsi <0/1>
    	Usi gsi authenication if true. 
	} }

	default {
	    set msg "No usage info is available for that command"
	}

    }


    return $msg
}


##=========================================================================
## Name: LDASSubmit
##
## Usage: 
##  LDASSubmit [<option> <value> ...] $command [<option> <value> ...]
## options:
##    -user <user>      LDAS username
##    -manager <mgr>    LDAS manager
##                        "shorthand" forms:  "lho", "dev", "mit", etc.
##                        regular forms:  ldas-test.ligo.caltech.edu:10001,
##                             mysun:10001, mysun
##                        If port number is omitted, it is assumed to be 10001
##
## Returns with:
##   code=ok, value=<task number> if LDAS job is submitted successfully
##   code=break, value=<task number> if LDAS job has failed already
##   code=error, value=<error message> if the input arguments are poorly
##           formed, or if there is some other internal software error

proc LDASSubmit { args } {
;### MonMsg "In LDASSubmit $args"

    ;##- Assign an internal task number, and create a state array for this task
    incr ::taskCounter
    set task $::taskCounter
    upvar #0 taskState$task tstate
    set tstate(status) "init"
    set tstate(done) 0
    set tstate(cwd) $::clientDir
    set tstate(logname) $::tcl_platform(user)
    set tstate(unixHost) [info hostname]
    set tstate(unixUser) $::tcl_platform(user)
    set tstate(startTimeS) [clock seconds]
    set tstate(startTime) [clock format $tstate(startTimeS)]
    set tstate(submitArgs) $args
    register tstate

    ;##- Parse arguments
    set option ""

    foreach arg [lrange $args 0 end-1] {

	if { [regexp -- {^-\S+$} $arg] } {

	    ;##- Make sure there is not an option still needing a value
	    if { [info exists needsval] } {
		unset tstate
		return -code error \
			"Option -$needsval must be followed by a value"
	    }

	    set option [string range $arg 1 end]
	    set val ""
	} else {
	    set val $arg
	}

	;##- There should not be any positional arguments in this sublist
	if { $option == "" } {
	    unset tstate
	    return -code error \
		    "Argument value $val is not associated with any option"
	} else {

	    set tstate($option) $val
	    switch -- $option {
		"XxPlaceholder" {   ;##- These options take no argument
		    set option ""
		}

		email {
		    ;##- These options take zero or one argument
		    if { $val != "" } { set option "" }
		}

		manager - user {
		    ;##- These options take exactly one argument
		    if { $val == "" } {
			set needsval $option
		    } else {
			set option ""
			catch { unset needsval }
		    }
		}
		globus { 
        	;##- These options take exactly one argument
		    if { $val == "" } {
			set needsval $option
		    } else {
			set option ""
			catch { unset needsval }
		    }
        	set ::USE_GLOBUS_CHANNEL $val
        }
		gsi { 
        	;##- These options take exactly one argument
		    if { $val == "" } {
			set needsval $option
		    } else {
			set option ""
			catch { unset needsval }
		    }
        	set ::USE_GSI $val
        }
		default {
		    unset tstate
		    return -code error "Invalid flag -$option"
		}
	    }

	}

    }

    ;##- Make sure there is not an option still needing a value
    if { [info exists needsval] } {
	unset tstate
	return -code error "Option -$needsval must be followed by a value"
    }

    ;##- If -email was specified without a value, try to get it from the
    ;##- LDASUSER environment variable
    if { [info exists tstate(email)] && [string is space $tstate(email)] } {
	if { [info exists ::env(LDASEMAIL)] } {
	    set tstate(email) $::env(LDASEMAIL)
	} else {
	    unset tstate
	    return -code error "Email address not specified, and LDASEMAIL\
		    environment variable is not set"
	}
    }

    ;##- Perform some operations on the LDAS command (the last argument)
    regsub -all -line {\#.*} [lindex $args end] "" cmd
    regsub -all -line {^\s*$} $cmd "" cmd

    ;##- Replace all whitespace characters by true spaces, and trim
    regsub -all {\s} [string trim $cmd] " " cmd

    MonMsg "Trimmed LDAS command: $cmd"

    set tstate(command) $cmd


    ;##- At this point, we know that valid arguments were passed to this proc

    ;##- Replace instances of %FILE(...) in the LDAS command with URLs at
    ;##- which we will serve up the files
    set tstate(inputs) {}
    while { [regexp {%FILE\(([^\)]+)\)} $tstate(command) match locfile] } {

	;##- See whether this is an http URL, or a file
	if { [regexp {^http://} $locfile] } {
	    ;##- This is an http URL, so use it as it is
	    set url $locfile
	} else {
	    ;##- This is a file, which we will serve up via http

	    ;##- If necessary, prepend the working directory of the client
	    if { [file pathtype $locfile] == "relative" } {
		set locfile [file join $tstate(cwd) $locfile]
	    }

	    ;##- Make sure the file exists and is readable
	    if { ! [file readable $locfile] } {
		;##- Remove any URLs already assigned on behalf of this task
		foreach {urlbase sublist} [array get ::urlbaseToFile] {
		    if { [lindex $sublist 1] == $task } {
			unset ::urlbaseToFile($urlbase)
		    }
		}
		SeqLDAS $task cleanup \
			"File $locfile does not exist, or is not readable"
		return -code break $task
	    }

	    ;##- Make sure the file is not empty
	    if { [file size $locfile] == 0 } {
		;##- Remove any URLs already assigned on behalf of this task
		foreach {urlbase sublist} [array get ::urlbaseToFile] {
		    if { [lindex $sublist 1] == $task } {
			unset ::urlbaseToFile($urlbase)
		    }
		}
		SeqLDAS $task cleanup "File $locfile is empty"
		return -code break $task
	    }

	    ;##- Record filename in the 'inputs' element of the job info array
	    lappend tstate(inputs) $locfile

	    ;##- Assign an obscure URL to refer to this file
	    set url [AssignUrl $locfile $task]
	}

	;##- Substitute the URL back into the LDAS command text
	regsub {%FILE\(([^\)]+)\)} $tstate(command) $url tstate(command)
    }

    ;##- Figure out what LDAS username to use
    if { ! [info exists tstate(user)] } {
	;##- Username was not explicitly specified, so try to get it from
	;##- the LDASUSER environment variable.  If that isn't defined, then
	;##- we will use the default in the ~/.ldaspw file.
	if { [info exists ::env(LDASUSER)] } {
	    set tstate(user) $::env(LDASUSER)
	}
    }
    
    ;##- If using Globus, get the username from the proxy certificate
	if	{ $::USE_GLOBUS_CHANNEL } {
        if  { [ catch {
            foreach { username mode } [ getUserFromProxy ] { break }
        } errmsg ] } {
            SeqLDAS $task cleanup $errmsg
	        return -code break $task
	    }
        if	{ [ info exist tstate(user) ] } {
        	if	{ ! [ string equal ldas $mode ] } {
        		regsub -all {\s+} $tstate(user) "_" tstate(user)
        		if	{ ! [ string equal $username $tstate(user) ] } {
            		SeqLDAS $task cleanup "Your user name '$tstate(user)' does not match proxy '$username'"
					return -code break $task
                }
            }
        } else {
        	set tstate(user) $username
        }
        set tstate(password) globus
    } else {
    	
    ;##- Read the ~/.ldaspw file
    if { ! [file exists ~/.ldaspw] } {
	SeqLDAS $task cleanup "~/.ldaspw file does not exist;\
		use the 'ldaspw' utility to create it"
	return -code break $task
    }
    if { ! [file readable ~/.ldaspw] } {
	SeqLDAS $task cleanup "No permission to read your ~/.ldaspw file"
	return -code break $task
    }
    if { [catch {open ~/.ldaspw r} fid] } {
	SeqLDAS $task cleanup "Error opening your ~/.ldaspw file"
	return -code break $task
    }

    ;##- Read in the list of usernames and encoded passwords
    set userlist {}
    while { [gets $fid line] >= 0 } {
	if { [regexp {^([\w\.]+)\s+([0-9A-F]+)} $line match user encpw] } {
	    lappend userlist $user
	    ;##- The first listing is the default username
	    if { [llength $userlist] == 1 } { set defuser $user }
	    set pwlist($user) $encpw
	}
    }
    close $fid

    ;##- Check whether any username/password was found
    if { ! [info exists defuser] } {
	SeqLDAS $task cleanup \
		"Your ~/.ldaspw file does not contain any username/password"
	return -code break $task
    }

    ;##- Set the username to the default, if not already known
    if { ! [info exists tstate(user)] } { set tstate(user) $defuser }

    ;##- Make sure a password is listed for the username we are using
    if { ! [info exists pwlist($tstate(user))] } {
	SeqLDAS $task cleanup "Your ~/.ldaspw file does not contain a password\
		for user $tstate(user)"
	return -code break $task
    }

    set tstate(password) $pwlist($tstate(user))
	}
    ;##- Figure out the address of the LDAS manager to use
    if { ! [info exists tstate(manager)] \
	    || [string is space $tstate(manager)] } {
	;##- Manager was not explicitly specified, so get it from environment
	if { ! [info exists ::env(LDASMANAGER)] } {
	    SeqLDAS $task cleanup "LDAS manager not specified,\
		    and LDASMANAGER environment variable is not set"
	    return -code break $task
	}
	set tstate(manager) $::env(LDASMANAGER)
    }

    ;##- If the manager was specified in "shorthand" fashion, look up the full
    ;##- IP address and port
    #-- uwm=ldas.phys.uwm.edu
    #-- psudev=hydra.gravity.psu.edu , psu=ldas-psu.aset.psu.edu
    #-- ///////////////// WHEN UPDATING THIS LIST, ALSO UPDATE: ///////////////
    #--     www.ldas-sw.ligo.caltech.edu/ligotools/ldasjob/shorthand.txt
    if	{ $::USE_GLOBUS_CHANNEL } { 
    	switch -- [string tolower $tstate(manager)] {
		"cit" { set tstate(manager) ldas-cit.ligo.caltech.edu }
		"dev" { set tstate(manager) ldas-dev.ligo.caltech.edu }
		"test" { set tstate(manager) ldas-test.ligo.caltech.edu }
		"mit" { set tstate(manager)  ldas.mit.edu}
		"llo" { set tstate(manager) ldas.ligo-la.caltech.edu }
		"lho" { set tstate(manager) ldas.ligo-wa.caltech.edu }
    	}
    } else {

    	switch -- [string tolower $tstate(manager)] {
		"cit" { set tstate(manager) 131.215.114.9:10001 }
		"dev" { set tstate(manager) 131.215.115.248:10001 }
		"test" { set tstate(manager) 131.215.115.235:10001 }
		"mit" { set tstate(manager) 18.120.0.97:10001 }
		"llo" { set tstate(manager) 130.39.245.245:10001 }
		"lho" { set tstate(manager) 198.129.208.245:10001 }
		"uwm" { set tstate(manager) 129.89.57.100:10001 }
		"psudev" { set tstate(manager) 128.118.29.39:10001 }
		"psu" { set tstate(manager) 128.118.2.190:10001 }
    	}
	}

    ;##- Strip off the manager's port number, if explicitly specified;
    ;##- if not, assume it to be 10001
    if { ! [regexp {^(.+):(.+)$} $tstate(manager) \
	    match tstate(managerIP) tstate(managerPort)] } {
	set tstate(managerIP) $tstate(manager)
	set tstate(managerPort) 10001
	append $tstate(manager) ":$tstate(managerPort)"
    }
    if { $::USE_GLOBUS_CHANNEL } {
	    MonMsg "Using LDAS manager at $tstate(managerIP),\
	    Globus port $::globus_manager_port"
    } else {
        MonMsg "Using LDAS manager at $tstate(managerIP),\
	    port $tstate(managerPort)"
    }

    ;##- Always use MD5-based password encryption
    if	{ ! $::USE_GLOBUS_CHANNEL } {
    	set tstate(pwprotocol) "md5protocol"
    	set tstate(md5pw) [md5::md5 $tstate(password)]
    	MonMsg "Using $tstate(pwprotocol) for password encryption"
	}
    
    #-- Determine whether to use a persistent connection to the LDAS manager
    if { [info exists ::env(LJPERSISTENT)] && \
	     [string equal -nocase $::env(LJPERSISTENT) "never"] } {
	set tstate(usepersistent) 0
    } else {
	set tstate(usepersistent) 1
    }

    ;##- Determine whether to use the LDAS job proxy server.  Use it if our
    ;##- IP address indicates that we are on a private network (unless the
    ;##- LDAS manager we're connecting to is also on a private network, or has
    ;##- an unqualified host name), OR if we are at LLO (which has a firewall)
    ;##- and are connecting to an LDAS system which is not at LLO.

    set private_re {^(10\.|172\.(1[6-9]|2[0-9]|3[01])\.|192\.168\.|169\.254\.)}
    set llo_re {(130\.39\.245\.|\.ligo-la)}

    set useproxy [info exists ::env(LJPROXY)]
    if { $useproxy == 0 \
	     && [regexp {\.} $tstate(managerIP)] \
	     && ! [regexp $private_re $tstate(managerIP)] } {
	#-- Manager address includes a domain and is not on a private network
	if { [regexp $private_re $::myIP] } {
	    #-- We're on a private network
	    set useproxy 1
	} elseif { [regexp -nocase $llo_re $::myIP] \
		       && ! [regexp -nocase $llo_re $tstate(managerIP)] } {
	    #-- We're at LLO, and the LDAS manager is NOT at LLO
	    set useproxy 1
	}
    }

    #-- Note that 'usepersistent' overrides 'useproxy'

    if { ! $tstate(usepersistent) && $useproxy } {
	set tstate(connectline) \
		"connect $tstate(managerIP) $tstate(managerPort)"

	if { [info exists ::env(LJPROXY)] \
		&& [regexp {^([^:]+):(\d+)$} $::env(LJPROXY) \
		match connIP connPort] } {
	} elseif { [info exists ::env(LJPROXY)] \
		&& $::env(LJPROXY) != "default" \
		&& ! [string is space $::env(LJPROXY)] } {
	    set connIP $::env(LJPROXY)
	    set connPort 9802
	} else {
	    set connIP 131.215.115.87    ;##- mirfak.ligo.caltech.edu
	    set connPort 9802
	}

	MonMsg "Using LDAS job proxy server at $connIP, port $connPort"
	set tstate(ljproxy) "$connIP:$connPort"
    } else {
	set connIP $tstate(managerIP)
	set connPort $tstate(managerPort)
    }

    ;##- Initiate a connection to the LDAS manager's operator socket.  Do an
    ;##- asynchronous open so that we can implement our own timeout mechanism.

    if { $::USE_GLOBUS_CHANNEL } {
       if 	{ [ catch { 
            set connPort $::globus_manager_port
            set tstate(managerPort) $connPort
            MonMsg "Opening gsi connection to $connIP, $tstate(manager), port $connPort"
            set gsicmd "gt_xio_socket"
            if	{ [ info exist ::PROXY_TYPE ] && [ string length $::PROXY_TYPE ] } {
            	append gsicmd " $::PROXY_TYPE "
            }
            append gsicmd " -timeout $::TCLGLOBUS_SOCKET_TIMEOUT "
            
			if  { [ info exist ::X509_CERT_DIR ] } {
                MonMsg "::X509_CERT_DIR set to $::X509_CERT_DIR"
            }
            if	{ $::USE_GSI } {
            	append gsicmd " $::GSI_AUTH_ENABLED "
            }

            append gsicmd " $connIP $connPort "
            MonMsg "pid [ pid ] gsicmd $gsicmd, $::globusError"
            set opsock [ eval $gsicmd ]
            MonMsg "opened opsock $opsock"
          	fconfigure $opsock -buffering full -blocking 0
    	 	fconfigure $opsock -translation binary -encoding binary
            MonMsg "set up fileevent w for opsock $opsock"
			fileevent $opsock w "SeqLDAS $task opConnect $opsock"
            set tstate(opsock) $opsock
			set tstate(opTimeoutEvent) \
				[after 60000 "SeqLDAS $task opTimeout $opsock"]

			set tstate(status) "pending"
       	} err ] } {
       		set msg "Error connecting to LDAS manager $connIP : $err"
            MonMsg "msg $msg"
       	  	SeqLDAS $task cleanup $msg
    		return -code break $task
       	}       
    } else {
    	if { [ catch {
        	set opsock nosock
        	MonMsg "Opening tcl connection to $connIP, port $connPort"
        	set opsock [ socket -async $connIP $connPort ] 
            MonMsg "opened tcl connection to $connIP, port $connPort $opsock"
            set tstate(opsock) $opsock
            MonMsg "set up fileevent w for opsock $opsock"
    		fileevent $opsock w "SeqLDAS $task opConnect $opsock"
			set tstate(opTimeoutEvent) \
				[after 60000 "SeqLDAS $task opTimeout $opsock"]

			set tstate(status) "pending"
        } err ] } {
			if { [info exists tstate(ljproxy)] } {
	    		set msg "Error connecting to LDAS job proxy server at $connIP:\
		    	$opsock"
			} else {
	    		set msg "Error connecting to LDAS manager $tstate(manager):\
		    	$opsock"
			}        
			SeqLDAS $task cleanup $msg
	;##- Return with "break" code to indicate that LDAS job failed
			return -code break $task
    	}
    }
    ;##- Append this to the list of active tasks
    lappend ::activeTasks $task

    return $task
}


##=========================================================================
## Name: SeqLDAS

proc SeqLDAS { task oper args } {

MonMsg "In SeqLDAS $task $oper $args"

    ;##- Make sure this task exists
    if { ! [info exists ::taskState$task] } {
	MonMsg "  *** Task no longer exists"
	;##- Remove the fileevent, if necessary
	if { $oper == "opConnect" || $oper == "opTimeout" } {
	    set opsock [lindex $args 0]
	    MonMsg "  *** Closing $opsock"
	    fileevent $opsock w {}
	    catch { close $opsock }
	} elseif { $oper == "jobInfo" || $oper == "replyTimeout" } {
	    set opsock [lindex $args 0]
	    if { [eof $opsock] || $oper == "replyTimeout" } {
		MonMsg "  *** Closing $opsock"
		fileevent $opsock r {}
		catch { close $opsock }
	    } else {
		MonMsg "  *** Ignoring input on $opsock"
		catch { gets $opsock line }
	    }
	}
	return
    }

    ;##- Get access to the state array for this task
    upvar #0 taskState$task tstate

    ;##- Now branch depending on the operation
    switch -- $oper {

	opTimeout {
	    set msg "Timeout connecting to LDAS manager's operator socket"
	    MonMsg $msg
	    fileevent $tstate(opsock) w {}
	    ;##- The cleanup routine will close the socket, etc.
	    after 0 [list SeqLDAS $task cleanup $msg]
	}

	opConnect {
	    after cancel $tstate(opTimeoutEvent)
	    unset tstate(opTimeoutEvent)
	    set opsock $tstate(opsock)
	    fileevent $opsock w {}

	    ;##- Check for an error message
        set err ""
	    catch { set err [fconfigure $opsock -error] }
	    if { ! [string equal $err ""] } {
		set msg "Connection to LDAS manager's operator socket\
			was terminated with an error: $err"
		MonMsg $msg
		after 0 [list SeqLDAS $task cleanup $msg]
		return
	    }

	    ;##- If we are using the proxy server, send the "connect" line
	    if { [info exists tstate(connectline)] } {
		if {[catch {puts $opsock $tstate(connectline)} err]} {
		    set msg "Error sending 'connect' line to proxy server:\
			    $err"
		    MonMsg $msg
		    after 0 [list SeqLDAS $task cleanup $msg]
		    return
		}
	    }

	    ;##- Decide what email address to specify
	    if { [info exists tstate(email)] } {
		set email $tstate(email)
	    } elseif { $tstate(usepersistent) } {
		set email "persistent_socket"
	    } else {
		set email "!host!:$::replyPort"
	    }

	    ;##- Construct the full LDAS user command
	    if { [info exists tstate(pwprotocol)] } {
		set ldascmd [list ldasJob \
			[list -name $tstate(user) \
			-password $tstate(pwprotocol) -email $email] \
			$tstate(command) ]
	    } else {
		set ldascmd [list ldasJob \
			[list -name $tstate(user) \
			-password $tstate(password) -email $email] \
			$tstate(command) ]
	    }

	    ;##- Send the LDAS command to the manager
	    if {[catch {puts $opsock $ldascmd; flush $opsock} err] } {
		set msg "Error sending LDAS command to LDAS manager: $err"
		MonMsg $msg
		after 0 [list SeqLDAS $task cleanup $msg]
		return
	    }

	    MonMsg "LDAS job is pending for LDASJobH task $task"

	    ;##- Set up a fileevent routine to handle data on this
	    ;##- socket (should be the manager telling us the LDAS job name).
	    ;##- Include socket ID in call, so we can close the socket if the
	    ;##- task no longer exists.
	    fconfigure $opsock -blocking 0
	    fileevent $opsock r "SeqLDAS $task jobInfo $opsock"
	    set tstate(jobInfo) "unknown"
	    set tstate(infoBuf) ""

	    ;##- Set up a timeout
	    set tstate(replyTimeoutEvent) \
		    [after $::MANAGER_REPLY_TIMEOUT "SeqLDAS $task replyTimeout $opsock"]
	}

	replyTimeout {
	    unset tstate(replyTimeoutEvent)
	    set msg "Timeout waiting after [ expr $::MANAGER_REPLY_TIMEOUT/1000 ] secs for LDAS manager to return job info"
	    MonMsg $msg
	    fileevent $tstate(opsock) r {}
	    ;##- The cleanup routine will close the socket
	    after 0 [list SeqLDAS $task cleanup $msg]
	}

	jobInfo {
	    set opsock $tstate(opsock)

	    set close 0
	    if { [eof $opsock] } {
		set close 1
	    } elseif { [catch {gets $opsock line} nchars] } {
		MonMsg "Error reading line from operator $opsock"
		set close 1
	    }

	    if { $close } {

		;##- Close this socket
		catch { close $opsock }
		set tstate(opsock) ""

###		MonMsg "*** Connection closed, infoBuf is:\n$tstate(infoBuf)"

		if { [info exists tstate(replyTimeoutEvent)] } {
		    ;##- Cancel the pending timeout event
		    after cancel $tstate(replyTimeoutEvent)
		    unset tstate(replyTimeoutEvent)
		}

		if { [regexp {\+\+\+\+\+\+ RESULT \S+?\n(.+?)\n\+\+\+\+\+\+} \
			$tstate(infoBuf) match resultinfo] } {
		    #-- This is a job-done message on a proxied connection
		    set tstate(jobReply) $resultinfo
		    after 0 "SeqLDAS $task jobReply"

		} elseif { [regexp {^\s*Subject:} $tstate(infoBuf)] } {
		    #-- This is a job-done message on a persistent connection
		    set tstate(jobReply) [string trimleft $tstate(infoBuf)]
		    after 0 "SeqLDAS $task jobReply"

		} elseif { [info exists tstate(jobid)] } {
		    #-- Job successfully launched, transient connection closed

		    ;##- Check whether the job has already finished!
		    set jobid $tstate(jobid)
		    if { [info exists ::oddJobBuf($jobid)] } {
			MonMsg "Job is already done!  Getting job info"
			set tstate(jobReply) $::oddJobBuf($jobid)
			unset ::oddJobBuf($jobid)
			after 0 "SeqLDAS $task jobReply"
			return
		    }

		    ;##- Now return.  When LDAS notifies us that the job
		    ;##- has finished, the ReplyInput routine will put the
		    ;##- reply message into tstate(jobReply) and then set
		    ;##- up an event to call "SeqLDAS $task jobReply"
		    return

		} else {
		    set msg "The job was not accepted by the LDAS manager. \
                            $tstate(infoBuf)"
		    ;##- Get rid of newlines, and escape braces
		    regsub -all "\n" $msg " " msg
		    regsub -all {[{}]} $msg {\\&} msg
		    MonMsg "Job submission failed: $msg"
		    after 0 [list SeqLDAS $task cleanup $msg]
		    return
		}

	    } else {

###		MonMsg "  Got $line"

		;##- Check whether LDAS has sent us an MD5 "salt" to use
		if { [regexp {^md5salt ([^\}\s]+)} $line match md5salt] } {

		    ;##- Append the "salt" (specified by LDAS) to the MD5 hash
		    ;##- of the actual password, calculate the MD5 digest, and
		    ;##- send it back to LDAS
		    set md5data "$tstate(md5pw)$md5salt"
		    set md5digest [md5::md5 $md5data]
		    puts $opsock [list "md5digest" $md5digest]
		    flush $opsock
###		    MonMsg "  Put [list md5digest $md5digest]"

###		    proc Heartbeat {} {
###			MonMsg ""
###			after 100 Heartbeat
###		    }
###		    Heartbeat

		    return
		}

		if { ! [regexp {^\+\+\+\+\+\+ END} $line] } {
		    append tstate(infoBuf) $line "\n"
		}

		set gotJobInfo 0

		if { [string match {*+} $line] \
			&& [regexp {\+\+\+\+\+\+ INFO\n(.+?)\n\+\+\+\+\+\+} \
			$tstate(infoBuf) match jobinfo] } {

		    #-- This is a job-info message on a proxied connection
		    set tstate(jobInfo) [string trimleft $jobinfo]
		    MonMsg "jobInfo is:\n$tstate(jobInfo)"
		    set gotJobInfo 1

		    #-- Delete this section, since we've now used it
		    regsub {\+\+\+\+\+\+ INFO\n(.+?)\n\+\+\+\+\+\+} \
			    $tstate(infoBuf) {} tstate(infoBuf)

		} elseif { [regexp \
			     {^\s*\{[^\}]*Your job is running as: [^\}]*\}\s*}\
				$tstate(infoBuf)] } {

		    #-- This is a complete job-info message
		    set tstate(jobInfo) [string trimleft $tstate(infoBuf)]
		    MonMsg "jobInfo is:\n$tstate(jobInfo)"
		    set gotJobInfo 1

		    #-- Reset buffer
		    set tstate(infoBuf) ""

		}

		#-- If we got a job-info message, parse it, etc.
		if $gotJobInfo {

		    #-- Cancel the pending timeout event, if any
		    if { [info exists tstate(replyTimeoutEvent)] } {
			after cancel $tstate(replyTimeoutEvent)
			unset tstate(replyTimeoutEvent)
		    }

		    #-- Try to determine the job ID
		    if { [regexp {Your job is running as: *"([^\"\n]*)"} \
			      $tstate(jobInfo) match tstate(jobid)]} {
			MonMsg "LDASJobH task $task is LDAS job $tstate(jobid)"
			#-- Fill numeric job number too
			regexp {\d+$} $tstate(jobid) tstate(jobnum)
		    } else {
			MonMsg "Unable to determine job ID from\
                                job-info message: $tstate(jobInfo)"
			set tstate(jobid) "unknown"
		    }

		    #-- Try to determine the LDAS version
		    if { ! [regexp {running LDAS version ([0-9\.]+)} \
				$tstate(jobInfo) match tstate(LDASVersion)] } {
			MonMsg "Unable to determine LDAS version from\
                                job-info message: $tstate(jobInfo)"
			set tstate(LDASVersion) unknown
		    }

		    set tstate(status) "submitted"

		    ;##- If a "submitted" callback was registered,
		    ;##-  execute it now
		    if { [info exists tstate(callback)] \
			     && $tstate(callback_when) == "submitted" } {
			MonMsg "Executing 'submitted' callback"
			StateCallback $task
		    }

		    ;##- If an email address was specified, then we are
		    ;##- done tracking this job, as far as we are concerned.
            
            ;## 2/28/06 mlei put in check for persistent socket and not close
            ;## esp if -nowait option is used.
		    if { [info exists tstate(email)] && ! [ string match persistent_socket [ set tstate(email) ] ] } {
			after 0 [list SeqLDAS $task cleanup]
			return
		    }

		    set ::ldasJobList($tstate(jobid)) $task

		    ;##- Set up a (long) timeout for the job
		    set tstate(jobTimeoutEvent) \
			[after [expr 6*3600000] "SeqLDAS $task jobTimeout"]

		}
		#-- End of block if we got a job-info message

	    }

	}

	jobTimeout {
	    unset tstate(jobTimeoutEvent)
	    set msg "Timeout waiting for LDAS job to finish"
	    MonMsg $msg
	    after 0 [list SeqLDAS $task cleanup $msg]
	}

	jobReply {
	    after cancel $tstate(jobTimeoutEvent)
	    unset tstate(jobTimeoutEvent)

	    MonMsg "jobReply is:\n$tstate(jobReply)"

	    #-- DON'T strip out tags...it was stripping out part of the
	    #-- interesting information in job reply messages
	    ##;##- Strip out html tags from reply message
	    ##regsub -all {<.*?>} $tstate(jobReply) {} jobout
	    set jobout $tstate(jobReply)

	    set tstate(outputDir) ""
	    set tstate(outputs) {}

	    ;##- Parse any outputs in the reply message from the LDAS manager
	    foreach block [regexp -all -inline \
			       {Your results:\s+?\S.*?\n *\n} $jobout] {

		#-- Get the filenames and/or path
		if { [regexp \
			{Your results:\s+(\S.+\S)\s+can be found at:\s+(\S+)} \
			$block match files path] } {
		} elseif { [regexp \
			{Your results:\s+(\S.+\S)} $block match files] } {
		    set path ""
		} else {
		    set path ""
		    set files {}
		}

		;##- Convert ftp path to an http path if necessary
		regsub {^ftp://([^/]+)/(:?ldas_outgoing/(:?jobs/)?)?} $path \
			{http://\1/ldas_outgoing/jobs/} path

		;##- If URL specifies a private IP address while we connected
		;##- via a public IP address, or vice versa, then modify the
		;##- URL so that we access it the way we connected
		if { [regexp {^http://([^/]+)/(.*)ldas_outgoing(.*)$} $path \
			  match urlIP urlpathhead rest] } {

		    #-- Get the IP address we used to connect to the manager
		    if { [info exists tstate(connectline)] } {
			regexp {connect (\S+) } $tstate(connectline) \
				match mgrIP
		    } else {
			set mgrIP $tstate(managerIP)
		    }

		    set private_re \
		       {^(10\.|172\.(1[6-9]|2[0-9]|3[01])\.|192\.168|169\.254)}
		    set urlPrivate [regexp $private_re $urlIP]
		    set mgrPrivate [regexp $private_re $mgrIP]
		    set myPrivate [regexp $private_re $::myIP]
		    set mgrSingle [expr {1-[regexp {\.} $mgrIP]}]
		    if { ($urlPrivate && ! $mgrPrivate) || \
			     (! $urlPrivate && \
			       ($mgrPrivate || ($myPrivate && $mgrSingle))) } {
			set path "http://$mgrIP/ldas_outgoing$rest"
			MonMsg "Revised URL path to be $path"
		    }
		}

		if { $tstate(outputDir) == "" } {
		    set tstate(outputDir) $path
		}

		foreach file $files {

		    ;##- If it's a complete ftp URL, convert it to an http URL
		    regsub {^ftp://([^/]+)/(:?ldas_outgoing/(:?jobs/)?)?} \
			    $file {http://\1/ldas_outgoing/jobs/} file

		    #-- If it's a relative filename, prepend the path
		    if { [regexp {^(http|ftp|gridftp|file):} $file] \
			    || [file pathtype $file] == "absolute" } {
			lappend tstate(outputs) $file
		    } else {
			lappend tstate(outputs) $path/$file
		    }

		    #-- Fill in outputDir if necessary
		    if { $tstate(outputDir) == "" } {
			regexp {^(.+)/[^/]+$} $file match tstate(outputDir)
		    }
		}
	    }

	    if { [regexp {look\s+for\s+your\s+results\s+here:\s+(http://\S+)} \
		    $jobout match urldir] } {
		set usedir $urldir
		set tstate(outputDir) $usedir
		set tstate(outputs) {}

		;##- At present, LDAS does not wait for all outputs to be
		;##- written before telling us that the job is done!  As a
		;##- crude hack, sleep here for a little while before
		;##- reading the contents of the directory.
		MonMsg "Sleeping to hopefully allow asynchronous job output\
			to be written completely"
		after 10000

		MonMsg "Looking for list of output files at $urldir"

		;##- We may need to loop, if there is URL redirection
		while { 1 } {

		    ;##- Read the contents of the directory to get a list of
		    ;##- output files
		    set httpvar ""
		    if { [catch \
			    {http::geturl $usedir -timeout 10000} httpvar] } {
			break
		    }

		    upvar #0 $httpvar httpstate
		    if { $httpstate(status) != "ok" } { break }

		    regexp {^(\S+) (\S+) (.+)$} $httpstate(http) \
			    match httpver statcode stattext
		    if { [string match "2*" $statcode] } {
			;##- We got the file successfully
###			MonMsg "httpstate(body) is $httpstate(body)"
			foreach {match url} [regexp -nocase -all -inline \
				{<a *href="(\w[^/\"]+)">} $httpstate(body)] {
			    lappend tstate(outputs) "$urldir/$url"
			}
			break
		    } elseif { [string match "4*" $statcode] } {
			;##- Error reading directory
			MonMsg "Got error code $statcode when reading\
				directory where outputs should be!  Bailing..."
			break
		    }

		    ;##- Parse the "meta" array, if it exists
		    if { [info exists httpstate(meta)] } {
			array set httpmeta $httpstate(meta)
		    } else {
			set httpmeta(null) ""
		    }

		    if { [string match "3*" $statcode] && \
			    [info exists httpmeta(Location)] } {
###			MonMsg "redirecting to $httpmeta(Location)"
			set usedir $httpmeta(Location)
			set tstate(outputDir) $usedir
			catch { http::cleanup $httpvar }
			continue   ;##- Go back and read from the revised URL
		    } else {
			MonMsg "Unable to handle http status = $statcode,
				meta = $httpstate(meta).  Bailing..."
			break
		    }

		} ;##- End of 'while' loop

		if { $httpvar != "" } {
		    catch { http::cleanup $httpvar }
		}
	    }

	    set tstate(error) ""

	    ;##- Determine whether the job succeeded or failed by
	    ;##- looking for "error" anywhere in the subject line,
	    ;##- or "ERROR" in the timing summary, or "API shutting down"
	    ;##- anywhere in the message
	    set subjline ""
	    regexp {^\*Subject:\s+(\S[^\n]*)\n} $jobout match subjline
	    if { [regexp -nocase {error} $subjline] || \
		    [regexp {CLOCK TIME.+?={36,}.+?ERROR.+?={36,}} $jobout] \
		    || [regexp {API shutting down} $jobout] } {
		set tstate(status) "error"
		set tstate(error) $jobout

		#-- Try to pick out just the error message
		if { [regsub -nocase \
			{^\*Subject:\s+[A-Z\-_]+[0-9]+ +error!?\s+} \
			$tstate(error) {} tstate(error) ] } {
		    #-- Stripped off "Subject:", job ID and "error"
		} elseif { [regsub -nocase \
			{^\*Subject:\s+error!? +([A-Z\-_]+[0-9]+)?\s*} \
			$tstate(error) {} tstate(error) ] } {
		    #-- Stripped off "Subject:", "error", and possibly job ID
		} else {
		    #-- Strip off "Subject:" only
		    regsub {^\*Subject:\s+} $tstate(error) {} tstate(error)
		}

		#-- Strip away time information
		regsub -nocase \
			{\s*={20,} *\n'?LDAS API[^\n]+CLOCK TIME.+={20,}} \
			$tstate(error) {} tstate(error)

	    } else {
		#-- It seems that the job succeeded
	    }

	    ;##- Initialize times to zero for each api
	    foreach api [list frame metadata ligolw datacond mpi eventmon] {
		set tstate(${api}Time) 0.0
	    }

	    ;##- Check for messages about rows inserted into database
	    foreach {line rows dbname table} [regexp -all -inline -line \
		    {^Inserted (\d+) rows into (\S+) database table (\S+)$} \
		    $jobout] {
		set tstate(dbname:$table) $dbname
		set tstate(rows:$table) $rows
	    }

	    ;##- Parse the "timing summary" section
	    set pat {^====[^\n]+\n[^\n]+CLOCK TIME[^\n]+\n}
	    append pat {====[^\n]+\n[^=]+\n====[^\n]+}
	    if { [regexp -lineanchor $pat $jobout tsummary] } {
		if { [regexp {managerAPI\(total\):[ \t]+([0-9\.]+)} $tsummary \
			match time] } {
		    set tstate(jobTime) $time
		}
		foreach line [split $tsummary "\n"] {
		    if { [regexp {^(.+)API:[ \t]+([0-9\.]+)(.*)$} $line \
			    match api time notes] } {			    
			if { [info exists tstate(${api}Time)] } {
			    set oldtime $tstate(${api}Time)
			    set tstate(${api}Time) [expr {$oldtime+$time}]
			} else {
			    set tstate(${api}Time) $time
			}
			if { [regexp -nocase {error} $notes] } {
			    set tstate(errorAPI) $api
			}
		    }
		}
	    }

	    after 0 "SeqLDAS $task cleanup"
	}

	cleanup {
	    ;##- Get the error message (if any)
	    if { [llength $args] > 0 && ! [string is space [lindex $args 0]]} {
		set errmsg [lindex $args 0]
		set tstate(error) $errmsg
		set tstate(status) "error"
		if	{ [ info exist ::globusError ] } {
			append errmsg "\n$::globusError"
		}
		MonMsg "Error message passed to SeqLDAS cleanup:\n$errmsg"
	    }

	    ;##- If there is no error message, set array element to blank
	    if { ! [info exists tstate(error)] } { set tstate(error) "" }

	    ;##- Close the socket connection to LDAS, if necessary
	    if { [info exists tstate(opsock)] && $tstate(opsock) != "" } {
		catch { close $tstate(opsock) }
        MonMsg "closed opsock $tstate(opsock)"
		set tstate(opsock) ""
	    }

	    ;##- Cancel any pending timeout event
	    foreach event {opTimeoutEvent replyTimeoutEvent jobTimeoutEvent} {
		if { [info exists tstate($event)] } {
		    after cancel $tstate($event)
		    unset tstate($event)
		}
	    }

	    set tstate(done) 1

	    ;##- Remove this from the list of active tasks
	    set index [lsearch -exact $::activeTasks $task]
	    set ::activeTasks [lreplace $::activeTasks $index $index]

	    ;##- Most of the rest of the code should be skipped if running a
	    ;##- "background" job (with notification via email)
	    if { ! [info exists tstate(email)] } {

		;##- Update elements of the state array for this task
		if { $tstate(status) != "error" } {
		    set tstate(status) "done"
		}
		;##- Record the job end time (according to this computer)
		set tstate(endTimeS) [clock seconds]
		set tstate(endTime) [clock format $tstate(endTimeS)]

		;##- Delete this job's entry in ::ldasJobList
		if { [info exists tstate(jobid)] } {
		    set jobid $tstate(jobid)
		    if { [info exists ::ldasJobList($jobid)] } {
			unset ::ldasJobList($jobid)
		    }
		}

		;##- Remove any URLs assigned on behalf of this task
		foreach {urlbase sublist} [array get ::urlbaseToFile] {
		    if { [lindex $sublist 1] == $task } {
			unset ::urlbaseToFile($urlbase)
		    }
		}

	    }

	    ;##- If there is a "submitted" callback in place, and LDAS rejected
	    ;##- the job for some transient reason (too soon after previous
	    ;##- submission, queue is currently full, etc.), then set up to
	    ;##- resubmit the job automatically after an appropriate delay
	    if { $tstate(status) == "error" && [info exists tstate(callback)] \
		    && $tstate(callback_when) == "submitted" } {

		set errmsg $tstate(error)

		catch {unset waitsecs}

		;##- Check for a "transient" error
		if { [regexp {wait at least \d+ seconds between LDAS system} \
				$errmsg] && \
			[regexp {Try again in (\d+) seconds} $errmsg \
				match waitsecs] } {
		    ;#-- No-op, since waitsecs has been set appropriately
		} elseif { [regexp \
			{system has a limited queue size .+ Please retry} \
			$errmsg] } {
		    set waitsecs 15
		} elseif { [regexp \
			{md5Challenge: expected: 'md5digest', received ''} \
			$errmsg] } {
		    ;##- md5digest timing glitch
		    set waitsecs 5
		} elseif { [regexp \
			{^The job was not accepted by the LDAS manager.\s*$} \
			$errmsg] } {
		    ;##- No error message reported...try again
		    set waitsecs 5
		}

		if { [info exists waitsecs] } {
		    set jobtag $::taskToJobtag($task)

		    ;##- Set up an event to resubmit, UNLESS we've reached the
		    ;##- limit on the number of retries
		    if { $::jobtagRetries($jobtag) > 5 } {
			append tstate(error) \
				" (after $::jobtagRetries($jobtag) retries)"
		    } else {
			;##- If we've already retried a few times, increase
			;##- the time delay by some factor
			if { $::jobtagRetries($jobtag) > 3 } {
			    set waitsecs [expr {20*$waitsecs}]
			} elseif { $::jobtagRetries($jobtag) > 1 } {
			    set waitsecs [expr {4*$waitsecs}]
			}

			MonMsg "Will resubmit job after $waitsecs seconds"
			after 0 "ClientCommand delete $jobtag"
			after ${waitsecs}000 \
				[list Resubmit $jobtag $tstate(submitArgs)]
			return
		    }
		}
	    }

	    ;##- If an error occurred, and a callback of any type was
	    ;##- set up, do it now.
	    if { [info exists tstate(callback)] && $tstate(status)=="error" } {
		MonMsg "Executing callback now since there was an error"
		StateCallback $task
		;##- (StateCallback clears the callback)
	    }

	    ;##- If this job has already been "deleted" by the client,
	    ;##- go ahead and delete the state array.  Otherwise, evaluate
	    ;##- the callback (if any)

	    if { [info exists tstate(deleted)] } {
		MonMsg "Deleting state array for task $task"
		unset tstate
		unset ::taskToJobtag($task)

	    } elseif { [info exists tstate(callback)] \
		    && $tstate(callback_when) == "done" } {
		MonMsg "Executing 'done' callback"
		StateCallback $task
	    }

	    ;##- Check whether we can shut down now
	    ShutdownCheck
	}

	default {
	    set errmsg "Error in SeqLDAS: unknown operation $oper"
	    MonMsg $errmsg
	    return -code error $errmsg
	}

    }

    return
}


##=========================================================================
## Name: ReplyConnect
##
## Description:
##   Proc associated with the reply socket, to handle a socket connection.
## 
## Parameters:
##   sock -- socket identifier set up
##   addr -- IP address of managerAPI
##   port -- Port number for connection
##
## Usage:
##   ReplyConnect sock addr port
##
## Comments:
##   Sets up a callback to ReplyInput to handle data arriving on the socket.

proc ReplyConnect { sock addr port } {

    MonMsg "ReplyConnect: accepted $sock from [fconfigure $sock -sockname]"

    fconfigure $sock -buffering line -blocking 0
    fileevent $sock readable "ReplyInput $sock"

    return
}


##=========================================================================
## Name: ReplyInput
##
## Description:
##   Routine to handle messages arriving over a reply connection.
## 
## Parameters:
##   sock -- socket over which message arrived
##
## Usage:
##   ReplyInput sock
##
## Comments:
##   Must be able to keep track of multiple connections, whose messages
##   might be intermingled.

proc ReplyInput { sock } {
###    MonMsg "In ReplyInput $sock"

    set close 0

    if { [eof $sock] } {
	MonMsg "Reached EOF on reply $sock"
	set close 1
    } elseif { [catch {gets $sock line} nchars] } {
	MonMsg "Error reading line from reply $sock: $nchars"
	set close 1
    }

    ;##- If the socket data is complete, do something with it
    if { $close == 1 } {

	catch { close $sock }

	;##- There should be a subject message
	if { [ regexp {^\s*Subject:\s} $::replySockBuf($sock) ] } {

	    #-- Pick out the job ID, wherever it is in the subject message
	    if { ! [regexp {^\s*?Subject:.*?([A-Z\-_]+[0-9]+)[^0-9]} \
		    $::replySockBuf($sock) match jobid ] } {
		MonMsg "Unable to determine job ID from\
                        reply:\n$::replySockBuf($sock)"
		#-- Ignore this message
		unset ::replySockBuf($sock)
		return
	    }

	    if { [info exists ::ldasJobList($jobid)] } {

		;##- Look up the task ID
		set task $::ldasJobList($jobid)
		;##- Get access to the state array for this task
		upvar #0 taskState$task tstate

		;##- Set the jobReply element of the state array
		set tstate(jobReply) $::replySockBuf($sock)

		;##- Add to the event queue a call to continue the sequence
		;##- for this task.
		after 0 "SeqLDAS $task jobReply"

	    } else {
		;##- This LDAS job id is unknown to us.  Maybe we have not yet
		;##- gotten the "your job is running as..." message about it!
		;##- Cache it for future use.
		MonMsg "Caching reply message for job $jobid"
		set ::oddJobBuf($jobid) $::replySockBuf($sock)

	    }
	} else {
	    ;##- Ignore this input
	    MonMsg "Ignoring spurious reply message:\n$::replySockBuf($sock)"
	}

	unset ::replySockBuf($sock)

    } else {

###	MonMsg "On reply $sock, received $line"

	if { [info exists ::replySockBuf($sock)] } {
	    append ::replySockBuf($sock) "$line\n"
	} else {
	    set ::replySockBuf($sock) "$line\n"
	}

    }

    return
}


##=========================================================================
## Name: AssignUrl
##

proc AssignUrl { file task } {

    set urlbase "[clock clicks]/[file tail $file]"
    set ::urlbaseToFile($urlbase) [list $file $task]
    set url "http://${::myIP}:$::httpPort/$urlbase"
    MonMsg "Assigning $file to $url"

    return $url
}


##=========================================================================
## Name: HttpConnect
##
## Description:
##   Proc associated with the http socket, to handle a socket connection.
## 
## Parameters:
##   sock -- socket identifier set up
##   addr -- IP address
##   port -- Port number for connection
##
## Usage:
##   HttpConnect sock addr port
##
## Comments:
##   Sets up a callback to HttpInput to handle data arriving on the socket.

proc HttpConnect { sock addr port } {
    MonMsg "http connect from $addr, port $port"

    ;##- Create a state array for this socket connection
    upvar #0 webState$sock wstate
    set wstate(input) ""
    set wstate(reqtype) ""

    ;##- Configure this socket
    fconfigure $sock -buffersize 65536 -buffering full -blocking 0 \
	    -translation {auto binary}

    ;##- Set up a fileevent to handle input on this socket
    fileevent $sock readable "HttpInput $sock"

    return
}


##=========================================================================
## Name: HttpInput
##
## Description:
##   Routine to handle messages arriving over a http connection.
## 
## Parameters:
##   sock -- socket over which message arrived
##
## Usage:
##   HttpInput sock
##
## Comments:
##   .

proc HttpInput { sock } {

    ;##- Get access to the state array for this socket
    if { ! [info exists ::webState$sock] } {
	MonMsg "In HttpInput, ::webState$sock no longer exists; closing $sock"
	fileevent $sock readable {}
	catch { close $sock }
	return
    }
    upvar #0 webState$sock wstate

    set close 0

    if { [eof $sock] } {
	set close 1
    } elseif { [catch {gets $sock line} nchars] } {
	MonMsg "http $sock read error: $nchars"
	set close 1
    }

    ;##- If the socket is closed by the client, clean up
    if { $close == 1 } {
	;##- Close input file, close socket, delete state array
	CopyDone $sock cancel
	return
    }

    ;##- If we get to this point, then we successfully read a line

    ;##- If we're already transferrring a file, ignore any additional input
    if { [info exists wstate(transferring)] } { return }

    ;##- Handle the input
    if { [regexp {^(GET|HEAD)\s+(\S+)\s} $line match reqtype request] } {
	set wstate(reqtype) $reqtype
	set wstate(request) $request
    }

    ;##- Request is complete when we receive a blank line
    if { ! [string is space $line] } { return }

###    MonMsg "http request is $wstate(request)"

    ;##- If we get to this point, then we have the complete request
    if { ! [info exists wstate(request)] } {
	MonMsg "http $sock did not get a valid request"
	CopyDone $sock cancel
	return
    }

    set request $wstate(request)

    ;##- Set a flag to indicate that we received a complete request; this
    ;##- causes any further input on this socket to be ignored
    set wstate(transferring) 1

    ;##- Trim off any leading or trailing slashes
    set request [string trim $request {/}]

    ;##- Collapse any repeated slashes
    regsub {/+} $request {/} request

    #hack
    ;##- If the request is blank, just send a friendly "home page" message
    if { [string is space $request] } {
	set hostname [info hostname]
	set body ""
	append body {<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.2//EN"} \n \
		"<html><head><title>" \
		"LDASJobH at $hostname</title></head>\n" \
		"<body><h1>LDASJobH at $hostname</h1>\n"

###	append body "<h4><a href=\"info\">Information page</a><h4>\n"

	append body "</body></html>\n"

	HttpSend $sock -type text/html -body $body
	return
    }

    ;##- Politely tell robots to keep away!
    if { [string equal -nocase $request "robots.txt"] } {
	HttpSend $sock -type text/plain -body "User-agent: *\nDisallow: /\n"
	return
    }

    ;##- Check for valid requests here
    if { [info exists ::urlbaseToFile($request)] } {
	set locfile [lindex $::urlbaseToFile($request) 0]
	;##- Only allow file to be accessed once!
	unset ::urlbaseToFile($request)
	;##- Figure out what MIME type to use
	switch -- [file extension $locfile] {
	    ".html" - ".htm" - ".shtml" { set type "text/html" }
	    ".txt" - ".log" { set type "text/plain" }
	    default { set type "application/binary" }
	}
	HttpSend $sock -type $type -file $locfile
	return
    }

    ;##- If we get to this point, then request is invalid

    MonMsg "Invalid URL"
    HttpSend $sock -code 404 -type text/html -body \
	    "<html><head><title>Invalid request</title></head>\
	    <body>Invalid request</body></html>"

    return
}


##=========================================================================
## Name: HttpSend
##
## Required argument:
##   sock
## Optional flags:
##   -code <code>        default: "200 OK"
##   -type <type>        default: text/plain
##   -body <text>
##   -file <filename>
##   -reqtype <reqtype>  default: "GET"
## You should specify EITHER '-body' OR '-file'

proc HttpSend { sock args } {

    ;##- Set defaults
    set code "200 OK"
    set type "text/plain"
    set body ""
    set file ""
    set reqtype "GET"

    ;##- Parse arguments
    set var ""
    foreach arg $args {
	if { [string match -* $arg] } {
	    ;##- This is a flag -- get the variable name
	    set var [string range $arg 1 end]
	} else {
	    ;##- Set the appropriate variable, after checking that it exists
	    if { [info exists $var] } {
		set $var $arg
	    }
	}
    }

    ;##- Tweak code/message into standard form, if necessary
    switch -glob -- $code {
	404* { set code "404 Not Found" }
    }

    ;##- If a filename was specified, check that it exists and look up its size
    if { $file != "" } {
	if { ! [file exists $file] || [file isdirectory $file] \
		|| [catch {file size $file} filesize] } {
	    MonMsg "http requested file $file not found"
	    set code "404 Not Found"
	    set file ""
	    set type text/html
	    set body "<html><head><title>File not found</title></head>\
		    <body>File not found</body></html>"
	}
    }

    ;##- Send the HTTP header
    catch {
	puts $sock "HTTP/1.0 $code"
	puts $sock "Server: LDASJobH/$::patchVersion"
	puts $sock "Content-Type: $type"
	if {$file != ""} { puts $sock "Content-Length: $filesize" }
	puts $sock ""
    }

    ;##- Now send the document contents, or just close (if the request type
    ;##- was "HEAD"), or start copying the file in the background
    if { $file == "" || $reqtype == "" } {
	catch { puts -nonewline $sock $body }
	CopyDone $sock 0
	return ""
    } elseif { [string tolower $reqtype] == "head" } {
	CopyDone $sock 0
	return ""
    } else {
	set fid [open $file r]
	fconfigure $fid -buffersize 65536 -translation binary
	fcopy $fid $sock -command [list CopyDone $sock]

	;##- Get access to the state array for this socket
	if { ! [info exists ::webState$sock] } { return }
	upvar #0 webState$sock wstate
	set wstate(file) $file
	set wstate(fid) $fid

	return $fid
    }
}


##=========================================================================
## Name: CopyDone
##

proc CopyDone { sock bytes {error ""} } {

    ;##- Get access to the state array for this socket
    if { ! [info exists ::webState$sock] } {
	catch { close $sock }
	return
    }
    upvar #0 webState$sock wstate

    if { $bytes == "cancel" } {
	MonMsg "http $sock transfer canceled by client"
    } elseif { $error != "" } {
	MonMsg "http $sock error during transfer: $error"
    } elseif { $bytes > 0 } {
	MonMsg "http $sock finished sending $wstate(file)\
		at [clock format [clock seconds]]"
    }

    ;##- Close the file and the socket connection
    if { [info exists wstate(fid)] } {
	close $wstate(fid)
	unset wstate(fid)
    }

    catch { close $sock }

    ;##- Delete the state array for the socket
    unset ::webState$sock

    return
}


##=========================================================================
## Name: ShutdownCheck

proc ShutdownCheck {} {

    ;##- If stdin is still open, we can't shut down
    if { [llength [file channels stdin]] > 0 } { return }

# Allow shutdown even if there are active tasks; "SeqLDAS cleanup" will be
# called for each one prior to actually shutting down
###    if { [llength $::activeTasks] > 0 } { return }

    ;##- If there are any files still waiting to be sent to LDAS, then
    ;##- do not shut down yet.  But schedule a callback to this routine
    ;##- for later, in case LDAS never connects.
    if { [llength [array names ::urlbaseToFile]] > 0 } {
	;##- The first time we get here, choose a future time for timeout
	if { ! [info exists ::shutdownTimeout] } {
	    set ::shutdownTimeout [expr {[clock seconds] + 300}]
	    after 300000 ShutdownCheck
	    MonMsg "Deferring shutdown until after LDAS gets all http files"
	    return
	}
	;##- On subsequent times, check the current time against the timeout
	if { [clock seconds] < $::shutdownTimeout } { return }
    }

    ;##- OK, now we know we can shut down
    set ::SHUTDOWN "idle"

    return
}


##=========================================================================
## Name: ShutDown
##
## Description:
##   Gracefully shut down
## 
## Parameters:
##   reason -- reason for shutting down
##
## Usage:
##   ShutDown reason
##
## Comments:
##   .

proc ShutDown { reason } {

    ;##- Close listening sockets
    MonMsg "Closing listening sockets"
    catch { close $::replySock }
    catch { close $::httpSock }

    ;##- Cleanup any tasks which are currently running
    foreach task $::activeTasks {
	SeqLDAS $task cleanup
    }

    if { [info exists ::whenShutdown] } {
	eval $::whenShutdown
    }

    MonMsg "Shutting down at [clock format [clock seconds]], reason: $reason"

    ;##- Close log file
    if { [info exists ::logChan] && $::logChan != "null" } {
	catch {
	    close $::logChan
	    #-- Rename the file to indicate that it finished
	    regsub {running\.log} $::logFile "done_[clock seconds].log" newname
	    file rename $::logFile $newname
	}
    }

    exit
}


##=========================================================================
## Name: LogHeartbeat
##

proc LogHeartbeat {} {

    ;##- Write a line to the log file
    MonMsg "LDASJobH is still running at [clock format [clock seconds]]"

    ;##- Re-schedule this routine
    after 3600000 LogHeartbeat

    return
}


##=========================================================================
## Name: MonMsg
##
## Description:
##   Add a monitoring message
## 
## Parameters:
##   msg -- message to add
##
## Usage:
##   MonMsg msg
##
## Comments:
##   .

proc MonMsg { msg } {

    #-- For now, at least, write to a log file
    ;##- If necessary, open the log file
    if { ! [info exists ::logChan] } {

	;##- First, delete "done" log files that are old
	set curtime [clock seconds]
	set origdir [pwd]
	cd $::baseDir
	set filelist [glob -nocomplain "LDASJobH_*.log"]
	set donefile 0
	set runfile 0
	foreach file [lsort -dictionary -decreasing $filelist ] {

	    if { [regexp {_done_([\-\d]+)\.log$} $file match donetime] } {

		;##- Always keep the 3 most recent "done" files
		incr donefile
		if { $donefile <= 3 } continue

		;##- Delete the file if it finished more than an hour ago
		if { $curtime-$donetime > 3600 } {
		    catch { file delete $file }
		}

	    } elseif { [regexp {_running\.log} $file] } {
		
		;##- Always keep the 3 most recent "running" files
		incr runfile
		if { $runfile <= 3 } continue

		;##- Delete the file if it has not been updated in over a day
		if { [catch {file mtime $file} modtime] } continue
		if { $curtime-$modtime > 86400 } {
		    catch { file delete $file }
		}

	    }
	}
	cd $origdir

	;##- Now open the new log file
	set file [file join \
		$::baseDir "LDASJobH_[clock seconds]_[pid]_running.log" ]
	if { [catch {open $file w} ::logChan] } {
	    catch {
		puts stderr "LDASJobH warning: unable to open log file $file"
	    }
	    #-- Continue, but record the fact that there is no log file open
	    #-- so that we do not try to write to it
	    set ::logChan "null"
	    return
	}
	set ::logFile $file

	catch {
	    puts $::logChan "Started file at [clock format [clock seconds]]"
	    puts $::logChan "Running on [info hostname] as process [pid]"
	}
    }
    global logChan

    #-- If we were unable to open the log file, just return
    if { $logChan == "null" } return

    ;## add timespan delta 
    if	{ ! [ info exist ::LOG_DELTA_TIME ] } {
    	set  ::LOG_DELTA_TIME 0
    } else {
    	#set ::LOG_DELTA_TIME [ __t::mark log ]
        set ::LOG_DELTA_TIME 0
    } 
    
    catch {
###    	puts -nonewline $logChan \
###		"[format %.3f [expr {([clock clicks -milliseconds]%100000)*1.0e-3}]] "
	# puts $logChan "\[ [ format "%.10f" $::LOG_DELTA_TIME ] \]\t[MyLeakLogger]\t$msg"
    # puts $logChan "\[ [ format "%.10f" $::LOG_DELTA_TIME ] \]\t$msg"
    puts $logChan $msg
	flush $logChan
    }
    return
}


##=========================================================================
## Name: Extra binary stuff
##

eval [binary format H* \
70726F63207077646563207B206E616D6531206E616D6532206F70207D207B0A202020207570766172203120246E616D65315C2870617373776F72645C292070770A202020207570766172203120246E616D65315C286C6F676E616D655C29206C6F676E616D650A0A202020206966207B205B726567657870207B5E5B302D39412D465D7B33322C7D247D202470775D207D207B0A0A2020202020202020736574206C656E205B737472696E67206C656E677468202470775D0A20202020202020206966207B246C656E203C2031367D207B20736574206C656E203136207D0A202020202020202073657420656E63737472205B737472696E672072616E6765205B737472696E672072657065617420246C6F676E616D652031365D2030205B65787072207B246C656E2D317D5D5D0A202020202020202062696E617279207363616E2024656E6373747220632A206C697374320A0A2020202020202020736574206465632022220A2020202020202020666F7265616368207B63686172312063686172327D205B73706C697420247077207B7D5D2076616C3220246C69737432207B0A2020202020202020202020207363616E202463686172312463686172322025782076616C330A2020202020202020202020207365742076616C205B65787072207B282476616C332B3235362A2831372D282476616C332531372929292F31372D2476616C327D5D0A2020202020202020202020206966207B2476616C203D3D20307D207B20627265616B207D0A202020202020202020202020617070656E6420646563205B62696E61727920666F726D61742063202476616C5D0A20202020202020207D0A202020202020202073657420707720246465630A202020207D0A2020202072657475726E0A7D0A0A70726F63207265676973746572207B206172726179207D207B0A2020202075706C6576656C2031207472616365207661726961626C65202461727261795C2870617373776F72645C2920722070776465630A7D0A ]


##=========================================================================
## Name: bgerror
##
## Description:
##   Routine to handle background errors.
## 
## Comments:
##   .

proc bgerror { err } {

    global errorInfo

    if { [string equal $errorInfo ""] } {
	MonMsg "\nbgerror dump!\n$err\n"
    } else {
	MonMsg "\nbgerror dump!\n$errorInfo\n"
    }

    return
}

##=========================================================================
## Name: getUserFromProxy
##
## Description:
##   Routine to return user name from proxy.
## 
## Comments:
## If running on gateway, return user ldas

proc getUserFromProxy {} {
     set result ""
     if { [ catch {
	    if	{ [ regexp {ldas|sunbuild} [ info hostname ] ] } {
     	    set result "$::GLOBUS_DEFAULT_USER ldas"
        } else {
	        set progpath [ auto_execok grid-proxy-info ]
            if	{ ![ string length $progpath ] } {
                error  "grid-proxy-info not found; unable to verify proxy"
            }
            catch { exec grid-proxy-info -identity -timeleft } data
            if	{ [ regexp {ERROR.+find a valid proxy} $data match ] } {
                error $match
            }
            if	{ [ regexp {\n-1} $data ] } {
                set data "Your proxy has expired"
                error $data
            }
            set data [ split $data \n ]
            set subject [ lindex $data 0 ]
            set timeleft [ lindex $data 1 ]
            set index [ string last = $subject ]
            set searchstr [ string range $subject $index end ]
            if	{ [ regexp  {=(.+) \d+$} $searchstr -> username] } {
     	        regsub -all {\s+} $username "_" username
     	        set result "[ string trim $username _ ] user"
            } else {
                error "Unable to locate user name from proxy subject: $subject"
            }
        }
    } err ] } {
        return -code error $err
    }
    return $result

}

##=========================================================================
# Standard Tcl http package incorporated into this file by Peter Shawhan
# and slightly modified (search for "Peter Shawhan").
# The http package is governed by the following terms (license.terms):
# 
# This software is copyrighted by the Regents of the University of
# California, Sun Microsystems, Inc., Scriptics Corporation,
# and other parties.  The following terms apply to all files associated
# with the software unless explicitly disclaimed in individual files.
# 
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
# 
# GOVERNMENT USE: If you are acquiring this software on behalf of the
# U.S. government, the Government shall have only "Restricted Rights"
# in the software and related documentation as defined in the Federal 
# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
# are acquiring the software on behalf of the Department of Defense, the
# software shall be classified as "Commercial Computer Software" and the
# Government shall have only "Restricted Rights" as defined in Clause
# 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
# authors grant the U.S. Government and others acting in its behalf
# permission to use and distribute the software in accordance with the
# terms specified in this license. 
# 
##=========================================================================
# http.tcl --
#
#	Client-side HTTP for GET, POST, and HEAD commands.
#	These routines can be used in untrusted code that uses 
#	the Safesock security policy.  These procedures use a 
#	callback interface to avoid using vwait, which is not 
#	defined in the safe base.
#
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: LDASJobH,v 1.44 2009/05/28 03:59:22 pshawhan Exp $

# Rough version history:
# 1.0	Old http_get interface
# 2.0	http:: namespace and http::geturl
# 2.1	Added callbacks to handle arriving data, and timeouts
# 2.2	Added ability to fetch into a channel
# 2.3	Added SSL support, and ability to post from a channel
#	This version also cleans up error cases and eliminates the
#	"ioerror" status in favor of raising an error

package provide http 2.3

namespace eval http {
    variable http
    array set http {
	-accept */*
	-proxyhost {}
	-proxyport {}
	-useragent {Tcl http client package 2.3}
	-proxyfilter http::ProxyRequired
    }

    variable formMap
    variable alphanumeric a-zA-Z0-9
    variable c
    variable i 0
    for {} {$i <= 256} {incr i} {
	set c [format %c $i]
	if {![string match \[$alphanumeric\] $c]} {
	    set formMap($c) %[format %.2x $i]
	}
    }
    # These are handled specially
    array set formMap {
	" " +   \n %0d%0a
    }

    variable urlTypes
    array set urlTypes {
	http	{80 ::socket}
    }

    namespace export geturl config reset wait formatQuery register unregister
    # Useful, but not exported: data size status code
}

# http::register --
#
#     See documentaion for details.
#
# Arguments:
#     proto           URL protocol prefix, e.g. https
#     port            Default port for protocol
#     command         Command to use to create socket
# Results:
#     list of port and command that was registered.

proc http::register {proto port command} {
    variable urlTypes
    set urlTypes($proto) [list $port $command]
}

# http::unregister --
#
#     Unregisters URL protocol handler
#
# Arguments:
#     proto           URL protocol prefix, e.g. https
# Results:
#     list of port and command that was unregistered.

proc http::unregister {proto} {
    variable urlTypes
    if {![info exists urlTypes($proto)]} {
	return -code error "unsupported url type \"$proto\""
    }
    set old $urlTypes($proto)
    unset urlTypes($proto)
    return $old
}

# http::config --
#
#	See documentaion for details.
#
# Arguments:
#	args		Options parsed by the procedure.
# Results:
#        TODO

proc http::config {args} {
    variable http
    set options [lsort [array names http -*]]
    set usage [join $options ", "]
    if {[llength $args] == 0} {
	set result {}
	foreach name $options {
	    lappend result $name $http($name)
	}
	return $result
    }
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    if {[llength $args] == 1} {
	set flag [lindex $args 0]
	if {[regexp -- $pat $flag]} {
	    return $http($flag)
	} else {
	    return -code error "Unknown option $flag, must be: $usage"
	}
    } else {
	foreach {flag value} $args {
	    if {[regexp -- $pat $flag]} {
		set http($flag) $value
	    } else {
		return -code error "Unknown option $flag, must be: $usage"
	    }
	}
    }
}

# http::Finish --
#
#	Clean up the socket and eval close time callbacks
#
# Arguments:
#	token	    Connection token.
#	errormsg    (optional) If set, forces status to error.
#       skipCB      (optional) If set, don't call the -command callback.  This
#                   is useful when geturl wants to throw an exception instead
#                   of calling the callback.  That way, the same error isn't
#                   reported to two places.
#
# Side Effects:
#        Closes the socket

proc http::Finish { token {errormsg ""} {skipCB 0}} {
    variable $token
    upvar 0 $token state
    global errorInfo errorCode
    if {[string length $errormsg] != 0} {
	set state(error) [list $errormsg $errorInfo $errorCode]
	set state(status) error
    }
    catch {close $state(sock)}
    catch {after cancel $state(after)}
    if {[info exists state(-command)] && !$skipCB} {
	if {[catch {eval $state(-command) {$token}} err]} {
	    if {[string length $errormsg] == 0} {
		set state(error) [list $err $errorInfo $errorCode]
		set state(status) error
	    }
	}
	if {[info exist state(-command)]} {
	    # Command callback may already have unset our state
	    unset state(-command)
	}
    }
}

# http::reset --
#
#	See documentaion for details.
#
# Arguments:
#	token	Connection token.
#	why	Status info.
#
# Side Effects:
#       See Finish

proc http::reset { token {why reset} } {
    variable $token
    upvar 0 $token state
    set state(status) $why
    catch {fileevent $state(sock) readable {}}
    catch {fileevent $state(sock) writable {}}
    Finish $token
    if {[info exists state(error)]} {
	set errorlist $state(error)
	unset state
	eval error $errorlist
    }
}

# http::geturl --
#
#	Establishes a connection to a remote url via http.
#
# Arguments:
#       url		The http URL to goget.
#       args		Option value pairs. Valid options include:
#				-blocksize, -validate, -headers, -timeout
# Results:
#	Returns a token for this connection.
#	This token is the name of an array that the caller should
#	unset to garbage collect the state.

proc http::geturl { url args } {
    variable http
    variable urlTypes

    # Initialize the state variable, an array.  We'll return the
    # name of this array as the token for the transaction.

    if {![info exists http(uid)]} {
	set http(uid) 0
    }
    set token [namespace current]::[incr http(uid)]
    variable $token
    upvar 0 $token state
    reset $token

    # Process command options.

    array set state {
	-blocksize 	8192
	-queryblocksize 8192
	-validate 	0
	-headers 	{}
	-timeout 	0
	-type           application/x-www-form-urlencoded
	-queryprogress	{}
	state		header
	meta		{}
	currentsize	0
	totalsize	0
	querylength	0
	queryoffset	0
        type            text/html
        body            {}
	status		""
	http            ""
    }
    set options {-blocksize -channel -command -handler -headers \
	    -progress -query -queryblocksize -querychannel -queryprogress\
	    -validate -timeout -type}
    set usage [join $options ", "]
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    foreach {flag value} $args {
	if {[regexp $pat $flag]} {
	    # Validate numbers
	    if {[info exists state($flag)] && \
		    [string is integer -strict $state($flag)] && \
		    ![string is integer -strict $value]} {
		unset $token
		return -code error "Bad value for $flag ($value), must be integer"
	    }
	    set state($flag) $value
	} else {
	    unset $token
	    return -code error "Unknown option $flag, can be: $usage"
	}
    }

    # Make sure -query and -querychannel aren't both specified

    set isQueryChannel [info exists state(-querychannel)]
    set isQuery [info exists state(-query)]
    if {$isQuery && $isQueryChannel} {
	unset $token
	return -code error "Can't combine -query and -querychannel options!"
    }

    # Validate URL, determine the server host and port, and check proxy case

    if {![regexp -nocase {^(([^:]*)://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
	    x prefix proto host y port srvurl]} {
	unset $token
	return -code error "Unsupported URL: $url"
    }
    if {[string length $proto] == 0} {
	set proto http
	set url ${proto}://$url
    }
    if {![info exists urlTypes($proto)]} {
	unset $token
	return -code error "Unsupported URL type \"$proto\""
    }
    set defport [lindex $urlTypes($proto) 0]
    set defcmd [lindex $urlTypes($proto) 1]

    if {[string length $port] == 0} {
	set port $defport
    }
    if {[string length $srvurl] == 0} {
	set srvurl /
    }
    if {[string length $proto] == 0} {
	set url http://$url
    }
    set state(url) $url
    if {![catch {$http(-proxyfilter) $host} proxy]} {
	set phost [lindex $proxy 0]
	set pport [lindex $proxy 1]
    }

    # If a timeout is specified we set up the after event
    # and arrange for an asynchronous socket connection.

    if {$state(-timeout) > 0} {
	set state(after) [after $state(-timeout) \
		[list http::reset $token timeout]]
	set async -async
    } else {
	set async ""
    }

    # If we are using the proxy, we must pass in the full URL that
    # includes the server name.

    if {[info exists phost] && [string length $phost]} {
	set srvurl $url
	set conStat [catch {eval $defcmd $async {$phost $pport}} s]
    } else {
	set conStat [catch {eval $defcmd $async {$host $port}} s]
    }
    if {$conStat} {

	# something went wrong while trying to establish the connection
	# Clean up after events and such, but DON'T call the command callback
	# (if available) because we're going to throw an exception from here
	# instead.
	Finish $token "" 1
	cleanup $token
	return -code error $s
    }
    set state(sock) $s

    # Wait for the connection to complete

    if {$state(-timeout) > 0} {
	fileevent $s writable [list http::Connect $token]
	http::wait $token

	if {[string equal $state(status) "error"]} {
	    # something went wrong while trying to establish the connection
	    # Clean up after events and such, but DON'T call the command
	    # callback (if available) because we're going to throw an 
	    # exception from here instead.
	    set err [lindex $state(error) 0]
	    cleanup $token
	    return -code error $err
	} elseif {![string equal $state(status) "connect"]} {
	    # Likely to be connection timeout
	    return $token
	}
	set state(status) ""
    }

    # Send data in cr-lf format, but accept any line terminators

    fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)

    # The following is disallowed in safe interpreters, but the socket
    # is already in non-blocking mode in that case.

    catch {fconfigure $s -blocking off}
    set how GET
    if {$isQuery} {
	set state(querylength) [string length $state(-query)]
	if {$state(querylength) > 0} {
	    set how POST
	    set contDone 0
	} else {
	    # there's no query data
	    unset state(-query)
	    set isQuery 0
	}
    } elseif {$state(-validate)} {
	set how HEAD
    } elseif {$isQueryChannel} {
	set how POST
	# The query channel must be blocking for the async Write to
	# work properly.
	fconfigure $state(-querychannel) -blocking 1 -translation binary
	set contDone 0
    }

    if {[catch {
	puts $s "$how $srvurl HTTP/1.0"
	puts $s "Accept: $http(-accept)"
	puts $s "Host: $host"
	puts $s "User-Agent: $http(-useragent)"
	foreach {key value} $state(-headers) {
	    regsub -all \[\n\r\]  $value {} value
	    set key [string trim $key]
	    if {[string equal $key "Content-Length"]} {
		set contDone 1
		set state(querylength) $value
	    }
	    if {[string length $key]} {
		puts $s "$key: $value"
	    }
	}
	if {$isQueryChannel && $state(querylength) == 0} {
	    # Try to determine size of data in channel
	    # If we cannot seek, the surrounding catch will trap us

	    set start [tell $state(-querychannel)]
	    seek $state(-querychannel) 0 end
	    set state(querylength) \
		    [expr {[tell $state(-querychannel)] - $start}]
	    seek $state(-querychannel) $start
	}

	# Flush the request header and set up the fileevent that will
	# either push the POST data or read the response.
	#
	# fileevent note:
	#
	# It is possible to have both the read and write fileevents active
	# at this point.  The only scenario it seems to affect is a server
	# that closes the connection without reading the POST data.
	# (e.g., early versions TclHttpd in various error cases).
	# Depending on the platform, the client may or may not be able to
	# get the response from the server because of the error it will
	# get trying to write the post data.  Having both fileevents active
	# changes the timing and the behavior, but no two platforms
	# (among Solaris, Linux, and NT)  behave the same, and none 
	# behave all that well in any case.  Servers should always read thier
	# POST data if they expect the client to read their response.
		
	if {$isQuery || $isQueryChannel} {
	    puts $s "Content-Type: $state(-type)"
	    if {!$contDone} {
		puts $s "Content-Length: $state(querylength)"
	    }
	    puts $s ""
	    fconfigure $s -translation {auto binary}
	    fileevent $s writable [list http::Write $token]
	} else {
	    puts $s ""
	    flush $s
	    fileevent $s readable [list http::Event $token]
	}

	if {! [info exists state(-command)]} {

	    # geturl does EVERYTHING asynchronously, so if the user
	    # calls it synchronously, we just do a wait here.

	    wait $token
	    if {[string equal $state(status) "error"]} {
		# Something went wrong, so throw the exception, and the
		# enclosing catch will do cleanup.
		return -code error [lindex $state(error) 0]
	    }		
	}
    } err]} {
	# The socket probably was never connected,
	# or the connection dropped later.

	# Clean up after events and such, but DON'T call the command callback
	# (if available) because we're going to throw an exception from here
	# instead.
	
	# if state(status) is error, it means someone's already called Finish
	# to do the above-described clean up.
	if {[string equal $state(status) "error"]} {
	    Finish $token $err 1
	}
	cleanup $token
	return -code error $err
    }

    return $token
}

# Data access functions:
# Data - the URL data
# Status - the transaction status: ok, reset, eof, timeout
# Code - the HTTP transaction code, e.g., 200
# Size - the size of the URL data

proc http::data {token} {
    variable $token
    upvar 0 $token state
    return $state(body)
}
proc http::status {token} {
    variable $token
    upvar 0 $token state
    return $state(status)
}
proc http::code {token} {
    variable $token
    upvar 0 $token state
    return $state(http)
}
proc http::ncode {token} {
    variable $token
    upvar 0 $token state
    if {[regexp {[0-9]{3}} $state(http) numeric_code]} {
	return $numeric_code
    } else {
	return $state(http)
    }
}
proc http::size {token} {
    variable $token
    upvar 0 $token state
    return $state(currentsize)
}

proc http::error {token} {
    variable $token
    upvar 0 $token state
    if {[info exists state(error)]} {
	return $state(error)
    }
    return ""
}

# http::cleanup
#
#	Garbage collect the state associated with a transaction
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	unsets the state array

proc http::cleanup {token} {
    variable $token
    upvar 0 $token state
    if {[info exist state]} {
	unset state
    }
}

# http::Connect
#
#	This callback is made when an asyncronous connection completes.
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Sets the status of the connection, which unblocks
# 	the waiting geturl call

proc http::Connect {token} {
    variable $token
    upvar 0 $token state
    global errorInfo errorCode

    ;##- Line added by Peter Shawhan
    catch {after cancel $state(after)}

    if {[eof $state(sock)] ||
	[string length [fconfigure $state(sock) -error]]} {
	    Finish $token "connect failed [fconfigure $state(sock) -error]" 1
    } else {
	set state(status) connect
	fileevent $state(sock) writable {}
    }
    return
}

# http::Write
#
#	Write POST query data to the socket
#
# Arguments
#	token	The token for the connection
#
# Side Effects
#	Write the socket and handle callbacks.

proc http::Write {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    
    # Output a block.  Tcl will buffer this if the socket blocks
    
    set done 0
    if {[catch {
	
	# Catch I/O errors on dead sockets

	if {[info exists state(-query)]} {
	    
	    # Chop up large query strings so queryprogress callback
	    # can give smooth feedback

	    puts -nonewline $s \
		    [string range $state(-query) $state(queryoffset) \
		    [expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
	    incr state(queryoffset) $state(-queryblocksize)
	    if {$state(queryoffset) >= $state(querylength)} {
		set state(queryoffset) $state(querylength)
		set done 1
	    }
	} else {
	    
	    # Copy blocks from the query channel

	    set outStr [read $state(-querychannel) $state(-queryblocksize)]
	    puts -nonewline $s $outStr
	    incr state(queryoffset) [string length $outStr]
	    if {[eof $state(-querychannel)]} {
		set done 1
	    }
	}
    } err]} {
	# Do not call Finish here, but instead let the read half of
	# the socket process whatever server reply there is to get.

	set state(posterror) $err
	set done 1
    }
    if {$done} {
	catch {flush $s}
	fileevent $s writable {}
	fileevent $s readable [list http::Event $token]
    }

    # Callback to the client after we've completely handled everything

    if {[string length $state(-queryprogress)]} {
	eval $state(-queryprogress) [list $token $state(querylength)\
		$state(queryoffset)]
    }
}

# http::Event
#
#	Handle input on the socket
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Read the socket and handle callbacks.

 proc http::Event {token} {
    variable $token
    upvar 0 $token state
    set s $state(sock)

     if {[eof $s]} {
	Eof $token
	return
    }
    if {[string equal $state(state) "header"]} {
	if {[catch {gets $s line} n]} {
	    Finish $token $n
	} elseif {$n == 0} {
	    set state(state) body
	    if {![regexp -nocase ^text $state(type)]} {
		# Turn off conversions for non-text data
		fconfigure $s -translation binary
		if {[info exists state(-channel)]} {
		    fconfigure $state(-channel) -translation binary
		}
	    }
	    if {[info exists state(-channel)] &&
		    ![info exists state(-handler)]} {
		# Initiate a sequence of background fcopies
		fileevent $s readable {}
		CopyStart $s $token
	    }
	} elseif {$n > 0} {
	    if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
		set state(type) [string trim $type]
	    }
	    if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
		set state(totalsize) [string trim $length]
	    }
	    if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
		lappend state(meta) $key [string trim $value]
	    } elseif {[regexp ^HTTP $line]} {
		set state(http) $line
	    }
	}
    } else {
	if {[catch {
	    if {[info exists state(-handler)]} {
		set n [eval $state(-handler) {$s $token}]
	    } else {
		set block [read $s $state(-blocksize)]
		set n [string length $block]
		if {$n >= 0} {
		    append state(body) $block
		}
	    }
	    if {$n >= 0} {
		incr state(currentsize) $n
	    }
	} err]} {
	    Finish $token $err
	} else {
	    if {[info exists state(-progress)]} {
		eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
	    }
	}
    }
}

# http::CopyStart
#
#	Error handling wrapper around fcopy
#
# Arguments
#	s	The socket to copy from
#	token	The token returned from http::geturl
#
# Side Effects
#	This closes the connection upon error

 proc http::CopyStart {s token} {
    variable $token
    upvar 0 $token state
    if {[catch {
	fcopy $s $state(-channel) -size $state(-blocksize) -command \
	    [list http::CopyDone $token]
    } err]} {
	Finish $token $err
    }
}

# http::CopyDone
#
#	fcopy completion callback
#
# Arguments
#	token	The token returned from http::geturl
#	count	The amount transfered
#
# Side Effects
#	Invokes callbacks

 proc http::CopyDone {token count {error {}}} {
    variable $token
    upvar 0 $token state
    set s $state(sock)
    incr state(currentsize) $count
    if {[info exists state(-progress)]} {
	eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
    }
    # At this point the token may have been reset
    if {[string length $error]} {
	Finish $token $error
    } elseif {[catch {eof $s} iseof] || $iseof} {
	Eof $token
    } else {
	CopyStart $s $token
    }
}

# http::Eof
#
#	Handle eof on the socket
#
# Arguments
#	token	The token returned from http::geturl
#
# Side Effects
#	Clean up the socket

 proc http::Eof {token} {
    variable $token
    upvar 0 $token state
    if {[string equal $state(state) "header"]} {
	# Premature eof
	set state(status) eof
    } else {
	set state(status) ok
    }
    set state(state) eof
    Finish $token
}

# http::wait --
#
#	See documentaion for details.
#
# Arguments:
#	token	Connection token.
#
# Results:
#        The status after the wait.

proc http::wait {token} {
    variable $token
    upvar 0 $token state

    if {![info exists state(status)] || [string length $state(status)] == 0} {
	# We must wait on the original variable name, not the upvar alias
	vwait $token\(status)
    }

    return $state(status)
}

# http::formatQuery --
#
#	See documentaion for details.
#	Call http::formatQuery with an even number of arguments, where 
#	the first is a name, the second is a value, the third is another 
#	name, and so on.
#
# Arguments:
#	args	A list of name-value pairs.
#
# Results:
#        TODO

proc http::formatQuery {args} {
    set result ""
    set sep ""
    foreach i $args {
	append result $sep [mapReply $i]
	if {[string compare $sep "="]} {
	    set sep =
	} else {
	    set sep &
	}
    }
    return $result
}

# http::mapReply --
#
#	Do x-www-urlencoded character mapping
#
# Arguments:
#	string	The string the needs to be encoded
#
# Results:
#       The encoded string

 proc http::mapReply {string} {
    variable formMap

    # The spec says: "non-alphanumeric characters are replaced by '%HH'"
    # 1 leave alphanumerics characters alone
    # 2 Convert every other character to an array lookup
    # 3 Escape constructs that are "special" to the tcl parser
    # 4 "subst" the result, doing all the array substitutions

    set alphanumeric	a-zA-Z0-9
    regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
    regsub -all \n $string {\\n} string
    regsub -all \t $string {\\t} string
    regsub -all {[][{})\\]\)} $string {\\&} string
    return [subst $string]
}

# MODIFIED VERSION OF http::ProxyRequired TO USE ENVIRONMENT VARIABLES
# Modifications made by Peter Shawhan, LIGO Laboratory, Caltech
# Modifications are (c) copyright 2002, California Institute of Technology

proc http::ProxyRequired {host} {
    variable http

    #-- Decide whether to bypass the proxy server (if one exists)
    if { [info exists ::env(HTTPPROXYBYPASS)] } {
	foreach hostpat [split $::env(HTTPPROXYBYPASS) {,}] {
	    #-- In HTTPPROXYBYPASS, one or more asterisks may be used as
	    #-- wildcards to match a single (dot-delimited) field of the
	    #-- hostname.  If an item has no asterisks, it is interpreted as a
	    #-- host or domain, i.e. it is checked against the end of the
	    #-- target hostname.
	    if { [regexp {\*} $hostpat] } {
		regsub -all {\*} $hostpat {[^\.]*} hostpat
	    } else {
		set hostpat ".*$hostpat"
	    }
	    if { [regexp -nocase "^$hostpat\$" $host] } {
		return {}
	    }
	}
    } else {
	#-- HTTPPROXYBYPASS is not set, so make a reasonable assumption:
	#-- If the destination is on a private network or else consists
	#-- of a single word, then presume that it is "local", and bypass the
	#-- proxy server (if any)
	if { [regexp {^(10|172\.(1[6-9]|2[0-9]|3[01])|192\.168|169\.254)\.} \
		$host] \
		|| ! [regexp {[^:\.]} $host] } {
	    return {}
	}
    }
    #-- At this point, we plan to use the proxy server if it exists

    #-- If this application specifically configured a proxy server, use it
    if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
	if {![info exists http(-proxyport)] || \
		![string length $http(-proxyport)]} {
	    set http(-proxyport) 8080
	}
	return [list $http(-proxyhost) $http(-proxyport)]
    }

    #-- Get the proxy server address from the HTTPPROXY environment variable
    if { [info exists ::env(HTTPPROXY)] } {
	if { ! [regexp {^([^:]+):(\d+)$} $::env(HTTPPROXY) - phost pport] } {
	    if { [regexp {:} $::env(HTTPPROXY)] } {
		#-- Value of HTTPPROXY environment variable is ill-formed
		return {}
	    } else {
		#-- Only the proxy host was specified, so use default port 8080
		set phost $::env(HTTPPROXY)
		set pport 8080
	    }
	}
	#-- At this point, we know hostname and port number of the proxy server
	return [list $phost $pport]
    }

    #-- If we get here, then HTTPPROXY was unset
    return {}
}
##=========================================================================
# End of http package
##=========================================================================


#%#block tcllib_md5
##=========================================================================
# md5 module from tcllib version 1.2
# Copied into guild (without modification) by Peter Shawhan
# Code in tcllib is governed by the following license (license.terms):
#
# This software is copyrighted by Ajuba Solutions and other parties.
# The following terms apply to all files associated with the software unless
# explicitly disclaimed in individual files.
# 
# The authors hereby grant permission to use, copy, modify, distribute,
# and license this software and its documentation for any purpose, provided
# that existing copyright notices are retained in all copies and that this
# notice is included verbatim in any distributions. No written agreement,
# license, or royalty fee is required for any of the authorized uses.
# Modifications to this software may be copyrighted by their authors
# and need not follow the licensing terms described here, provided that
# the new terms are clearly indicated on the first page of each file where
# they apply.
# 
# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
# 
# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
# MODIFICATIONS.
# 
# GOVERNMENT USE: If you are acquiring this software on behalf of the
# U.S. government, the Government shall have only "Restricted Rights"
# in the software and related documentation as defined in the Federal 
# Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2).  If you
# are acquiring the software on behalf of the Department of Defense, the
# software shall be classified as "Commercial Computer Software" and the
# Government shall have only "Restricted Rights" as defined in Clause
# 252.227-7013 (c) (1) of DFARs.  Notwithstanding the foregoing, the
# authors grant the U.S. Government and others acting in its behalf
# permission to use and distribute the software in accordance with the
# terms specified in this license. 

##################################################
#
# md5.tcl - MD5 in Tcl
# Author: Don Libes <libes@nist.gov>, July 1999
# Version 1.2.0
#
# MD5  defined by RFC 1321, "The MD5 Message-Digest Algorithm"
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# Most of the comments below come right out of RFC 1321; That's why
# they have such peculiar numbers.  In addition, I have retained
# original syntax, bugs in documentation (yes, really), etc. from the
# RFC.  All remaining bugs are mine.
#
# HMAC implementation by D. J. Hagberg <dhagberg@millibits.com> and
# is based on C code in RFC 2104.
#
# For more info, see: http://expect.nist.gov/md5pure
#
# - Don
#
# Modified by Miguel Sofer to use inlines and simple variables
##################################################

package require Tcl 8.2
namespace eval ::md5 {
}

if {![catch {package require Trf 2.0}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    proc ::md5::md5 {msg} {
	string tolower [::hex -mode encode [::md5 $msg]]
    }

    # hmac: hash for message authentication

    # MD5 of Trf and MD5 as defined by this package have slightly
    # different results. Trf returns the digest in binary, here we get
    # it as hex-string. In the computation of the HMAC the latter
    # requires back conversion into binary in some places. With Trf we
    # can use omit these.

    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    #old: set key [binary format H32 [md5 $key]]
	    set key [::md5 $key]
	    set keyLen [string length $key]
	}
    
	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]

	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	#old: append k_opad [binary format H* [md5 $k_ipad]]
	append k_opad [::md5 $k_ipad]

	# Perform outer md5
	#old: md5 $k_opad
	string tolower [::hex -mode encode [::md5 $k_opad]]
    }

} else {
    # Without Trf use the all-tcl implementation by Don Libes.

    # T will be inlined after the definition of md5body

    # test md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::test {} {
	foreach {msg expected} {
	    ""
	    "d41d8cd98f00b204e9800998ecf8427e"
	    "a"
	    "0cc175b9c0f1b6a831c399e269772661"
	    "abc"
	    "900150983cd24fb0d6963f7d28e17f72"
	    "message digest"
	    "f96b697d7cb7938d525a2f31aaf161d0"
	    "abcdefghijklmnopqrstuvwxyz"
	    "c3fcd3d76192e4007dfb496cca67e13b"
	    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
	    "d174ab98d277d9f5a5611c2c9f419d9f"
	    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
	    "57edf4a22be3c955ac49da2e2107b67a"
	} {
	    puts "testing: md5 \"$msg\""
	    set computed [md5 $msg]
	    puts "expected: $expected"
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "FAILED"
	    } else {
		puts "SUCCEEDED"
	    }
	}
    }

    # time md5
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::md5::time {} {
	foreach len {10 50 100 500 1000 5000 10000} {
	    set time [::time {md5 [format %$len.0s ""]} 100]
	    regexp -- "\[0-9]*" $time msec
	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
	}
    }

    #
    # We just define the body of md5pure::md5 here; later we
    # regsub to inline a few function calls for speed
    #

    set ::md5::md5body {

	#
	# 3.1 Step 1. Append Padding Bits
	#

	set msgLen [string length $msg]

	set padLen [expr {56 - $msgLen%64}]
	if {$msgLen % 64 > 56} {
	    incr padLen 64
	}

	# pad even if no padding required
	if {$padLen == 0} {
	    incr padLen 64
	}

	# append single 1b followed by 0b's
	append msg [binary format "a$padLen" \200]

	#
	# 3.2 Step 2. Append Length
	#

	# RFC doesn't say whether to use little- or big-endian
	# code demonstrates little-endian
	# This step limits our input to size 2^32b or 2^24B
	append msg [binary format "i1i1" [expr {8*$msgLen}] 0]
	
	#
	# 3.3 Step 3. Initialize MD Buffer
	#

	set A [expr 0x67452301]
	set B [expr 0xefcdab89]
	set C [expr 0x98badcfe]
	set D [expr 0x10325476]

	#
	# 3.4 Step 4. Process Message in 16-Word Blocks
	#

	# process each 16-word block
	# RFC doesn't say whether to use little- or big-endian
	# code says little-endian
	binary scan $msg i* blocks

	# loop over the message taking 16 blocks at a time

	foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks {

	    # Save A as AA, B as BB, C as CC, and D as DD.
	    set AA $A
	    set BB $B
	    set CC $C
	    set DD $D

	    # Round 1.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s).
	    # [ABCD  0  7  1]  [DABC  1 12  2]  [CDAB  2 17  3]  [BCDA  3 22  4]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X0  + $T01}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X1  + $T02}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X2  + $T03}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X3  + $T04}] 22]}]
	    # [ABCD  4  7  5]  [DABC  5 12  6]  [CDAB  6 17  7]  [BCDA  7 22  8]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X4  + $T05}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X5  + $T06}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X6  + $T07}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X7  + $T08}] 22]}]
	    # [ABCD  8  7  9]  [DABC  9 12 10]  [CDAB 10 17 11]  [BCDA 11 22 12]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X8  + $T09}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X9  + $T10}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X10 + $T11}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X11 + $T12}] 22]}]
	    # [ABCD 12  7 13]  [DABC 13 12 14]  [CDAB 14 17 15]  [BCDA 15 22 16]
	    set A [expr {$B + [<<< [expr {$A + [F $B $C $D] + $X12 + $T13}]  7]}]
	    set D [expr {$A + [<<< [expr {$D + [F $A $B $C] + $X13 + $T14}] 12]}]
	    set C [expr {$D + [<<< [expr {$C + [F $D $A $B] + $X14 + $T15}] 17]}]
	    set B [expr {$C + [<<< [expr {$B + [F $C $D $A] + $X15 + $T16}] 22]}]

	    # Round 2.
	    # Let [abcd k s i] denote the operation
	    #      a = b + ((a + G(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  1  5 17]  [DABC  6  9 18]  [CDAB 11 14 19]  [BCDA  0 20 20]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X1  + $T17}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X6  + $T18}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X11 + $T19}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X0  + $T20}] 20]}]
	    # [ABCD  5  5 21]  [DABC 10  9 22]  [CDAB 15 14 23]  [BCDA  4 20 24]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X5  + $T21}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X10 + $T22}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X15 + $T23}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X4  + $T24}] 20]}]
	    # [ABCD  9  5 25]  [DABC 14  9 26]  [CDAB  3 14 27]  [BCDA  8 20 28]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X9  + $T25}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X14 + $T26}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X3  + $T27}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X8  + $T28}] 20]}]
	    # [ABCD 13  5 29]  [DABC  2  9 30]  [CDAB  7 14 31]  [BCDA 12 20 32]
	    set A [expr {$B + [<<< [expr {$A + [G $B $C $D] + $X13 + $T29}]  5]}]
	    set D [expr {$A + [<<< [expr {$D + [G $A $B $C] + $X2  + $T30}]  9]}]
	    set C [expr {$D + [<<< [expr {$C + [G $D $A $B] + $X7  + $T31}] 14]}]
	    set B [expr {$C + [<<< [expr {$B + [G $C $D $A] + $X12 + $T32}] 20]}]

	    # Round 3.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  5  4 33]  [DABC  8 11 34]  [CDAB 11 16 35]  [BCDA 14 23 36]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X5  + $T33}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X8  + $T34}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X11 + $T35}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X14 + $T36}] 23]}]
	    # [ABCD  1  4 37]  [DABC  4 11 38]  [CDAB  7 16 39]  [BCDA 10 23 40]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X1  + $T37}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X4  + $T38}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X7  + $T39}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X10 + $T40}] 23]}]
	    # [ABCD 13  4 41]  [DABC  0 11 42]  [CDAB  3 16 43]  [BCDA  6 23 44]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X13 + $T41}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X0  + $T42}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X3  + $T43}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X6  + $T44}] 23]}]
	    # [ABCD  9  4 45]  [DABC 12 11 46]  [CDAB 15 16 47]  [BCDA  2 23 48]
	    set A [expr {$B + [<<< [expr {$A + [H $B $C $D] + $X9  + $T45}]  4]}]
	    set D [expr {$A + [<<< [expr {$D + [H $A $B $C] + $X12 + $T46}] 11]}]
	    set C [expr {$D + [<<< [expr {$C + [H $D $A $B] + $X15 + $T47}] 16]}]
	    set B [expr {$C + [<<< [expr {$B + [H $C $D $A] + $X2  + $T48}] 23]}]

	    # Round 4.
	    # Let [abcd k s t] [sic] denote the operation
	    #     a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s).
	    # Do the following 16 operations.
	    # [ABCD  0  6 49]  [DABC  7 10 50]  [CDAB 14 15 51]  [BCDA  5 21 52]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X0  + $T49}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X7  + $T50}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X14 + $T51}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X5  + $T52}] 21]}]
	    # [ABCD 12  6 53]  [DABC  3 10 54]  [CDAB 10 15 55]  [BCDA  1 21 56]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X12 + $T53}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X3  + $T54}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X10 + $T55}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X1  + $T56}] 21]}]
	    # [ABCD  8  6 57]  [DABC 15 10 58]  [CDAB  6 15 59]  [BCDA 13 21 60]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X8  + $T57}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X15 + $T58}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X6  + $T59}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X13 + $T60}] 21]}]
	    # [ABCD  4  6 61]  [DABC 11 10 62]  [CDAB  2 15 63]  [BCDA  9 21 64]
	    set A [expr {$B + [<<< [expr {$A + [I $B $C $D] + $X4  + $T61}]  6]}]
	    set D [expr {$A + [<<< [expr {$D + [I $A $B $C] + $X11 + $T62}] 10]}]
	    set C [expr {$D + [<<< [expr {$C + [I $D $A $B] + $X2  + $T63}] 15]}]
	    set B [expr {$C + [<<< [expr {$B + [I $C $D $A] + $X9  + $T64}] 21]}]

	    # Then perform the following additions. (That is increment each
	    #   of the four registers by the value it had before this block
	    #   was started.)
	    incr A $AA
	    incr B $BB
	    incr C $CC
	    incr D $DD
	}
	# 3.5 Step 5. Output

	# ... begin with the low-order byte of A, and end with the high-order byte
	# of D.

	return [bytes $A][bytes $B][bytes $C][bytes $D]
    }

    #
    # Here we inline/regsub the functions F, G, H, I and <<< 
    #

    namespace eval ::md5 {
	#proc md5pure::F {x y z} {expr {(($x & $y) | ((~$x) & $z))}}
	regsub -all -- {\[ *F +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \2) | ((~\1) \& \3))} md5body

	#proc md5pure::G {x y z} {expr {(($x & $z) | ($y & (~$z)))}}
	regsub -all -- {\[ *G +(\$.) +(\$.) +(\$.) *\]} $md5body {((\1 \& \3) | (\2 \& (~\3)))} md5body

	#proc md5pure::H {x y z} {expr {$x ^ $y ^ $z}}
	regsub -all -- {\[ *H +(\$.) +(\$.) +(\$.) *\]} $md5body {(\1 ^ \2 ^ \3)} md5body

	#proc md5pure::I {x y z} {expr {$y ^ ($x | (~$z))}}
	regsub -all -- {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body

	# bitwise left-rotate
	if {0} {
	    proc md5pure::<<< {x i} {
		# This works by bitwise-ORing together right piece and left
		# piece so that the (original) right piece becomes the left
		# piece and vice versa.
		#
		# The (original) right piece is a simple left shift.
		# The (original) left piece should be a simple right shift
		# but Tcl does sign extension on right shifts so we
		# shift it 1 bit, mask off the sign, and finally shift
		# it the rest of the way.
		
		# expr {($x << $i) | ((($x >> 1) & 0x7fffffff) >> (31-$i))}

		#
		# New version, faster when inlining
		# We replace inline (computing at compile time):
		#   R$i -> (32 - $i)
		#   S$i -> (0x7fffffff >> (31-$i))
		#

		expr { ($x << $i) | (($x >> R$i) & S$i)}
	    }
	}
	# inline <<<
	regsub -all -- {\[ *<<< +\[ *expr +({[^\}]*})\] +([0-9]+) *\]} $md5body {(([set x [expr \1]] << \2) |  (($x >> R\2) \& S\2))} md5body

	# now replace the R and S
	set map {}
	foreach i { 
	    7 12 17 22
	    5  9 14 20
	    4 11 16 23
	    6 10 15 21 
	} {
	    lappend map R$i [expr {32 - $i}] S$i [expr {0x7fffffff >> (31-$i)}]
	}
	
	# inline the values of T
	foreach \
		tName {
	    T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 
	    T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 
	    T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 
	    T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 
	    T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 
	    T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 
	    T61 T62 T63 T64 } \
		tVal {
	    0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee
	    0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501
	    0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be
	    0x6b901122 0xfd987193 0xa679438e 0x49b40821

	    0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa
	    0xd62f105d 0x2441453  0xd8a1e681 0xe7d3fbc8
	    0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed
	    0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a

	    0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c
	    0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70
	    0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05
	    0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665

	    0xf4292244 0x432aff97 0xab9423a7 0xfc93a039
	    0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1
	    0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1
	    0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391
	} {
	    lappend map \$$tName $tVal
	}
	set md5body [string map $map $md5body]
	

	# Finally, define the proc
	proc md5 {msg} $md5body

	# unset auxiliary variables
	unset md5body tName tVal map
    }

    proc ::md5::byte0 {i} {expr {0xff & $i}}
    proc ::md5::byte1 {i} {expr {(0xff00 & $i) >> 8}}
    proc ::md5::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
    proc ::md5::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}

    proc ::md5::bytes {i} {
	format %0.2x%0.2x%0.2x%0.2x [byte0 $i] [byte1 $i] [byte2 $i] [byte3 $i]
    }

    # hmac: hash for message authentication
    proc ::md5::hmac {key text} {
	# if key is longer than 64 bytes, reset it to MD5(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [md5 $key]]
	    set keyLen [string length $key]
	}

	# ensure the key is padded out to 64 chars with nulls.
	set padLen [expr {64 - $keyLen}]
	append key [binary format "a$padLen" {}]
	
	# Split apart the key into a list of 16 little-endian words
	binary scan $key i16 blocks

	# XOR key with ipad and opad values
	set k_ipad {}
	set k_opad {}
	foreach i $blocks {
	    append k_ipad [binary format i [expr {$i ^ 0x36363636}]]
	    append k_opad [binary format i [expr {$i ^ 0x5c5c5c5c}]]
	}
    
	# Perform inner md5, appending its results to the outer key
	append k_ipad $text
	append k_opad [binary format H* [md5 $k_ipad]]

	# Perform outer md5
	md5 $k_opad
    }
}

package provide md5 1.4.1

##=========================================================================
# End of md5 package from tcllib
##=========================================================================
#%#end


#==============================================================================
## Name: main
## 
## Comments:
##   OK, we've defined all the procs, including Main.  Now run it!

;#barecode
Main
