args.tcl

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