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 {msg} {
  10     variable lastarg
  11     badusage "unknown option $msg"
  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 set w 50
  32 set h 50
  33 set orientation horizontal
  34 set bc darkblue
  35 set bw 1
  36
  37 proc generalarg {} {
  38     switch -exact $arg {
  39         -width { set w [next_num] }
  40         -height { set h [next_num] }
  41         -horizontal - -vertical { set orientation $arg }
  42         -borderColour - -borderColor { set bc [next] }
  43         -borderWidth { set bw [next_num] }
  44         default { return 0 }
  45     }
  46     return 1
  47 }
  48
  49 proc more {} {
  50     global argv
  51     if {![llength $argv]} { return 0 }
  52     if {![regexp {^-} [lindex $argv 0]]} { return 0 }
  53     return 1
  54 }
  55
  56 proc next_special {va} {
  57     upvar 1 $va arg
  58     global argv
  59     while {[more]} {
  60         set arg [next]
  61         if {[generalarg $arg]} continue
  62         return 1
  63     }
  64     return 0
  65 }
  66
  67 }