From 22a829cb1907c79bfe68ad91314a1dddbf1beeb3 Mon Sep 17 00:00:00 2001
From: Miller Puckette <millerpuckette@users.sourceforge.net>
Date: Tue, 1 Sep 2009 18:22:23 +0000
Subject: merge in HC's new tcl code and start taking patches

svn path=/trunk/; revision=12166
---
 pd/tcl/opt_parser.tcl | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)
 create mode 100644 pd/tcl/opt_parser.tcl

(limited to 'pd/tcl/opt_parser.tcl')

diff --git a/pd/tcl/opt_parser.tcl b/pd/tcl/opt_parser.tcl
new file mode 100644
index 00000000..d304e045
--- /dev/null
+++ b/pd/tcl/opt_parser.tcl
@@ -0,0 +1,78 @@
+package provide opt_parser 0.1
+
+namespace eval opt_parser {
+    # list of option vars (keys are long option names)
+    variable optlist
+    variable optprefix {-}
+}
+
+proc opt_parser::init {optdata} {
+    variable optlist
+    array unset optlist
+    array set optlist {}
+    foreach item $optdata {
+        foreach {longname varlist} $item {
+            if {[llength $varlist] < 1} {
+                return -code error "usage: init { {optname {var1 var2 ...}} ... }"
+            }
+            set optlist($longname) $varlist
+        }
+    }
+}
+
+proc opt_parser::get_options {argv {opts {}}} {
+    set ignore_unknown_flags 0
+    foreach {k v} $opts {set $k $v}
+
+    variable optlist
+    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]]
+        }
+    }
+
+    # here will be appended non-options arguments
+    set residualArgs {}
+
+    set argc [llength $argv]
+    for {set i 0} {$i < $argc} {} {
+        # get i-th arg
+        set argv_i [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
+            continue
+        }
+
+        set optName [regsub ^$optprefix $argv_i {}]
+        if {[info exists optlist($optName)]} {
+            set varlist $optlist($optName)
+            uplevel [list set [lindex $optlist($optName) 0] 1]
+            set n_required_opt_args [expr {-1+[llength $varlist]}]
+            set j 1
+            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"
+                }
+                uplevel [list lappend [lindex $varlist $j] [lindex $argv $i]]
+                incr j
+                incr i
+            }
+        } else {
+            if {$ignore_unknown_flags} {
+                lappend residualArgs $argv_i
+                continue
+            } else {
+                return -code error "unknown option: $optprefix$optName"
+            }
+        }
+    }
+    return $residualArgs
+}
-- 
cgit v1.2.1