--- foxTypedOpts.tcl.orig Sat Feb 19 19:46:50 1994 +++ foxTypedOpts.tcl Thu Mar 18 16:15:13 1999 @@ -80,9 +80,8 @@ # typedopts several times with different s without losing the # information from previous calls. # -# if typedopts can't parse its options for any reason, it will print an -# error message to stderr and return a -1 without modifying any other -# variables. +# if typedopts can't parse its options for any reason, it return an +# error message without modifying any other variables. # # EXAMPLE: # @@ -157,8 +156,7 @@ # Initial revision # -proc typedopts { args } { - +namespace eval foxOpts { proc abbr { s1 s2 } { if { [ set len [ string length $s1 ]] } then { if { ! [ string compare $s1 [ string range $s2 0 [ expr $len - 1 ]]] } then { @@ -298,8 +296,7 @@ return 1 } default { - puts stderr "Eek! Option type <$otype> not supported yet!" - set var "isn't a supported type." + set var "<$otype> isn't a supported type." return 0 } } @@ -315,54 +312,52 @@ "floats" - "strings" { if { [ llength $optlist ] } then { - puts stderr "typedopts: Type $type doesn't take arguments" - return "" + return -code error "typedopts: Type $type doesn't take arguments" } return [ string index $type 0 ] } "one-of" { if { ! [ llength $optlist ] } then { - puts stderr "typedopts: No arguments given to type $type" - return "" + return -code error "typedopts: No arguments given to type $type" } return [ concat [ string index $type 0 ] $optlist ] } "list-of" - "multiple" { if { ! [ llength $optlist ] } then { - puts stderr "typedopts: No arguments given to type $type" - return "" - } - if { ! [ string length [ set subtype [ parseOption $optlist ]]] } then { - return "" + return -code error "typedopts: No arguments given to type $type" } + if [catch {parseOption $optlist} subtype] { + return -code error $subtype + } return [ concat [ string index $type 0 ] $subtype ] } default { - puts stderr "typedopts: Unknown option type $type" - return "" + return -code error "typedopts: Unknown option type $type" } } } +} + +proc typedopts { args } { set doinit 1 if { [ llength $args ] < 5 } then { - puts stderr "typedopts: bad number of arguments." - return -1 + return -code error "typedopts: bad number of arguments." } - set args [ extract $args arglist optlist optret argret restret ] + set args [ foxOpts::extract $args arglist optlist optret argret restret ] while { [ llength $args ] } { - set opt [ shift args ] - switch -exact [ findabbr { -noinitialize } $opt ] { + set opt [ foxOpts::shift args ] + switch -exact [ foxOpts::findabbr { -noinitialize } $opt ] { -noinitialize { set doinit 0 } default { - puts stderr "typedopts: bad option \"$opt\": should be -noinitialize or --" - return -1 + return -code error \ + "typedopts: bad option \"$opt\": should be -noinitialize or --" } } } @@ -380,16 +375,15 @@ if { [ string length $type ] } then { foreach arg $word { if { [ lsearch -exact $arg $allopts ] > -1 } then { - puts stderr "typedopts: option -$arg multiply declared." - return -1 + return -code error "typedopts: option -$arg multiply declared." } lappend allopts $arg set opttype($arg) $type } set type "" } else { - if { ! [ string length [ set type [ parseOption $word ]]] } then { - return -1 + if [catch {foxOpts::parseOption $word} type] then { + return -code error $type } } } @@ -408,7 +402,7 @@ while { [ llength $arglist ] } { switch -glob -- $arglist { -- { - shift arglist + foxOpts::shift arglist break } -* { @@ -417,10 +411,10 @@ break } } - set opt [ string range [ shift arglist ] 1 end ] - if { [ string length [ set fnd [ findabbr $allopts $opt ]]] } then { + set opt [ string range [ foxOpts::shift arglist ] 1 end ] + if { [ string length [set fnd [foxOpts::findabbr $allopts $opt]]] } then { set type $opttype($fnd) - if { [ parseOptionType $opttype($fnd) arglist arg ] } then { + if { [ foxOpts::parseOptionType $opttype($fnd) arglist arg ] } then { if { $_opts($fnd) && ! [ string match "m*" $type ] } then { set _args(_ERROR_) "Found multiple occurrences of option -$fnd" set retval 0