args.tcl

   1
   2 namespace eval args {
   3
   4 proc badusage {msg} {
   5     puts stderr "bad usage: $msg"
   6     exit 12
   7 }
   8
   9 proc badoption {} {
  10     variable lastarg
  11     badusage "unknown option $lastarg"
  12 }
  13
  14 proc next {} {
  15     global argv
  16     variable lastarg
  17     if {![llength $argv]} { badusage "$lastarg needs a value" }
  18     set arg [lindex $argv 0]
  19     set argv [lrange $argv 1 end]
  20     set lastarg $arg
  21 }
  22
  23 proc next_num {} {
  24     set arg [next]
  25     variable lastarg
  26     if {[catch { eval {$arg + 0} } emsg]} {
  27         badusage "$lastargv value must be a number ($emsg)"
  28     }
  29 }
  30
  31 proc generalarg {arg} {
  32     switch -exact -- $arg {
  33         -width { set applet::w [next_num] }
  34         -height { set applet::h [next_num] }
  35         -horizontal - -vertical { set applet::deforient $arg }
  36         -borderColour - -borderColor { set applet::border_colour [next] }
  37         -borderWidth { set applet::border_width [next_num] }
  38         -debug { applet::setup-debug puts }
  39         default { return 0 }
  40     }
  41     return 1
  42 }
  43
  44 proc more {} {
  45     global argv
  46     if {![llength $argv]} { return 0 }
  47     if {![regexp {^-} [lindex $argv 0]]} { return 0 }
  48     return 1
  49 }
  50
  51 proc next_special {va} {
  52     upvar 1 $va arg
  53     global argv
  54     while {[more]} {
  55         set arg [next]
  56         if {[generalarg $arg]} continue
  57         return 1
  58     }
  59     return 0
  60 }
  61
  62 }