Attachment "cmdline.patch" to
ticket [3584575fff]
added by
amitguptainn
2013-05-15 08:26:46.
==== //depot/users/amit/lib/public/tcllib/cmdline/cmdline.tcl#7 (text) - //depot/users/amit/lib/public/tcllib/cmdline/cmdline.tcl#1 (text) ==== content
@@ -14,9 +14,8 @@
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
package require Tcl 8.2
+package require fileutil 1.14.4
+package provide cmdline 1.3.3
-package provide cmdline 1.3.3
namespace eval ::cmdline {
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
getKnownOptions usage
@@ -453,7 +452,6 @@
variable dummy
regexp -- {must be (.+)$} $charclasses dummy charclasses
regsub -all -- {, (or )?} $charclasses {|} charclasses
- set charclasses "$charclasses|file|dir"
unset dummy
}
@@ -590,7 +588,7 @@
set retvar $opt
set argsList [lrange $argsList 1 end]
- } elseif {[regexp -- "\\.(arg|$charclasses|{.*})\$" $opt dummy charclass]
+ } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
if {[string equal arg $charclass]} {
set type arg
@@ -601,7 +599,7 @@
}
set argsList [lrange $argsList 1 end]
- set opt [lindex [split $opt . ] 0 ]
+ set opt [file rootname $opt]
while {1} {
if {[llength $argsList] == 0
@@ -639,29 +637,6 @@
set retval -2
}
set quantifier ""
- } elseif { (($type == "oneof")
- && ([regexp {\{.*\}} $charclass dummy ] ==1 ))} {
- if { [ eval regexp $charclass [lindex $argsList 0] dummy ] == 1 } {
- set retval 1
- set retvar $opt
- lappend optarg [lindex $argsList 0]
- } else {
- set retval -4
- set retvar $opt
- set optarg "Option requires value matching $charclass pattern"
- }
- set argsList [lrange $argsList 1 end]
- } elseif { (($type == "class")
- && ([string equal "dir" $charclass ] || [string equal file $charclass ]))} {
- if { [ ::fileutil::test [lindex $argsList 0] [list exists $charclass] optarg ] } {
- set retval 1
- set retvar $opt
- lappend optarg [lindex $argsList 0]
- } else {
- set retval -4
- set retvar $opt
- }
- set argsList [lrange $argsList 1 end]
} elseif {($type == "arg")
|| (($type == "oneof")
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
@@ -777,11 +752,6 @@
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
}
- if {[regsub -- {\.must$} $name {} name] == 1} {
- # Remove this extension before passing to typedGetopt.
- regsub -- {\..*$} $name {} temp
- set must($temp) 1
- }
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
@@ -801,8 +771,7 @@
}
set argc [llength $argv]
while {[set err [typedGetopt argv $opts opt arg]]} {
- switch $err {
- 1 {
+ if {$err == 1} {
if {[info exists result($opt)]
&& [info exists multi($opt)]} {
# Toggle boolean options or append new arguments
@@ -810,29 +779,17 @@
if {$arg == ""} {
unset result($opt)
} else {
- set result($opt) [concat $result($opt) $arg]
+ set result($opt) "$result($opt) $arg"
}
} else {
- set result($opt) [list $arg]
+ set result($opt) "$arg"
}
- }
- -1 {
- error [typedUsage $optlist "ERROR:: \"-$opt\" Invalid option $arg \n $usage"]
- }
- -3 {
- error [typedUsage $optlist "ERROR:: Argument to a valid option \"-$opt\" does not match type $arg \n $usage"]
- }
- -4 {
- error [typedUsage $optlist "ERROR:: Argument to a valid option \"-$opt\" $arg \n $usage"]
- }
- -2 {
- if { ![info exists defaults($opt)] } {
- error [typedUsage $optlist "ERROR:: Missing argument to a valid option \"-$opt\" $arg \n $usage"]
+ } elseif {($err == -1) || ($err == -3)} {
+ error [typedUsage $optlist $usage]
+ } elseif {$err == -2 && ![info exists defaults($opt)]} {
+ error [typedUsage $optlist $usage]
}
}
- }
- }
-
if {[info exists result(?)] || [info exists result(help)]} {
error [typedUsage $optlist $usage]
}
@@ -841,11 +798,6 @@
set result($opt) $dflt
}
}
- foreach opt [array names must ] {
- if { ! [ info exists result($opt) ] } {
- error [typedUsage $optlist "$opt is must parameter"]
- }
- }
return [array get result]
}
@@ -863,7 +815,8 @@
proc ::cmdline::typedUsage {optlist {usage {options:}}} {
variable charclasses
- set str "[getArgv0]: $usage\n"
+
+ set str "[getArgv0] $usage\n"
foreach opt [concat $optlist \
{{help "Print this message"} {? "Print this message"}}] {
set name [lindex $opt 0]
@@ -871,17 +824,14 @@
# Hidden option
} else {
- if {[regsub -- {\.must$} $name {} name] == 1} {
- # Display something about must options
- }
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Display something about multiple options
}
- if {[regexp -- "\\.(arg|$charclasses|{.*})\$" $name dummy charclass]
+ if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
regsub -- "\\..+\$" $name {} name
- set comment [lindex $opt end]
+ set comment [lindex $opt 2]
set default "<[lindex $opt 1]>"
if {$default == "<>"} {
set default ""
@@ -889,7 +839,7 @@
append str [format " %-20s %s %s\n" "-$name $charclass" \
$comment $default]
} else {
- set comment [lindex $opt end]
+ set comment [lindex $opt 1]
append str [format " %-20s %s\n" "-$name" $comment]
}
}
@@ -914,19 +864,19 @@
proc ::cmdline::prefixSearch {list pattern} {
# Check for an exact match
- if {[set pos [::lsearch -nocase -exact $list $pattern]] > -1} {
+ if {[set pos [::lsearch -exact $list $pattern]] > -1} {
return $pos
}
# Check for a unique short version
set slist [lsort $list]
- if {[set pos [::lsearch -nocase -glob $slist $pattern*]] > -1} {
+ if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
# What if there is nothing for the check variable?
set check [lindex $slist [expr {$pos + 1}]]
if {[string first $pattern $check] != 0} {
- return [::lsearch -nocase -exact $list [lindex $slist $pos]]
+ return [::lsearch -exact $list [lindex $slist $pos]]
}
}
return -1
