1# cmdline.tcl -- 2# 3# This package provides a utility for parsing command line 4# arguments that are processed by our various applications. 5# It also includes a utility routine to determine the 6# application name for use in command line errors. 7# 8# Copyright (c) 1998-2000 by Ajuba Solutions. 9# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sf.net>. 10# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: cmdline.tcl,v 1.26 2008/07/09 18:02:59 andreas_kupries Exp $ 15 16package require Tcl 8.2 17package provide cmdline 1.3.1 18 19namespace eval ::cmdline { 20 namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ 21 getKnownOptions usage 22} 23 24# ::cmdline::getopt -- 25# 26# The cmdline::getopt works in a fashion like the standard 27# C based getopt function. Given an option string and a 28# pointer to an array or args this command will process the 29# first argument and return info on how to proceed. 30# 31# Arguments: 32# argvVar Name of the argv list that you 33# want to process. If options are found the 34# arg list is modified and the processed arguments 35# are removed from the start of the list. 36# optstring A list of command options that the application 37# will accept. If the option ends in ".arg" the 38# getopt routine will use the next argument as 39# an argument to the option. Otherwise the option 40# is a boolean that is set to 1 if present. 41# optVar The variable pointed to by optVar 42# contains the option that was found (without the 43# leading '-' and without the .arg extension). 44# valVar Upon success, the variable pointed to by valVar 45# contains the value for the specified option. 46# This value comes from the command line for .arg 47# options, otherwise the value is 1. 48# If getopt fails, the valVar is filled with an 49# error message. 50# 51# Results: 52# The getopt function returns 1 if an option was found, 0 if no more 53# options were found, and -1 if an error occurred. 54 55proc ::cmdline::getopt {argvVar optstring optVar valVar} { 56 upvar 1 $argvVar argsList 57 upvar 1 $optVar option 58 upvar 1 $valVar value 59 60 set result [getKnownOpt argsList $optstring option value] 61 62 if {$result < 0} { 63 # Collapse unknown-option error into any-other-error result. 64 set result -1 65 } 66 return $result 67} 68 69# ::cmdline::getKnownOpt -- 70# 71# The cmdline::getKnownOpt works in a fashion like the standard 72# C based getopt function. Given an option string and a 73# pointer to an array or args this command will process the 74# first argument and return info on how to proceed. 75# 76# Arguments: 77# argvVar Name of the argv list that you 78# want to process. If options are found the 79# arg list is modified and the processed arguments 80# are removed from the start of the list. Note that 81# unknown options and the args that follow them are 82# left in this list. 83# optstring A list of command options that the application 84# will accept. If the option ends in ".arg" the 85# getopt routine will use the next argument as 86# an argument to the option. Otherwise the option 87# is a boolean that is set to 1 if present. 88# optVar The variable pointed to by optVar 89# contains the option that was found (without the 90# leading '-' and without the .arg extension). 91# valVar Upon success, the variable pointed to by valVar 92# contains the value for the specified option. 93# This value comes from the command line for .arg 94# options, otherwise the value is 1. 95# If getopt fails, the valVar is filled with an 96# error message. 97# 98# Results: 99# The getKnownOpt function returns 1 if an option was found, 100# 0 if no more options were found, -1 if an unknown option was 101# encountered, and -2 if any other error occurred. 102 103proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { 104 upvar 1 $argvVar argsList 105 upvar 1 $optVar option 106 upvar 1 $valVar value 107 108 # default settings for a normal return 109 set value "" 110 set option "" 111 set result 0 112 113 # check if we're past the end of the args list 114 if {[llength $argsList] != 0} { 115 116 # if we got -- or an option that doesn't begin with -, return (skipping 117 # the --). otherwise process the option arg. 118 switch -glob -- [set arg [lindex $argsList 0]] { 119 "--" { 120 set argsList [lrange $argsList 1 end] 121 } 122 123 "-*" { 124 set option [string range $arg 1 end] 125 126 if {[lsearch -exact $optstring $option] != -1} { 127 # Booleans are set to 1 when present 128 set value 1 129 set result 1 130 set argsList [lrange $argsList 1 end] 131 } elseif {[lsearch -exact $optstring "$option.arg"] != -1} { 132 set result 1 133 set argsList [lrange $argsList 1 end] 134 if {[llength $argsList] != 0} { 135 set value [lindex $argsList 0] 136 set argsList [lrange $argsList 1 end] 137 } else { 138 set value "Option \"$option\" requires an argument" 139 set result -2 140 } 141 } else { 142 # Unknown option. 143 set value "Illegal option \"-$option\"" 144 set result -1 145 } 146 } 147 default { 148 # Skip ahead 149 } 150 } 151 } 152 153 return $result 154} 155 156# ::cmdline::getoptions -- 157# 158# Process a set of command line options, filling in defaults 159# for those not specified. This also generates an error message 160# that lists the allowed flags if an incorrect flag is specified. 161# 162# Arguments: 163# arglistVar The name of the argument list, typically argv. 164# We remove all known options and their args from it. 165# optlist A list-of-lists where each element specifies an option 166# in the form: 167# (where flag takes no argument) 168# flag comment 169# 170# (or where flag takes an argument) 171# flag default comment 172# 173# If flag ends in ".arg" then the value is taken from the 174# command line. Otherwise it is a boolean and appears in 175# the result if present on the command line. If flag ends 176# in ".secret", it will not be displayed in the usage. 177# usage Text to include in the usage display. Defaults to 178# "options:" 179# 180# Results 181# Name value pairs suitable for using with array set. 182 183proc ::cmdline::getoptions {arglistVar optlist {usage options:}} { 184 upvar 1 $arglistVar argv 185 186 set opts [GetOptionDefaults $optlist result] 187 188 set argc [llength $argv] 189 while {[set err [getopt argv $opts opt arg]]} { 190 if {$err < 0} { 191 set result(?) "" 192 break 193 } 194 set result($opt) $arg 195 } 196 if {[info exist result(?)] || [info exists result(help)]} { 197 error [usage $optlist $usage] 198 } 199 return [array get result] 200} 201 202# ::cmdline::getKnownOptions -- 203# 204# Process a set of command line options, filling in defaults 205# for those not specified. This ignores unknown flags, but generates 206# an error message that lists the correct usage if a known option 207# is used incorrectly. 208# 209# Arguments: 210# arglistVar The name of the argument list, typically argv. This 211# We remove all known options and their args from it. 212# optlist A list-of-lists where each element specifies an option 213# in the form: 214# flag default comment 215# If flag ends in ".arg" then the value is taken from the 216# command line. Otherwise it is a boolean and appears in 217# the result if present on the command line. If flag ends 218# in ".secret", it will not be displayed in the usage. 219# usage Text to include in the usage display. Defaults to 220# "options:" 221# 222# Results 223# Name value pairs suitable for using with array set. 224 225proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} { 226 upvar 1 $arglistVar argv 227 228 set opts [GetOptionDefaults $optlist result] 229 230 # As we encounter them, keep the unknown options and their 231 # arguments in this list. Before we return from this procedure, 232 # we'll prepend these args to the argList so that the application 233 # doesn't lose them. 234 235 set unknownOptions [list] 236 237 set argc [llength $argv] 238 while {[set err [getKnownOpt argv $opts opt arg]]} { 239 if {$err == -1} { 240 # Unknown option. 241 242 # Skip over any non-option items that follow it. 243 # For now, add them to the list of unknownOptions. 244 lappend unknownOptions [lindex $argv 0] 245 set argv [lrange $argv 1 end] 246 while {([llength $argv] != 0) \ 247 && ![string match "-*" [lindex $argv 0]]} { 248 lappend unknownOptions [lindex $argv 0] 249 set argv [lrange $argv 1 end] 250 } 251 } elseif {$err == -2} { 252 set result(?) "" 253 break 254 } else { 255 set result($opt) $arg 256 } 257 } 258 259 # Before returning, prepend the any unknown args back onto the 260 # argList so that the application doesn't lose them. 261 set argv [concat $unknownOptions $argv] 262 263 if {[info exist result(?)] || [info exists result(help)]} { 264 error [usage $optlist $usage] 265 } 266 return [array get result] 267} 268 269# ::cmdline::GetOptionDefaults -- 270# 271# This internal procedure processes the option list (that was passed to 272# the getopt or getKnownOpt procedure). The defaultArray gets an index 273# for each option in the option list, the value of which is the option's 274# default value. 275# 276# Arguments: 277# optlist A list-of-lists where each element specifies an option 278# in the form: 279# flag default comment 280# If flag ends in ".arg" then the value is taken from the 281# command line. Otherwise it is a boolean and appears in 282# the result if present on the command line. If flag ends 283# in ".secret", it will not be displayed in the usage. 284# defaultArrayVar The name of the array in which to put argument defaults. 285# 286# Results 287# Name value pairs suitable for using with array set. 288 289proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { 290 upvar 1 $defaultArrayVar result 291 292 set opts {? help} 293 foreach opt $optlist { 294 set name [lindex $opt 0] 295 if {[regsub -- .secret$ $name {} name] == 1} { 296 # Need to hide this from the usage display and getopt 297 } 298 lappend opts $name 299 if {[regsub -- .arg$ $name {} name] == 1} { 300 301 # Set defaults for those that take values. 302 303 set default [lindex $opt 1] 304 set result($name) $default 305 } else { 306 # The default for booleans is false 307 set result($name) 0 308 } 309 } 310 return $opts 311} 312 313# ::cmdline::usage -- 314# 315# Generate an error message that lists the allowed flags. 316# 317# Arguments: 318# optlist As for cmdline::getoptions 319# usage Text to include in the usage display. Defaults to 320# "options:" 321# 322# Results 323# A formatted usage message 324 325proc ::cmdline::usage {optlist {usage {options:}}} { 326 set str "[getArgv0] $usage\n" 327 foreach opt [concat $optlist \ 328 {{help "Print this message"} {? "Print this message"}}] { 329 set name [lindex $opt 0] 330 if {[regsub -- .secret$ $name {} name] == 1} { 331 # Hidden option 332 continue 333 } 334 if {[regsub -- .arg$ $name {} name] == 1} { 335 set default [lindex $opt 1] 336 set comment [lindex $opt 2] 337 append str [format " %-20s %s <%s>\n" "-$name value" \ 338 $comment $default] 339 } else { 340 set comment [lindex $opt 1] 341 append str [format " %-20s %s\n" "-$name" $comment] 342 } 343 } 344 return $str 345} 346 347# ::cmdline::getfiles -- 348# 349# Given a list of file arguments from the command line, compute 350# the set of valid files. On windows, file globbing is performed 351# on each argument. On Unix, only file existence is tested. If 352# a file argument produces no valid files, a warning is optionally 353# generated. 354# 355# This code also uses the full path for each file. If not 356# given it prepends [pwd] to the filename. This ensures that 357# these files will never conflict with files in our zip file. 358# 359# Arguments: 360# patterns The file patterns specified by the user. 361# quiet If this flag is set, no warnings will be generated. 362# 363# Results: 364# Returns the list of files that match the input patterns. 365 366proc ::cmdline::getfiles {patterns quiet} { 367 set result {} 368 if {$::tcl_platform(platform) == "windows"} { 369 foreach pattern $patterns { 370 set pat [file join $pattern] 371 set files [glob -nocomplain -- $pat] 372 if {$files == {}} { 373 if {! $quiet} { 374 puts stdout "warning: no files match \"$pattern\"" 375 } 376 } else { 377 foreach file $files { 378 lappend result $file 379 } 380 } 381 } 382 } else { 383 set result $patterns 384 } 385 set files {} 386 foreach file $result { 387 # Make file an absolute path so that we will never conflict 388 # with files that might be contained in our zip file. 389 set fullPath [file join [pwd] $file] 390 391 if {[file isfile $fullPath]} { 392 lappend files $fullPath 393 } elseif {! $quiet} { 394 puts stdout "warning: no files match \"$file\"" 395 } 396 } 397 return $files 398} 399 400# ::cmdline::getArgv0 -- 401# 402# This command returns the "sanitized" version of argv0. It will strip 403# off the leading path and remove the ".bin" extensions that our apps 404# use because they must be wrapped by a shell script. 405# 406# Arguments: 407# None. 408# 409# Results: 410# The application name that can be used in error messages. 411 412proc ::cmdline::getArgv0 {} { 413 global argv0 414 415 set name [file tail $argv0] 416 return [file rootname $name] 417} 418 419## 420# ### ### ### ######### ######### ######### 421## 422# Now the typed versions of the above commands. 423## 424# ### ### ### ######### ######### ######### 425## 426 427# typedCmdline.tcl -- 428# 429# This package provides a utility for parsing typed command 430# line arguments that may be processed by various applications. 431# 432# Copyright (c) 2000 by Ross Palmer Mohn. 433# See the file "license.terms" for information on usage and redistribution 434# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 435# 436# RCS: @(#) $Id: cmdline.tcl,v 1.26 2008/07/09 18:02:59 andreas_kupries Exp $ 437 438namespace eval ::cmdline { 439 namespace export typedGetopt typedGetoptions typedUsage 440 441 # variable cmdline::charclasses -- 442 # 443 # Create regexp list of allowable character classes 444 # from "string is" error message. 445 # 446 # Results: 447 # String of character class names separated by "|" characters. 448 449 variable charclasses 450 #checker exclude badKey 451 catch {string is . .} charclasses 452 variable dummy 453 regexp -- {must be (.+)$} $charclasses dummy charclasses 454 regsub -all -- {, (or )?} $charclasses {|} charclasses 455 unset dummy 456} 457 458# ::cmdline::typedGetopt -- 459# 460# The cmdline::typedGetopt works in a fashion like the standard 461# C based getopt function. Given an option string and a 462# pointer to a list of args this command will process the 463# first argument and return info on how to proceed. In addition, 464# you may specify a type for the argument to each option. 465# 466# Arguments: 467# argvVar Name of the argv list that you want to process. 468# If options are found, the arg list is modified 469# and the processed arguments are removed from the 470# start of the list. 471# 472# optstring A list of command options that the application 473# will accept. If the option ends in ".xxx", where 474# xxx is any valid character class to the tcl 475# command "string is", then typedGetopt routine will 476# use the next argument as a typed argument to the 477# option. The argument must match the specified 478# character classes (e.g. integer, double, boolean, 479# xdigit, etc.). Alternatively, you may specify 480# ".arg" for an untyped argument. 481# 482# optVar Upon success, the variable pointed to by optVar 483# contains the option that was found (without the 484# leading '-' and without the .xxx extension). If 485# typedGetopt fails the variable is set to the empty 486# string. SOMETIMES! Different for each -value! 487# 488# argVar Upon success, the variable pointed to by argVar 489# contains the argument for the specified option. 490# If typedGetopt fails, the variable is filled with 491# an error message. 492# 493# Argument type syntax: 494# Option that takes no argument. 495# foo 496# 497# Option that takes a typeless argument. 498# foo.arg 499# 500# Option that takes a typed argument. Allowable types are all 501# valid character classes to the tcl command "string is". 502# Currently must be one of alnum, alpha, ascii, control, 503# boolean, digit, double, false, graph, integer, lower, print, 504# punct, space, true, upper, wordchar, or xdigit. 505# foo.double 506# 507# Option that takes an argument from a list. 508# foo.(bar|blat) 509# 510# Argument quantifier syntax: 511# Option that takes an optional argument. 512# foo.arg? 513# 514# Option that takes a list of arguments terminated by "--". 515# foo.arg+ 516# 517# Option that takes an optional list of arguments terminated by "--". 518# foo.arg* 519# 520# Argument quantifiers work on all argument types, so, for 521# example, the following is a valid option specification. 522# foo.(bar|blat|blah)? 523# 524# Argument syntax miscellany: 525# Options may be specified on the command line using a unique, 526# shortened version of the option name. Given that program foo 527# has an option list of {bar.alpha blah.arg blat.double}, 528# "foo -b fob" returns an error, but "foo -ba fob" 529# successfully returns {bar fob} 530# 531# Results: 532# The typedGetopt function returns one of the following: 533# 1 a valid option was found 534# 0 no more options found to process 535# -1 invalid option 536# -2 missing argument to a valid option 537# -3 argument to a valid option does not match type 538# 539# Known Bugs: 540# When using options which include special glob characters, 541# you must use the exact option. Abbreviating it can cause 542# an error in the "cmdline::prefixSearch" procedure. 543 544proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { 545 variable charclasses 546 547 upvar $argvVar argsList 548 549 upvar $optVar retvar 550 upvar $argVar optarg 551 552 # default settings for a normal return 553 set optarg "" 554 set retvar "" 555 set retval 0 556 557 # check if we're past the end of the args list 558 if {[llength $argsList] != 0} { 559 560 # if we got -- or an option that doesn't begin with -, return (skipping 561 # the --). otherwise process the option arg. 562 switch -glob -- [set arg [lindex $argsList 0]] { 563 "--" { 564 set argsList [lrange $argsList 1 end] 565 } 566 567 "-*" { 568 # Create list of options without their argument extensions 569 570 set optstr "" 571 foreach str $optstring { 572 lappend optstr [file rootname $str] 573 } 574 575 set _opt [string range $arg 1 end] 576 577 set i [prefixSearch $optstr [file rootname $_opt]] 578 if {$i != -1} { 579 set opt [lindex $optstring $i] 580 581 set quantifier "none" 582 if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { 583 set opt [string range $opt 0 end-1] 584 } 585 586 if {[string first . $opt] == -1} { 587 set retval 1 588 set retvar $opt 589 set argsList [lrange $argsList 1 end] 590 591 } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] 592 || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { 593 if {[string equal arg $charclass]} { 594 set type arg 595 } elseif {[regexp -- "^($charclasses)\$" $charclass]} { 596 set type class 597 } else { 598 set type oneof 599 } 600 601 set argsList [lrange $argsList 1 end] 602 set opt [file rootname $opt] 603 604 while {1} { 605 if {[llength $argsList] == 0 606 || [string equal "--" [lindex $argsList 0]]} { 607 if {[string equal "--" [lindex $argsList 0]]} { 608 set argsList [lrange $argsList 1 end] 609 } 610 611 set oneof "" 612 if {$type == "arg"} { 613 set charclass an 614 } elseif {$type == "oneof"} { 615 set oneof ", one of $charclass" 616 set charclass an 617 } 618 619 if {$quantifier == "?"} { 620 set retval 1 621 set retvar $opt 622 set optarg "" 623 } elseif {$quantifier == "+"} { 624 set retvar $opt 625 if {[llength $optarg] < 1} { 626 set retval -2 627 set optarg "Option requires at least one $charclass argument$oneof -- $opt" 628 } else { 629 set retval 1 630 } 631 } elseif {$quantifier == "*"} { 632 set retval 1 633 set retvar $opt 634 } else { 635 set optarg "Option requires $charclass argument$oneof -- $opt" 636 set retvar $opt 637 set retval -2 638 } 639 set quantifier "" 640 } elseif {($type == "arg") 641 || (($type == "oneof") 642 && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) 643 || (($type == "class") 644 && [string is $charclass [lindex $argsList 0]])} { 645 set retval 1 646 set retvar $opt 647 lappend optarg [lindex $argsList 0] 648 set argsList [lrange $argsList 1 end] 649 } else { 650 set oneof "" 651 if {$type == "arg"} { 652 set charclass an 653 } elseif {$type == "oneof"} { 654 set oneof ", one of $charclass" 655 set charclass an 656 } 657 set optarg "Option requires $charclass argument$oneof -- $opt" 658 set retvar $opt 659 set retval -3 660 661 if {$quantifier == "?"} { 662 set retval 1 663 set optarg "" 664 } 665 set quantifier "" 666 } 667 if {![regexp -- {[+*]} $quantifier]} { 668 break; 669 } 670 } 671 } else { 672 error "Illegal option type specification:\ 673 must be one of $charclasses" 674 } 675 } else { 676 set optarg "Illegal option -- $_opt" 677 set retvar $_opt 678 set retval -1 679 } 680 } 681 default { 682 # Skip ahead 683 } 684 } 685 } 686 687 return $retval 688} 689 690# ::cmdline::typedGetoptions -- 691# 692# Process a set of command line options, filling in defaults 693# for those not specified. This also generates an error message 694# that lists the allowed options if an incorrect option is 695# specified. 696# 697# Arguments: 698# arglistVar The name of the argument list, typically argv 699# optlist A list-of-lists where each element specifies an option 700# in the form: 701# 702# option default comment 703# 704# Options formatting is as described for the optstring 705# argument of typedGetopt. Default is for optionally 706# specifying a default value. Comment is for optionally 707# specifying a comment for the usage display. The 708# options "-help" and "-?" are automatically included 709# in optlist. 710# 711# Argument syntax miscellany: 712# Options formatting and syntax is as described in typedGetopt. 713# There are two additional suffixes that may be applied when 714# passing options to typedGetoptions. 715# 716# You may add ".multi" as a suffix to any option. For options 717# that take an argument, this means that the option may be used 718# more than once on the command line and that each additional 719# argument will be appended to a list, which is then returned 720# to the application. 721# foo.double.multi 722# 723# If a non-argument option is specified as ".multi", it is 724# toggled on and off for each time it is used on the command 725# line. 726# foo.multi 727# 728# If an option specification does not contain the ".multi" 729# suffix, it is not an error to use an option more than once. 730# In this case, the behavior for options with arguments is that 731# the last argument is the one that will be returned. For 732# options that do not take arguments, using them more than once 733# has no additional effect. 734# 735# Options may also be hidden from the usage display by 736# appending the suffix ".secret" to any option specification. 737# Please note that the ".secret" suffix must be the last suffix, 738# after any argument type specification and ".multi" suffix. 739# foo.xdigit.multi.secret 740# 741# Results 742# Name value pairs suitable for using with array set. 743 744proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} { 745 variable charclasses 746 747 upvar 1 $arglistVar argv 748 749 set opts {? help} 750 foreach opt $optlist { 751 set name [lindex $opt 0] 752 if {[regsub -- {\.secret$} $name {} name] == 1} { 753 # Remove this extension before passing to typedGetopt. 754 } 755 if {[regsub -- {\.multi$} $name {} name] == 1} { 756 # Remove this extension before passing to typedGetopt. 757 758 regsub -- {\..*$} $name {} temp 759 set multi($temp) 1 760 } 761 lappend opts $name 762 if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { 763 # Set defaults for those that take values. 764 # Booleans are set just by being present, or not 765 766 set dflt [lindex $opt 1] 767 if {$dflt != {}} { 768 set defaults($name) $dflt 769 } 770 } 771 } 772 set argc [llength $argv] 773 while {[set err [typedGetopt argv $opts opt arg]]} { 774 if {$err == 1} { 775 if {[info exists result($opt)] 776 && [info exists multi($opt)]} { 777 # Toggle boolean options or append new arguments 778 779 if {$arg == ""} { 780 unset result($opt) 781 } else { 782 set result($opt) "$result($opt) $arg" 783 } 784 } else { 785 set result($opt) "$arg" 786 } 787 } elseif {($err == -1) || ($err == -3)} { 788 error [typedUsage $optlist $usage] 789 } elseif {$err == -2 && ![info exists defaults($opt)]} { 790 error [typedUsage $optlist $usage] 791 } 792 } 793 if {[info exists result(?)] || [info exists result(help)]} { 794 error [typedUsage $optlist $usage] 795 } 796 foreach {opt dflt} [array get defaults] { 797 if {![info exists result($opt)]} { 798 set result($opt) $dflt 799 } 800 } 801 return [array get result] 802} 803 804# ::cmdline::typedUsage -- 805# 806# Generate an error message that lists the allowed flags, 807# type of argument taken (if any), default value (if any), 808# and an optional description. 809# 810# Arguments: 811# optlist As for cmdline::typedGetoptions 812# 813# Results 814# A formatted usage message 815 816proc ::cmdline::typedUsage {optlist {usage {options:}}} { 817 variable charclasses 818 819 set str "[getArgv0] $usage\n" 820 foreach opt [concat $optlist \ 821 {{help "Print this message"} {? "Print this message"}}] { 822 set name [lindex $opt 0] 823 if {[regsub -- {\.secret$} $name {} name] == 1} { 824 # Hidden option 825 826 } else { 827 if {[regsub -- {\.multi$} $name {} name] == 1} { 828 # Display something about multiple options 829 } 830 831 if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] 832 || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { 833 regsub -- "\\..+\$" $name {} name 834 set comment [lindex $opt 2] 835 set default "<[lindex $opt 1]>" 836 if {$default == "<>"} { 837 set default "" 838 } 839 append str [format " %-20s %s %s\n" "-$name $charclass" \ 840 $comment $default] 841 } else { 842 set comment [lindex $opt 1] 843 append str [format " %-20s %s\n" "-$name" $comment] 844 } 845 } 846 } 847 return $str 848} 849 850# ::cmdline::prefixSearch -- 851# 852# Search a Tcl list for a pattern; searches first for an exact match, 853# and if that fails, for a unique prefix that matches the pattern 854# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" 855# 856# Arguments: 857# list list of words 858# pattern word to search for 859# 860# Results: 861# Index of found word is returned. If no exact match or 862# unique short version is found then -1 is returned. 863 864proc ::cmdline::prefixSearch {list pattern} { 865 # Check for an exact match 866 867 if {[set pos [::lsearch -exact $list $pattern]] > -1} { 868 return $pos 869 } 870 871 # Check for a unique short version 872 873 set slist [lsort $list] 874 if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { 875 # What if there is nothing for the check variable? 876 877 set check [lindex $slist [expr {$pos + 1}]] 878 if {[string first $pattern $check] != 0} { 879 return [::lsearch -exact $list [lindex $slist $pos]] 880 } 881 } 882 return -1 883} 884