EventLoop
are_arrays_identical
array_to_keyed_list
calculate_ratio_of_month_left
copy_array
day_month_calculations
days_in_month
die
dollar_format
fail_exit
force_width
getargs
keyed_list_to_array
load_stanza_file
next_month_year
parse_rfc822_line
parse_rfc822_mail_address
parse_stanza_line
prompt
prompt_choices
prompt_yn
read_rfc822
read_rfc822_group
read_stanza_body
read_stanza_file
read_stanza_header
require
rfc931
save_stanza_file
spawn_child
store_stanza_field
write_rfc822
write_rfc822_group
write_stanza
xkeylget
EventLoop - an [incr tcl] class
EventLoop object -selectTimeout 10 -timeoutCallout {}
inherits
object make_select_list
object run
object stop
object add_trigger
file command
object remove_trigger
file
#@package: EventLoop EventLoop # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. ### # # # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # Incr Tcl Event Loop class. # # For use with Extended Tcl, but not Wishx, which has its # own mechanism (addinput). A functionally identical EventLoop # class for Wishx would be really nice. # constructor {config} { } destructor { } # make a list containing the file handles of all the sockets, # pipes, fifos, etc, we are waiting for data from. method make_select_list {} { set readSelectList [array names readSelectorCallouts] } # # run an event loop, waiting for input from any of the file handles # we've been told to look at, and calling the timeoutCallout, # if it exists, every selectTimeout floating point seconds. # method run {} { set running 1 make_select_list while {$running} { set selectResult [select $readSelectList "" "" $selectTimeout] set readReadyList [lindex $selectResult 0] if {$readReadyList == ""} { eval $timeoutCallout } foreach readReady $readReadyList { set command $readSelectorCallouts($readReady) if {[gets $readReady line] < 0} { close $readReady continue } [lindex $command 0] [lindex $command 1] $line } } } # stop the event loop after the event that invoked this method # finishes method stop {} { set running 0 } # add a trigger whereby data on the specified filehandle causes # command to execute method add_trigger {file command} { set readSelectorCallouts($file) $command } # remove the trigger on the specified filehandle method remove_trigger {file} { unset readSelectorCallouts($file) } # true while the event loop is running protected running 0 # array where keys are file handles and data are commands to execute protected readSelectorCallouts # list of file handles to select on as a list protected readSelectList # timeout interval, default 10 seconds public selectTimeout 10 # timeout callout code, default is to do nothing public timeoutCallout ""
are_arrays_identical
are_arrays_identical array1Name array2Name
# # Return true if two arrays are identical, else false. # upvar $array1Name array1 $array2Name array2 # if they don't have the same number of elements, no way are they identical if {[array size array1] != [array size array2]} {return 0} # For each element in the first array, # If the element isn't in the second array, they're not identical. # If the contents of both elements aren't the same, the arrays aren't # identical. # If you get to the end, the arrays are identical. set searchId [array startsearch array1] while {[array anymore array1 $searchId]} { set elementName [array nextelement array1 $searchId] if ![info exists array2($elementName)] {return 0} if {$array1($elementName) != $array2($elementName)} { return 0 } } array donesearch sourceArray $searchId return 1
array_to_keyed_list
array_to_keyed_list arrayName
# # Convert an array to a keyed list. Only handles "flat" keyed lists. # upvar $arrayName array set list "" foreach key [array names array] { keylset list $key $array($key) } return $list
calculate_ratio_of_month_left
calculate_ratio_of_month_left month day year
# # What is the floating point ratio of days left from the specified # day, in the specified month, of the specified year? # set daysInThisMonth [days_in_month $month $year] set daysLeftInThisMonth [expr $daysInThisMonth - $day + 1] return [expr $daysLeftInThisMonth.0/$daysInThisMonth]
copy_array
copy_array sourceArrayName destArrayName
#@package: array_utilities copy_array array_to_keyed_list keyed_list_to_array are_arrays_identical # # Array Utility Functions # # # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # Copy the contents of one array into another. # upvar $sourceArrayName sourceArray $destArrayName destArray set searchId [array startsearch sourceArray] while {[array anymore sourceArray $searchId]} { set elementName [array nextelement sourceArray $searchId] set destArray($elementName) sourceArray($elementName) } array donesearch sourceArray $searchId
day_month_calculations
day_month_calculations clock thisMonthVar thisYearVar daysInThisMonthVar daysLeftInThisMonthVar ratioLeftVar nextMonthMonthVar nextMonthYearVar
# # Given a integer-seconds-since-1970 and the names of some variables, # return in those variables the month number (1-12), the year number, # the days in the current month (28-31), the days left in this month, # the ratio of days left in the month, the month number (1-12) of # the month following this date's month, and the year number of the month # following this date's month. # upvar $thisMonthVar thismonth upvar $thisYearVar thisyear upvar $daysInThisMonthVar daysInThisMonth upvar $daysLeftInThisMonthVar daysLeftInThisMonth upvar $ratioLeftVar ratioLeft upvar $nextMonthMonthVar nextmonth upvar $nextMonthYearVar nextyear lassign [fmtclock $clock "%m %d %Y"] thismonth thisday thisyear scan $thismonth %d thismonth scan $thisday %d thisday next_month_year $thismonth $thisyear nextmonth nextyear set monthStartSeconds [convertclock $nextmonth/1/$nextyear] set daysInThisMonth [days_in_month $thismonth $thisyear] set daysLeftInThisMonth [expr $daysInThisMonth - $thisday + 1] set ratioLeft [expr $daysLeftInThisMonth.0/$daysInThisMonth]
days_in_month
days_in_month month year
# # How many days are in the specified month, in the specified year? # switch $month { 1 {return 31} 2 { if {$year % 4 == 0} { return 29 } else { return 28 } } 3 {return 31} 4 {return 30} 5 {return 31} 6 {return 30} 7 {return 31} 8 {return 31} 9 {return 30} 10 {return 31} 11 {return 30} 12 {return 31} } error "month out of range ($month)"
die
die message {exitStatus 1}
puts stderr $message exit $exitStatus
dollar_format
dollar_format number
# # format a number and return it as a dollar field (two digits precision # to the right of the decimal place.) # return [format "%.2f" $number]
fail_exit
fail_exit command {exitStatus 1}
#@package: catchers fail_exit die # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # fail_exit command [exitStatus] # execute command and, if it gets a tcl error, write the program # name and error message to stderr and exit the program. # If exit is taken, exit status is 1 unless specified. # if {[catch {uplevel $command} result] == 1} { global argv0 puts stderr "$argv0: $result" exit $exitStatus }
force_width
force_width string width
#@package: neo_misc_procs force_width dollar_format # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # return a string forceed to a specified width either by padding, if it # is too short, or by truncation, if it is too long. # return [crange [format "%-${width}s" $string] 0 $width-1]
getargs
getargs arrayName argList
#@package: getargs getargs # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # parses an arglist of key-value pairs where the key starts with a # dash and the value must always be present. # # we want to use it in this manner # # dialog_box -bitmap @/bitmap -text "hi there" -suppress 1 # # in dialog_box, # # proc dialog_box {blah blah blah args} {} comment {# getargs $args parms} comment {# } # # and have the parms array set as follows: # # bitmap=@/bitmap # text="hi there" # suppress="1" # # upvar $arrayName array set length [llength $argList] if {$length % 2 != 0} { error "list of key-value pairs is missing a value" } for {set i 0} {$i < $length} {incr i 2} { set key [lindex $argList $i] if {[cindex $key 0] != "-"} { error "key '$key' of key-value pairs doesn't start with '-'" } set array([crange $key 1 end]) [lindex $argList [expr $i + 1]] }
keyed_list_to_array
keyed_list_to_array list arrayName
# # Convert a keyed list to an array. Only handles "flat" keyed lists. # upvar $arrayName array foreach key [keylkeys list] { set array($key) [keylget list $key] }
load_stanza_file
load_stanza_file fileName arrayVarName
# # load_stanza_file and save_stanza_file work differently from the # above. these guys read the stanza bodies into keyed lists indexed # by the header names through an array # # # # load_stanza_file # # load in a stanza file where the stanza headers becomne array names # and the bodies become keyed lists # # slight optimization hack was to append up the list instead of # keylsetting it, don't know if that really helped or not # upvar $arrayVarName stanzaArray set fp [open $fileName] while 1 { if {[read_stanza_header $fp section] == 0} { close $fp return } set keyedList "" while {[gets $fp line] >= 0} { if ![parse_stanza_line $line key value] break lappend keyedList "$key $value" } set stanzaArray($section) $keyedList }
next_month_year
next_month_year currentMonth currentYear nextMonthVar nextMonthYearVar
#@package: timedate-utility next_month_year days_in_month calculate_ratio_of_month_left day_month_calculations # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # Time/Date utility functions # # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # # # given the current month and year and the names of two variables, # put in the first the numeric month following this one and in the # second, the year of that month. # upvar $nextMonthVar nextMonth upvar $nextMonthYearVar nextMonthYear set nextMonthYear $currentYear set nextMonth $currentMonth if {$nextMonth < 12} { incr nextMonth } else { set nextMonth 1 incr nextMonthYear }
parse_rfc822_line
parse_rfc822_line line keyVar valueVar
#@package: rfc822 parse_rfc822_line read_rfc822_group read_rfc822 write_rfc822_group write_rfc822 parse_rfc822_mail_address # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # we really need to rewrite this in C and be truly RFC-822 compliant, # it's a pig. # # RFC noncompliance issues: Line order isn't maintained, multiple # lines with the same key aren't supported. # There may be stuff in there about quoting, too. # # # parse_rfc822_line # # Given a line of RFC822 header text and the names of two variables, # parse the key into one and the value into the other. # # Warning, can't do multiple line messages unless line argument contains # all necessary lines. # # upvar $keyVar key upvar $valueVar value set key "" set colon [string first ":" $line] if {$colon < 2} { return 0 } set key [string trim [string range $line 0 [expr $colon-1]]] set value [string trim [string range $line [expr $colon+1] end]] return 1
parse_rfc822_mail_address
parse_rfc822_mail_address line emailAddressVar fullNameVar
# # parse_rfc822_mail_address # # take the body of an address line and convert it into a name and address # upvar $emailAddressVar emailAddress upvar $fullNameVar fullName # in the form "Ellyn Jones <ellyn@NeoSoft.com>"? if {[regexp {(.*) <(.*)>} $line dummy fullName emailAddress]} { set emailAddress [string tolower $emailAddress] return } # in the form "ellyn@NeoSoft.com (Ellyn Jones)"? if {[regexp {(.*) \((.*)\)} $line dummy emailAddress fullName]} { set emailAddress [string tolower $emailAddress] return } # hmm, take whatever's there as the reply address set emailAddress [string tolower $line] set fullName $emailAddress
parse_stanza_line
parse_stanza_line line keyVarName dataVarName
# parse_stanza_line # # given a line and the names of key and value variables, put # the key and value in variables and return 1, else 0 or error # upvar $keyVarName key upvar $dataVarName value if {[string trim $line] == ""} {return 0} if {[cindex $line 0] == "\["} { error "called parse_stanza_line with a header line '$line'" } set separator [string first "=" $line] if {$separator < 2} { error "malformed stanza line '$line'" } set key [string trim [string range $line 0 [expr $separator-1]]] set value [string trim [string range $line [expr $separator+1] end]] return 1
prompt
prompt promptText varName {default ""}
#@package: prompts prompt prompt_yn prompt_choices # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # prompt - given some prompt text, the name of a variable, and a possible # default value, emit the text, read a line into the named variable and, # if an empty string is entered, use the default instead, and set the # result into the named variable. # upvar $varName line set line "" if {$default == ""} { puts stdout "$promptText: " nonewline } else { puts stdout "$promptText \[$default\]: " nonewline } if {[gets stdin line] < 0} return if {$line == ""} { set line $default }
prompt_choices
prompt_choices promptText choiceList {default ""}
# # prompt_choices - emit some prompt text and get a selection of one # of a number of responses. # while 1 { set nChoices 0 echo $promptText foreach element $choiceList { echo " $nChoices $element" incr nChoices } prompt "Your selection?" input $default if {([catch {set choice [lindex $choiceList $input]} result] == 1) || ($choice == "" && $default != "")} { echo "Please enter a number between 1 and $nChoices." continue } if {$choice == ""} {return $default} return $choice }
prompt_yn
prompt_yn promptText {default ""}
# # prompt_yn - emit some prompt text and get a yes or no response, # returning 1 for yes and 0 for no. # while 1 { if {$default == ""} { puts stdout "$promptText (y/n): " nonewline } else { puts stdout "$promptText (y/n) \[$default\]: " nonewline } if {[gets stdin line] < 0} return if {$line == ""} {set line $default} set char [string tolower [cindex $line 0]] if {$char == "n"} {return 0} if {$char == "y"} {return 1} echo "Please answer y)es or n)o" }
read_rfc822
read_rfc822 fileName arrayVarName
# # read_rfc822 # # load in a file containing one rfc822 group # upvar $arrayVarName rfcArray set fp [open $fileName] read_rfc822_group $fp rfcArray close $fp
read_rfc822_group
read_rfc822_group fp arrayVarName
# # read_rfc822_group # # given a filehandle and an array name, read the file, pulling key-value # pairs and putting them into the named array, returning when an empty # line or EOF is found # # upvar $arrayVarName rfcArray set success 0 while {[gets $fp line] >= 0} { if {$line == ""} break set firstchar [cindex $line 0] if {$firstchar == " " || $firstchar == "\t"} { if {$key != ""} { append rfcArray($key) "\n$line" } else { puts stderr "rfc-822 line starts with whitespace with no prior key '$line'" } continue } set key "" set colon [string first ":" $line] if {$colon < 2} { puts stderr "malformed rfc-822 line '$line'" } set success 1 set key [string trim [string range $line 0 [expr $colon-1]]] set value [string trim [string range $line [expr $colon+1] end]] set rfcArray($key) $value } return $success
read_stanza_body
read_stanza_body fp arrayVarName
# read_stanza_body # # given a filehandle and an array name, read the file, pulling key-value # pairs and putting them into the named array, returning when an empty # line or EOF is found # # upvar $arrayVarName stanzaArray set success 0 while {[gets $fp line] >= 0} { if ![parse_stanza_line $line key value] break set success 1 set stanzaArray($key) $value } return $success
read_stanza_file
read_stanza_file fileName arrayVarPrefix {global ""}
set upLevel "2" if {$global != ""} {set upLevel "#0"} set fp [open $fileName] while 1 { if {[read_stanza_header $fp section] == 0} { close $fp return } store_stanza_field $arrayVarPrefix$section $upLevel ID $section while {[gets $fp line] >= 0} { if ![parse_stanza_line $line key value] break store_stanza_field $arrayVarPrefix$section $upLevel $key $value } }
read_stanza_header
read_stanza_header fp headerVarName
#@package: stanza read_stanza_header read_stanza_body read_stanza_file load_stanza_file write_stanza save_stanza_file # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # we really need to rewrite this in C and be truly stanza compliant, # it's kind of a pig. # # stanza noncompliance issues: lots # # seems to work, though. # # read_stanza_header # # given a filehandle and an array name, read the file, pulling key-value # pairs and putting them into the named array, returning when an empty # line or EOF is found # # upvar $headerVarName headerVar if {[gets $fp line] <= 0} {return 0} if {[string index $line 0] != "\["} { error "malformed stanza file - no '[' in header" } if {[cindex $line [clength $line]-1] != "]"} { error "malformed stanza file - no ']' in header" } set headerVar [crange $line 1 [clength $line]-2] return 1
require
require commandName
#@package: libmanager require # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # This little thing will force the autoloading of the specified command, # without actually executing it. # # already loaded? if {[info commands $commandName] != ""} return # get it if ![auto_load $commandName] { error "couldn't auto_load $commandName" }
rfc931
rfc931 fp resultVar
#@package: rfc931 rfc931 # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # Perform an rfc931 authentication request on the socket bound to the # specified filehandle. Returns username and hostname if found, # username and ip if no hostname is found, or an empty string if # the remote site isn't running an rfc931 authentication server. # # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # upvar $resultVar result lassign [fstat $fp localhost] localAddr localPort lassign [fstat $fp remotehost] remoteAddr remotePort if {[catch {lassign [server_open -myip $localAddr $remoteAddr ident] readIdent writeIdent} result] == 1} { global errorCode errorInfo if {[lindex $errorCode 1] == "ECONNREFUSED"} {return 0} error $result $errorInfo $errorCode } set remoteName [server_info address_name $remoteAddr] puts $writeIdent "$remotePort,$localPort\r" close $writeIdent if {[gets $readIdent authLine] < 0} { close $readIdent set result "read failed" return 0 } set result $authLine if {[scan $authLine {%u , %u : USERID :%*[^:]:%s} remote local user] != 3} { close $readIdent return 0 } if {$remote != $remotePort || $local != $localPort} { close $readIdent set result "ports didn't match" return 0 } if {[cindex $user end] == "\r"} { set user [crange $user 0 end-1] } set result $user@$remoteName close $readIdent return 1
save_stanza_file
save_stanza_file fileName arrayVarPrefix {global ""}
# # save_stanza_file # # save a stanza file where the stanza headers come from an array's keys # and the bodies are from keyed lists indexed by the keys # set upVar "1" if {$global != ""} {set upVar "#0"} set varPrefixLength [string length $arrayVarPrefix] set fp [open $fileName w] foreach arrayVarName [uplevel $upVar "info vars $arrayVarPrefix*"] { upvar $upVar $arrayVarName stanzaArray set setName [string range $arrayVarName $varPrefixLength end] puts $fp "\[$setName\]" foreach key [array names stanzaArray] { if {[cindex $key 0] != "_"} { puts $fp "$key=$stanzaArray($key)" } } puts $fp "" } close $fp
spawn_child
spawn_child command stdinPipeVarName stdoutPipeVarName stderrPipeVarName
#@package: spawn_child spawn_child # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # spawn_child - fork a tcl subprocess, redirecting standard input, # output and error to pipes. # # Three variable names are specified. # Within those variables spawn_child writes the filehandles of pipes that # correspond to standard input, standard output and standard error of # the subprocess. # upvar $stdinPipeVarName stdinPipe $stdoutPipeVarName stdoutPipe $stderrPipeVarName stderrPipe pipe childStdinPipe stdinPipe pipe stdoutPipe childStdoutPipe pipe stderrPipe childStderrPipe if {[set childPid [fork]] == 0} { dup $childStdinPipe stdin close $childStdinPipe dup $childStdoutPipe stdout close $childStdoutPipe dup $childStderrPipe stderr close $childStderrPipe eval "execl $command" } return $childPid
store_stanza_field
store_stanza_field varName upLevel key value
upvar $upLevel $varName myArray set myArray($key) $value
write_rfc822
write_rfc822 fileName arrayVarName
# # write_rfc822 # # write out a file containing one rfc822 group # upvar $arrayVarName rfcArray set fp [open $fileName w] write_rfc822_group $fp rfcArray close $fp
write_rfc822_group
write_rfc822_group fp arrayVarName
# # write_rfc822_group # # given a filehandle and an array name, write the file, pulling key-value # pairs from the named array, returning when finished. # # upvar $arrayVarName rfcArray foreach name [array names rfcArray] { set data [split $rfcArray($name) "\n"] puts $fp "$name: [lindex $data 0]" foreach additionalLine [lrange $data 1 end] { puts $fp "\t$additionalLine" } } puts $fp ""
write_stanza
write_stanza fp headerName arrayVarName
# # write_stanza # # given a filehandle, an array name containing stanza elements # and a stanza header name, write it out # # upvar $arrayVarName stanzaArray puts $fp "\[$headerName\]" foreach name [array names stanzaArray] { puts $fp "$name=$rfcArray($name)" } puts $fp ""
xkeylget
xkeylget keylistName args
# # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # $Id: neolib.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # #@package: xkeylget xkeylget upvar $keylistName keylist if {[llength $args] % 2 != 0} {error "odd number of key-varname pairs"} while {$args != ""} { set elementName [lindex $args 0] set varName [lindex $args 1] set args [lrange $args 2 end] keylget keylist $elementName value uplevel set $varName [list $value] }