The genericAPI.tcl Script

Modification Date: 11/26/2008

Table of Procedures

Main addNewResourcesToFile anonFtpToplevel apiDirectory bCrypt bak bakDemangle bgLoop binaryDecrypt binaryEncrypt bootLock checkLeaks checkMySetup cloneProc cmdGet cmdSets cmonResource::deleteResourcesFromFile countChannels cppBase64Init cryptFileInPlace curlGetRemoteFileSize decryptFile destructElementWrap dropStatusPage dumpData dumpFile execscp execssh expandOpts fifo fileExists fileIsBeingWritten fileType fixUrlTarget formatAndProtocol formatConversion freeMemOnBox ftpPutLocal getApiOS getCurlUrl getCurlUrlCallback getIPAddress getMddTarget getSockData (reads data from a socket, usually getUrl gifBalls gridFtpToplevel ifConfig infoVars int2roman isBinary itemCount jobDirectory lastline leakLogger leaksSummary libstdcPlusPlus

macroReturnMsg managerOutputUrl mapTCLVarToCVar mapTCLVarToCVar memFlag metaOpts myIP myName newhead newtail numRange outputFormat outputUrls outputUrlsBg packageReport parseURL pingAPI pongAPI popMsg portInfo procList procServer pubDirSetup publicFile putCurlUrl putUrl randomNumber realTimeRscValues relativeDirectory revArray roVar safeRxPat saveResourceToFile setAlertDebug setAlertDebugCB setLdasSystemName setResourceLimit shellPipe sleep sourceFile sourceRsc stats touch trace traceTimeout ucase unknown unpackTarball unwrapText url2file validFilename validProc validateEtcHosts varType when wrapText

proc trace { args } {
    if { [ info exists ::DEBUG_TRACE ] \
	     && $::DEBUG_TRACE == 1 \
	     && [ info exists ::operator_socket ] } {
	set msg "'[ info level -1 ]' calling Trace: trace $args"
	addLogEntry $msg purple
    }
    if { [regexp {8.3} $::tcl_version]  \
	     && ( [llength $args] > 2 ) \
	     && ![regexp {variable|vdelete|vinfo} [lindex $args 0] ] \
	     && [regexp {variable} [lindex $args 1] ] } {
	## **************************************************************
	## Provide tcl 8.4 syntax for 8.3 interpreter
	## **************************************************************
	set majorcommand [lindex $args 0]
	set tuype [lindex $args 1]
	set name [lindex $args 2]
	set ops [list]
	set minorcommand [list]
	if { [llength $args] > 2 } {
	    foreach op [lindex $args 3] {
		switch -exact $op {
		    read {
			set ops "r$ops"
		    }
		    write {
			set ops "w$ops"
		    }
		    unset {
			set ops "u$ops"
		    }
		}
	    }
	    if { [string length $ops] <= 0 } {
		set $ops [lindex $args 3]
	    }
	
	    set minorcommand [list [lindex $args 4] ]
	}
	switch -exact $majorcommand {
	    add {
		uplevel tcl_trace variable $name $ops $minorcommand
	    }
	    remove {
		uplevel tcl_trace vdelete $name $ops $minorcommand
	    }
	    info {
		uplevel tcl_trace vinfo $name
	    }
	    default {
		uplevel tcl_trace $args
	    }
	}
	
    } else {
	uplevel tcl_trace $args
    }
}

proc setAlertDebug { args } {
    uplevel ldas_setAlert $args
    if { [ info exists ::DEBUG_TRACE ] \
	     && $::DEBUG_TRACE == 1 \
	     && [ info exists ::operator_socket ] } {
	set msg "'[ info level -1 ]' setAlert $args -- [getTIDDebugInfo [ lindex $args 0] ]"
	addLogEntry $msg purple
    }
}

proc setAlertDebugCB { args } {
    if { [ lsearch [ info proc *setAlert ] ldas_setAlert ] == -1 } {
	trace remove variable ::TID_FINISHED [list read write] ::setAlertDebugCB
	rename setAlert ldas_setAlert
	rename setAlertDebug setAlert
    }
}

1. See if the machine knows it's name. if not, check for the existence of the variable $LOCALHOST. If the machine name cannot be determined, a Tcl exception is thrown.
   No attempt is made to defeat spoofing.
   
2. Check to see if the LDAS toplevel directory has been declared, and whether the subdirectory locations are set. Set the toplevel to "pwd" if it's not found, and set the required subdirs to reasonable places beneath it.
   
3. Check the declarations of required resource variables, throws an exception if any required value is not found.
   
4. Finally, it checks for a valid filename for the local log file, and make up a likely one based on the name of the resource file if it needs to.
   

       checkMySetup
Where "API" should be declared at the top of the resource
file by a line like:


                      set API usr

proc validateEtcHosts { args } {
     if { [ catch {
        set data [ dumpFile /etc/hosts ]
        set data [ split $data "\n" ]
        foreach line $data {
           if { [ regexp {^\s*127.0.0.1} $line ] } {
              break
           }
        }
        if { ! [ string equal localhost $::env(HOST) ] && \
               [ lsearch $line $::env(HOST) ] != -1 } {
           set subject "$::API API: $::env(HOST) aliased to loopback!"
           set msg    "/etc/hosts file declares $::env(HOST) to "
           append msg "be an alias for the loopback address.\n"
           append msg "if all API's in this LDAS system are running\n"
           append msg "on $::env(HOST) this is not a problem, but if\n"
           append msg "any API's run on OTHER MACHINES this is likely\n"
           append msg "to cause data socket communication problems!"
           return -code error $subject
        }
     } err ] } {
        puts stderr $subject
        addLogEntry "Subject: ${subject}; Body: $msg" email
     }
}

proc setLdasSystemName { } {
     if { [ catch {
        if { [ file exists /etc/ldasname ] } {
           set ::LDAS_SYSTEM [ dumpFile /etc/ldasname ]
        } else {
           set ::LDAS_SYSTEM localhost
        }
        ;## convert trailing integers to roman numerals!
        if { [ regexp {(.+)(\d+)$} $::LDAS_SYSTEM -> name int ] } {
           set ::LDAS_SYSTEM $name[ int2roman $int ]
        }
        set ::LDAS_SYSTEM [ string trim $::LDAS_SYSTEM ]
        roVar LDAS_SYSTEM
        set ::RUNCODE [ string toupper $::LDAS_SYSTEM ]
        puts stderr "::LDAS_SYSTEM set to '$::LDAS_SYSTEM'"
        ;## turn ::${::API}_API_HOST resource variables
        ;## into the system api host list.
        set hosts [ info vars ::*_API_HOST ]
        foreach host $hosts {
           regexp {::([^_]+)} $host -> api
           set host [ set $host ]
           set api [ string tolower $api ]
           set ::${::LDAS_SYSTEM}($api) $host
        }
     } err ] } {
        return -code error "[ myName ]: $err"
     }
}

proc pubDirSetup { } {
     if { ! [ info exists  ::FTPDIR ] || \
          ! [ file exists $::FTPDIR ] } {
        set ::FTPDIR  [ anonFtpToplevel ]
        ;## anon ftp may be set up badly -- it happens!
        if { [ string length $::FTPDIR ] && \
           ! [ file exists $::FTPDIR ]   && \
             [ string equal manager $::API ] } {
           file mkdir $::FTPDIR
           file attributes $::FTPDIR -permissions 0755
           puts stderr "toplevel ftp directory created: '$::FTPDIR'"
        }
        if { [ string length $::FTPDIR ] && \
           ! [ file writable $::FTPDIR ] } {
           if { [ file writable \
                [ file join $::FTPDIR pub outgoing ] ] } {
              set ::FTPDIR [ file join $::FTPDIR pub outgoing ]
           } elseif { [ file writable \
                      [ file join $::FTPDIR pub ] ] } {
              set ::FTPDIR [ file join $::FTPDIR pub ]
           } else {
              set ::FTPDIR [ list ]
           }
        }
     }
     set rel [ list ]
     set cwd $::env(RUNDIR)
     ;## no browser access to cwd!
     if { ! [ file exists index.html ] } {
        set fid [ open index.html w 0444 ]
        puts $fid <HTML>
        close $fid
     }
     regsub $::WORKING_DIRECTORY_MOUNT_POINT $cwd {} cwd
     regsub [ anonFtpToplevel ] $::FTPDIR {} rel
     if { ! [ info exists  ::FTPURL ] || \
          ! [ file exists $::FTPURL ] } {
        set ::FTPURL  ftp://$::MY_IP$rel
     }
     if { ! [ info exists  ::HTTPURL ] || \
          ! [ file exists $::HTTPURL ] } {
        set ::HTTPURL http://${::MY_IP}${cwd}/jobs
     }
     if { ! [ info exists  ::HTTPDIR ] || \
          ! [ file exists $::HTTPDIR ] } {
        set ::HTTPDIR [ file join $cwd jobs ]
     }
     if { ! [ info exists  ::PUBDIR ] || \
          ! [ file exists $::PUBDIR ] } {
        set ::PUBDIR $::HTTPDIR
     }
     set fname [ file join $::PUBDIR .htaccess ]
     if { ! [ file exists $fname ] } {
        file mkdir $::PUBDIR
        file attributes $::PUBDIR -permissions 0775
        set fid [ open $fname w 0444 ]
        puts $fid "DefaultType application/octet-stream"
        close $fid
     }
     setLdasSystemName
     set ::GRIDFTPDIR [ gridFtpToplevel ]
     if { [ string length $::GRIDFTPDIR ] } {
        set ::GRIDFTPURL gridftp:$::GRIDFTPDIR
     } else {
        set ::GRIDFTPURL [ list ]
     }
     puts stderr "::FTPDIR set to '$::FTPDIR'"
     puts stderr "::FTPURL set to '$::FTPURL'"
     puts stderr "::HTTPDIR set to '$::HTTPDIR'"
     puts stderr "::HTTPURL set to '$::HTTPURL'"
     puts stderr "::GRIDFTPURL set to '$::GRIDFTPURL'"
     puts stderr "::GRIDFTPDIR set to '$::GRIDFTPDIR'"
     puts stderr "::PUBDIR set to '$::PUBDIR'"
}

      set ip_address [ getIPAddress $host|$ipaddress ]

proc getIPAddress { host } {
     set retval [ list ]
     if { [ catch {
        set sid [ socket -async $host 22 ]
        after 100
        set data [ fconfigure $sid -peername ]
        close $sid
        foreach [ list ip hostname port ] $data { break }
        if { [ string equal $host $ip ] } {
           set retval $hostname
        } else {
           set retval $ip
        }
     } err ] } {
        catch { ::close $sid }
        puts stderr "getIPAddress: failed to connect to $host port 22: '$err'"
     }
     return $retval
}

       set ::__myip [ myIP ]

proc myIP {} {
     if { [ catch {
        set ip 127.0.0.1
        set sid [ socket -async [ info hostname ] 22 ]
        set ip  [ lindex [ fconfigure $sid -sockname ] 0 ]
        ::close $sid
     } err ] } {
        catch { ::close $sid }
        puts stderr "myIP error: '$err' on port 22 (sshd). using 127.0.0.1"
     }
     return $ip
}

  Example output:


   {lo0 127.0.0.1 localhost}
   {ge0 10.16.0.5 gateway}
   {hme0 131.215.115.248 {ldas-dev ldas-dev.ligo.caltech.edu loghost}}

proc ifConfig { args } {
     if { [ catch {
        set interfaces [ list ]
        if { [ file executable /usr/sbin/ifconfig ] } {
           catch { ::exec /usr/sbin/ifconfig -a } data
        } elseif { [ file executable /sbin/ifconfig ] } {
           catch { ::exec /sbin/ifconfig -a } data
        } else {
           return -code error "can't find 'ifconfig' executable!"
        }
        set fid [ open /etc/hosts r ]
        set hostdata [ read $fid [ file size /etc/hosts ] ]
        ::close $fid
        foreach line [ split $hostdata "\n" ] {
           array set hosts \
              [ list [ lindex $line 0 ] [ lrange $line 1 end ] ]
        }
        foreach line [ split $data "\n" ] {
           regexp {^(lo |[a-z]+\d+)} $line -> if
           set if [ string trim $if ]
           if { [ regexp {^\s+inet\s+(?:addr:)?(\S+)} $line -> ip ] } {
              if { [ info exists hosts($ip) ] } {
                 lappend interfaces [ list $if $ip $hosts($ip) ]
              } else {
                 lappend interfaces [ list $if $ip dhcp ]
              }
           }
        }
     } err ] } {
        return -code error "[ myName ]: $err"
     }
     return $interfaces
}

• name - a proc name or wildcard in any number of forms:
  
  1. foo - a plain proc name in ANY child namespace
  2. ::foo* - all procs in the namespace foo
  3. ::foo::* - same
  4. ::foo::valid* - all procs named like this one

      if { ! [ validProc "procname" ] } { complain }

proc validProc { { name * } } {
     set namesp [ namespace children ]
     ;## if the argument was namespace aware
     if { [ regexp {::} $name ] } {
        set namesp {}
        }
     ;## if the arg was of the form ::foo*
     if { [ regexp {^(::[^:]+)\*} $name -> tmp ] } {
        set name ${tmp}::*
        }
     ;## examine all namespaces visible locally
     foreach ns $namesp {
        if { ! [ regexp {::$} $ns ] } {
           set ns ${ns}::
           }
        if { [ llength [ info commands $ns$name ] ] } {
           return 1
           }
        }
     ;## if the argument was a non-namespace proc
     if { [ llength [ info commands $name ] ] } {
        return 1
        }
     return 0
}

      set ${API}procs [ procList ]

proc procList { { globpat * } { level 1 } } {
     return [ uplevel $level info commands $globpat ]
}

       array set rev_array [ revArray array_name ]

proc revArray { { name "" } } {
     if { ! [ array exists $name ] } {
        return -code error "No array named \"$name\" in scope."
        }
     if { [ catch {
        array set local_array [ uplevel [ array get $name ] ]
        } err ] } {
        return -code error $err
        }
     set reverse [ list ]
     foreach {name value} [ array get local_array ] {
     lappend reverse $value $name
     }
     return $reverse
}

      set data [ dumpFile filename ]

proc dumpFile { { file "" } } {
     if { ! [ string length $file ] } {
        return {}
        }
     if { ! [ file exists $file ] } {
        return {}
        }
     if { [ catch { set fid [ open $file r ] } err ] } {
        return -code error $err
        }
     set size [ file size $file ]
     if { $size == 0 } {
        set size 100000
     }
     set data [ read $fid $size ]
     catch { ::close $fid }
     set data [ string trim $data ]
     return $data
}

• jobid - the jobid, and hence the subdirectory.
  

proc publicFile { jobid fname contents { format binary } { comp none } } {
     set seqpt {}
     if { [ catch {
        regexp {\d+} $jobid job
        set jobid $::RUNCODE$job
        ;## remove all blank spaces from dir and file names
        ;## and replace with underscores.
        regsub -all -- {\s+} $fname {_} fname
        ;## find out as much about the object to be written as
        ;## possible
        foreach [ list type contents ] [ varType $contents ] { break }
        ;## because sometimes a bug makes us try to copy
        ;## the *root* directory!!
        if { [ regexp {directory} $type ] } {
           set err "attempt to copy directory: '$contents' "
           append err "made in file context."
           return -code error $err
        }
        ;## determine the correct file extension intelligently
        set extension [ file extension $fname ]
        if { ! [ string length $extension ] } {
           if { [ regexp {unknown} $type ] } {
              set extension .txt
           } elseif { [ regexp {ilwd} $type ] } {
              set extension .ilwd
           } elseif { [ regexp {ligo_lw} $type ] } {
              set extension .xml
           }
        }
        ;## create the fully qualified path of the output file
        set rootname  [ file rootname [ file tail $fname ] ]
        set fname $rootname$extension
        set dir [ jobDirectory $jobid ]
        set fname [ file join $dir $fname ]
        ;## don't overwrite existing files
        bak $fname
        ;## do the real work of writing the file
        if { [ regexp {ilwd pointer} $type ] } {
           set seqpt {}
           ilwd::write2disk $jobid $fname $contents $format $comp
        ;## this can only happen in the frame API
        } elseif { [ regexp {framecpp pointer} $type ] } {
           set seqpt {}
           frame::writeFile $jobid $fname $contents
        } elseif { [ regexp {file} $type ] } {
           file copy -force -- $contents $fname
        } else {
           set fid [ open $fname w 0664 ]
           puts $fid $contents
           close $fid
           unset fid
        }
        if { [ file exists $fname ] } {
           file attributes $fname -permissions 0664
        }
     } err ] } {
        if { [ info exists fid ] } {
           if { [ catch {
              close $fid
           } err2 ] } {
              set err "$err: $err2"
           }
        }
        return -code error "[ myName ]:$seqpt $err"
     }
     return $fname
}

      if { [ validFilename filename ] } { do }

proc validFilename { { filename "" } } {
     set flag 1
     if { [ regexp {[^a-zA-Z0-9\-\_\.\~]} $filename ] } {
        set flag 0 ;## invalid filename!
        }
     set flag ;## filename is ok!
}

      pingAPI $api

proc pingAPI { api } {
     set busy    0
     set sid    {}
     set retval {}
     if { [ catch {
        set sid [ sock::open $api emergency ]
        fconfigure $sid -blocking off
        set pingkey [ key::time ]
        __t::start $pingkey
        puts $sid "$::MGRKEY {\${::API}::reply \$cid \[ pongAPI \]}"
        flush $sid
        set i 0;
        while { 1 } {
           incr i 20
           ;## if we get a response we're done
           if { [ regexp {\d{9,10}} [ gets $sid ] ] } {
              break
           } else {
              ;## how long have we been waiting?
              if { $i < 1000 } {
                 after 20
              } else {
                 ;## too long
                 set busy 1
                 break
              }
           }
        }
        set tmark [ ::__t::mark $pingkey ]
        ::__t::cancel $pingkey
        set tmark [ format "%.3f" $tmark ]
        set retval "mgr -> $api -> mgr in $tmark"
     } err ] } {
        set retval "$api API unreachable! $err"
     }
     if { $busy } {
        set host [ set ::${::LDAS_SYSTEM}($api) ]
        set status [ sock::diagnostic $host ]
        foreach { flag msg } $status { break }
        if { $flag } {
           set retval "$api API unreachable! $msg"
        } else {
           if { [ info exists retval ] } {
              if { [ regexp {unreachable} $retval ] } {
              } else {
                 set retval "$api emergency port is open but unresponsive"
              }
           }
        }
     }
     catch { ::close $sid }
     return $retval
}

proc pongAPI {} {
     return [ gpsTime ]
}

       popMsg msg win {delay}

proc popMsg { { msg "" } { win "" } { delay 2500 } } {
     global window; set window $win
     catch { [ winfo ] } errmsg
     if { [ string match invalid* $errmsg ] } {
        puts stderr $msg
        set msg {}
        }
     if { [ string length $msg ] } {
        destroy $win.mess
        frame   $win.mess       -class message \
                                -borderwidth 4 \
                                -relief raised
        label   $win.mess.label -foreground red \
                                -text $msg
        pack $win.mess.label -padx 12 -pady 12
        catch { ;## bury error if $win == ""
        place $win.mess -rely .1 -relx .25 -in $win
        }
        after $delay {
              destroy $window.mess
              }
        }
     return {}
}

proc sourceRsc { } {
     if { [ catch {
        set rscfile [ file join $::env(RUNDIR) LDASapi.rsc ]
        if { [ file exists $rscfile ] } {
           uplevel source $rscfile
        } else {
           uplevel source [ file join $::LDAS bin LDASapi.rsc ]
        }
        } err ] } {
        return -code error "Error sourcing LDASapi.rsc: $err"
        }
}

      sourceFile filename subdir

proc sourceFile { { filename "" } { subdir "" } } {
     if { ! [ string length $filename ] } {
        return -code error "sourceFile: filename not given"
        }
     if { [ string length $subdir ] } {
        set filename [ file join $subdir $filename ]
        }
     if { ! [ regexp $::LDAS $filename ] } {
        set filename [ file join $LDAS $filename ]
        }
     if { [ file exists $filename ] } {
        uplevel source $filename
        } else {
        set msg    "Tried to source:\n$filename\n"
        append msg "File not found."
        return -code error "sourceFile:\n$msg"
        }
     return {}
}

      set myname [ myName ]

proc myName { { level "-1" } } {
     if { $level > 0 } {
        return -code error "myName: called with level > 0 ($level)."
     }
     if { [ catch {
        set name [ lindex [ info level $level ] 0 ]
     } err ] } {
        set name $::API
     }
     set name
}

      set number [ randomNumber (seed) ]
Where seed is a positive integer 0 < seed < 2147483648
and the value returned is likewise.

namespace eval random {
set a1 { 1941 1860 1812 1776 1492 1215 1066 12013 };
set a2 { 1111 2222 3333 4444 5555 6666 7777   827 };
set m1 { 30903 4817 23871 16840 7656 24290 24514 15657 19102 };
set m2 { 30903 4817 23871 16840 7656 24290 24514 15657 19102 };
}

       start: bgLoop $name $code $delay
        stop: set ::bg::jobs($name,run) 0

proc bgLoop { { name NULL } { code "" } { delay 2 } } {
     if { ! [ llength [ namespace children :: bg ] ] } {
        namespace eval bg {}
        set ::bg::iterator 0
     }
     incr ::bg::iterator
     ;## register a new job if it has valid args
     if { ! [ string equal NULL $name ]      && \
            [ string length [ join $code ] ] } {
        set ::bg::jobs($name,run)   1
        set ::bg::jobs($name,code)  $code
        set ::bg::jobs($name,delay) $delay
        addLogEntry "Looping process $name started"
     }
     if { [ info exists ::bg::after ] && \
          [ lsearch [ after info ] $::bg::after ] != -1 } {
        after cancel $::bg::after
     }
     if { [ string equal NULL $name ] } {
        set dt 0
        foreach job [ array names ::bg::jobs *,run ] {
           set job [ lindex [ split $job , ] 0 ]
           if { [ string equal NULL $job ] || \
                [ string equal -1 $::bg::jobs($job,run) ] } {
              continue
           }
           ;## if the run flag == 0, unregister the job
           if { [ string equal 0 $::bg::jobs($job,run) ] } {
              foreach item [ array names ::bg::jobs $job,* ] {
                 unset ::bg::jobs($item)
              }
              addLogEntry "Looping process $job terminated"
              continue
           }
           ;## otherwise, eval!
           if { ! ($::bg::iterator % $::bg::jobs($job,delay)) } {
              set ts [ clock clicks -milliseconds ]
              if { [ catch {
                 eval $::bg::jobs($job,code)
              } err ] } {
                 set ::bg::jobs($job,run) 0
                 addLogEntry "$err ($::bg::jobs($job,code))" email
              }
              set te [ clock clicks -milliseconds ]
              set td [ expr $te - $ts ]
              set dt [ expr $dt + $td ]
              lappend data [ list $job $td ]
           }
        }
        ;## produce a timing report if required
        if { ($dt > 1000) && [ info exists ::PROFILE_BGLOOP ] && \
             [ string equal 1 $::PROFILE_BGLOOP ] } {
           addLogEntry "runtime per iteration: $dt ms ($data)" blue
        }
        set ::bg::after [ after 1000 bgLoop ]
     } else {
        ;## we are running the code block for the first time,
        ;## so we eval NOW.
        if { [ catch {
           set retval [ eval $::bg::jobs($name,code) ]
        } err ] } {
           if { [ info exists job ] } {
              set ::bg::jobs($job,run) 0
              addLogEntry "$err ($::bg::jobs($job,code))" email
           } else {
              addLogEntry "$err ('job' not defined)" email
           }
           set ::bg::after [ after 1000 bgLoop ]
           return -code error $err
        }
        set ::bg::after [ after 1000 bgLoop ]
        return $retval
     }
}

proc anonFtpToplevel { } {
     set data [ list ]
     if { [ file readable /etc/passwd ] } {
        set fid [ open /etc/passwd r ]
        set data [ read $fid ]
        close $fid
     } else {
        return -code error "[ myName ]: /etc/passwd not readable"
     }
     foreach line [ split $data "\n" ] {
        if { [ regexp {^ftp} $line ] } {
           set tmp [ split $line ":" ]
           set dir [ lindex $tmp end-1 ]
           return $dir
        }
     }
     puts stderr "[ myName ]: no anonymous ftp on this system"
     return {}
}

proc gridFtpToplevel {  } {
     set data [ list ]
     set dir  [ list ]
     if { [ file readable /etc/passwd ] } {
        set fid [ open /etc/passwd r ]
        set data [ read $fid ]
        close $fid
     } else {
        return -code error "[ myName ]: /etc/passwd not readable"
     }
     foreach line [ split $data "\n" ] {
        if { [ regexp {^grid} $line ] } {
           set tmp [ split $line ":" ]
           set dir [ lindex $tmp end-1 ]
           if { [ string length $dir ] && \
                [ info exists ::GRID_FTP_WRITABLE_SUBDIRECTORY ] } {
              set subdir $::GRID_FTP_WRITABLE_SUBDIRECTORY
              set subdir [ string trim $subdir / ]
              set dir $dir/$subdir
           }
           break
        }
     }
     if { ! [ string length $dir ] } {
        set msg "no grid ftp user found on this system.\n"
        append msg "this is ok if this system is not\n"
        append msg "supposed to be supporting grid ftp.\n"
        append msg "this error will not adversely affect\n"
        append msg "the running of LDAS unless requests\n"
        append msg "for grid ftp data transfer are made."
     } elseif { ! [ file exists $dir ] } {
        set msg "[ myName ]: grid ftp directory: '$dir' "
        append msg "not found.\nare you sure it is visible "
        append msg "from the host $::env(HOST) ?"
     } elseif { ! [ file isdirectory $dir ] } {
        set msg "[ myName ]: grid ftp directory: '$dir' "
        append msg "is not a directory."
     } elseif { ! [ file writable $dir ] } {
        set msg "[ myName ]: grid ftp directory: '$dir' "
        append msg "is not writable by user $::env(USER)"
     }
     if { [ string equal manager $::API ] && [ info exists msg ] } {
        puts stderr $msg
        set pre "$::LDAS_SYSTEM ${::API}API"
        set subject "$pre gridftp config error!"
        set msg "$pre $msg"
        addLogEntry "Subject: ${subject}; Body: $msg" email
     }
     return $dir
}

       array set opts [ expandOpts [opts] ]
     Where: opts is optional, defaulting to "opts".

proc expandOpts { { opts "opts" } } {
     set options [ list ]
     set matches [ list ]
     ;## get inputs and massage them into a
     ;## well-formed list
     set inputs [ uplevel set args ]
     regsub -all -- {\s+} $inputs { } inputs
     regexp {^\{(.+)\}$}    $inputs  -> inputs
     ;## get defaults and do the same
     set defaults [ uplevel subst \$$opts ]
     regsub -all -- {\s+} $defaults { } defaults
     ;## and GO! (trimming loose spaces from values)
     foreach { opt def } $defaults {
        set opt     [ string trim $opt  ]
        set def     [ string trim $def  ]
        set matched 0
        foreach { name val } $inputs {
           set name [ string trim $name ]
           regsub -- {[-]+} $name "-" name
           set val  [ string trim $val  ]
           if { [ regexp -nocase -- ^$name $opt ] } {
              ;## next test fails if ambiguous item is last
              ;## option on command line...
              if { [ lsearch -exact $matches $name ] > -1 } {
                 return -code error "[ myName ]: ambiguous option: \"$name\""
              }
              lappend matches $name
              set options [ concat $options [ list $opt $val ] ]
              set matched 1
              break
           }
        }
        if { $matched == 0 } {
           set options    [ concat $options [ list $opt $def ] ]
        }
     }
     return $options
}

proc metaOpts { args } {
     if { [ catch {
        set opts [ uplevel set opts ]
        array set tmp [ expandOpts ]
        set jobid $tmp(-jobid)
        #catch { unset ::$jobid }
        array set ::$jobid [ array get tmp ]
     } err ] } {
        return -code error "[ myName ]: $err"
     }
}

• vname - the name of the variable being traced
• cmd - the command to execute when the trace is triggered
• timeout - expiration interval for the trigger in seconds.
  

       traceTimeout vname doThis [ timeout ]
the argument list for command must end with "args"
to eat the arguments added by trace.


it is better for varname to be a unique name.

proc traceTimeout { { vname "" } { cmd "" } { timeout 10 } } {
     if { ! [ string length $cmd ] } {
        return {}
        }