checked in pd-0.43-0.src.tar.gz

svn path=/trunk/; revision=15557

1 files changed, 24 insertions, 16 deletions

diff --git a/pd/tcl/opt_parser.tcl b/pd/tcl/opt_parser.tcl
index d304e045..c34baf6d 100644
--- a/pd/tcl/opt_parser.tcl
+++ b/pd/tcl/opt_parser.tcl
@@ -3,35 +3,44 @@ package provide opt_parser 0.1
 namespace eval opt_parser {
     # list of option vars (keys are long option names)
     variable optlist
+    # option behavior <set|lappend>
+    variable optbehavior
     variable optprefix {-}
 }
 
 proc opt_parser::init {optdata} {
     variable optlist
-    array unset optlist
-    array set optlist {}
+    variable optbehavior
+    array unset optlist ; array set optlist {}
+    array unset optbehavior ; array set optbehavior {}
     foreach item $optdata {
-        foreach {longname varlist} $item {
-            if {[llength $varlist] < 1} {
-                return -code error "usage: init { {optname {var1 var2 ...}} ... }"
+        foreach {optName behavior varlist} $item {
+            if {[llength $varlist] < 1 || [lsearch -exact {set lappend} $behavior] == -1} {
+                return -code error "usage: init { {optname <set|lappend> {var1 var2 ...}} ... }"
             }
-            set optlist($longname) $varlist
+            set optlist($optName) $varlist
+            set optbehavior($optName) $behavior
         }
     }
 }
 
 proc opt_parser::get_options {argv {opts {}}} {
-    set ignore_unknown_flags 0
+    # second argument are internal options
+    # (like 'ignore_unknown_flags <0|1>')
     foreach {k v} $opts {set $k $v}
+    set ignore_unknown_flags 0
 
     variable optlist
+    variable optbehavior
     variable optprefix
 
     # zero all the options 1st var
     foreach optName [array names optlist] {
         uplevel [list set [lindex $optlist($optName) 0] 0]
-        for {set i 1} {$i < [llength $optlist($optName)]} {incr i} {
-            uplevel [list set [lindex $optlist($optName) $i] [list]]
+        if {$optbehavior($optName) == {lappend}} {
+            for {set i 1} {$i < [llength $optlist($optName)]} {incr i} {
+                uplevel [list set [lindex $optlist($optName) $i] [list]]
+            }
         }
     }
 
@@ -41,16 +50,15 @@ proc opt_parser::get_options {argv {opts {}}} {
     set argc [llength $argv]
     for {set i 0} {$i < $argc} {} {
         # get i-th arg
-        set argv_i [lindex $argv $i]
+        set optName [lindex $argv $i]
         incr i
 
         # if it's not an option, stop here, and add to residualArgs
-        if {![regexp ^$optprefix $argv_i]} {
-            lappend residualArgs $argv_i
+        if {![regexp ^$optprefix $optName]} {
+            lappend residualArgs $optName
             continue
         }
 
-        set optName [regsub ^$optprefix $argv_i {}]
         if {[info exists optlist($optName)]} {
             set varlist $optlist($optName)
             uplevel [list set [lindex $optlist($optName) 0] 1]
@@ -59,9 +67,9 @@ proc opt_parser::get_options {argv {opts {}}} {
             while {$n_required_opt_args > 0} {
                 incr n_required_opt_args -1
                 if {$i >= $argc} {
-                    return -code error "not enough arguments for option $optprefix$optName"
+                    return -code error "not enough arguments for option $optName"
                 }
-                uplevel [list lappend [lindex $varlist $j] [lindex $argv $i]]
+                uplevel [list $optbehavior($optName) [lindex $varlist $j] [lindex $argv $i]]
                 incr j
                 incr i
             }
@@ -70,7 +78,7 @@ proc opt_parser::get_options {argv {opts {}}} {
                 lappend residualArgs $argv_i
                 continue
             } else {
-                return -code error "unknown option: $optprefix$optName"
+                return -code error "unknown option: $optName"
             }
         }
     }