hostside/lib.tcl

   1
   2 proc manyset {list args} {
   3     foreach val $list var $args { upvar 1 $var my; set my $val }
   4 }
   5
   6 proc start_commandloop {} {
   7     commandloop -async -prompt1 { return "% " } -prompt2 { return "> " }
   8 }
   9
  10 proc fconfig-trainproto {file} {
  11     fconfigure $file -translation {auto lf} -buffering line -blocking 0
  12 }
  13
  14 proc badusage {m} {
  15     global argv0
  16     puts stderr "$argv0: bad usage: $m"
  17     exit 8
  18 }
  19
  20 proc setting {varname defvalue regexp} {
  21     upvar #0 $varname var
  22     upvar #0 settings($varname) re
  23     set var $defvalue
  24     set re $regexp
  25 }
  26
  27 proc readable {whatfor conn args} {
  28     while {[gets $conn l]>=0} { eval [list $whatfor-inputline $conn $l] $args }
  29     if {[eof $conn]} { eval [list $whatfor-eof $conn] $args }
  30 }
  31
  32 proc parse-argv {formalargs} {
  33     # formalargs: list; if list is [list *] then any is allowed
  34     # sets argv to list of non-option args
  35     # checks settings($var)
  36     global argv settings
  37     for {set i 0} {$i < [llength $argv]} {incr i} {
  38         set a [lindex $argv $i]
  39         if {[regexp {^--(\w+)\=(.*)$} $a dummy var val]} {
  40             if {[info exist settings]} {
  41                 upvar #0 settings($var) re
  42                 if {![info exists re]} {
  43                     badusage "unknown variable setting --$var=..."
  44                 }
  45                 if {![regexp -- "^$re\$" $val]} {
  46                     badusage "bad value for setting $var"
  47                 }
  48             }
  49             upvar #0 $var varset
  50             set varset $val
  51         } elseif {[regexp {^--$} $a]} {
  52             incr i
  53             break
  54         } elseif {[regexp {^-} $a]} {
  55             badusage "unknown command line option $a"
  56         } else {
  57             break
  58         }
  59     }
  60     set argv [lrange $argv $i end]
  61     if {[llength $formalargs]==1 && [string compare * [lindex $formalargs 0]] \
  62             && [llength $formalargs] != [llength $argv]} {
  63         if {![llength $formalargs]} {
  64             badusage "no non-option arguments expected"
  65         } else {
  66             badusage "needed non-option arguments: [concat $formalargs]"
  67         }
  68     }
  69 }
  70
  71 proc get-unique {prefix} {
  72     upvar #0 unique_ix($prefix) ix
  73     if {![info exists ix]} { set ix 0 }
  74     return "$prefix[incr ix]"
  75 }
  76
  77 proc addexpr {varname expr} {
  78     set add [uplevel 1 [list expr $expr]]
  79     upvar 1 $varname var
  80     if {![info exists var]} { set var 0 }
  81     set var [expr {$var + $add}]
  82 }
  83
  84 proc setexpr {varname expr} {
  85     upvar 1 $varname var
  86     set var [uplevel 1 [list expr $expr]]
  87 }
  88
  89 proc defset {varname val} {
  90     upvar 1 $varname var
  91     if {[info exists var]} return
  92     set var $val
  93 }
  94
  95 setting port 2883 {\d+}
  96