home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / cmdline / cmdline.tcl next >
Encoding:
Text File  |  2001-08-17  |  7.6 KB  |  268 lines
  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 app
  6. #    name for use in command line errors.
  7. #
  8. # Copyright (c) 1998-2000 by Ajuba Solutions.
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. # 
  12. # RCS: @(#) $Id: cmdline.tcl,v 1.9 2001/08/02 16:38:06 andreas_kupries Exp $
  13.  
  14. package require Tcl 8.2
  15. package provide cmdline 1.1
  16. namespace eval cmdline {
  17.     namespace export getArgv0 getopt getfiles getoptions usage
  18. }
  19.  
  20. # Load the typed versions of these functions
  21. source [file join [file dirname [info script]] typedCmdline.tcl]
  22.  
  23. # cmdline::getopt --
  24. #
  25. #    The cmdline::getopt works in a fashion like the standard
  26. #    C based getopt function.  Given an option string and a 
  27. #    pointer to an array or args this command will process the
  28. #    first argument and return info on how to procede.
  29. #
  30. # Arguments:
  31. #    argvVar        Name of the argv list that you
  32. #            want to process.  If options are found the
  33. #            arg list is modified and the processed arguments
  34. #            are removed from the start of the list.
  35. #    optstring    A list of command options that the application
  36. #            will accept.  If the option ends in ".arg" the
  37. #            getopt routine will use the next argument as 
  38. #            an argument to the option.  Otherwise the option    
  39. #            is a boolean that is set to 1 if present.
  40. #    optVar        The variable pointed to by optVar
  41. #            contains the option that was found (without the
  42. #            leading '-' and without the .arg extension).
  43. #    valVar        Upon success, the variable pointed to by valVar
  44. #            contains the value for the specified option.
  45. #            This value comes from the command line for .arg
  46. #            options, otherwise the value is 1.
  47. #            If getopt fails, the valVar is filled with an
  48. #            error message.
  49. #
  50. # Results:
  51. #     The getopt function returns 1 if an option was found, 0 if no more
  52. #     options were found, and -1 if an error occurred.
  53.  
  54. proc cmdline::getopt {argvVar optstring optVar valVar} {
  55.     upvar 1 $argvVar argsList
  56.  
  57.     upvar 1 $optVar option
  58.     upvar 1 $valVar value
  59.  
  60.     # default settings for a normal return
  61.     set value ""
  62.     set option ""
  63.     set result 0
  64.  
  65.     # check if we're past the end of the args list
  66.     if {[llength $argsList] != 0} {
  67.  
  68.     # if we got -- or an option that doesn't begin with -, return (skipping
  69.     # the --).  otherwise process the option arg.
  70.     switch -glob -- [set arg [lindex $argsList 0]] {
  71.         "--" {
  72.         set argsList [lrange $argsList 1 end]
  73.         }
  74.  
  75.         "-*" {
  76.         set option [string range $arg 1 end]
  77.  
  78.         if {[lsearch -exact $optstring $option] != -1} {
  79.             # Booleans are set to 1 when present
  80.             set value 1
  81.             set result 1
  82.             set argsList [lrange $argsList 1 end]
  83.         } elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
  84.             set result 1
  85.             set argsList [lrange $argsList 1 end]
  86.             if {[llength $argsList] != 0} {
  87.             set value [lindex $argsList 0]
  88.             set argsList [lrange $argsList 1 end]
  89.             } else {
  90.             set value "Option \"$option\" requires an argument"
  91.             set result -1
  92.             }
  93.         } else {
  94.             set value "Illegal option \"$option\""
  95.             set result -1
  96.         }
  97.         }
  98.         default {
  99.         # Skip ahead
  100.         }
  101.     }
  102.     }
  103.  
  104.     return $result
  105. }
  106.  
  107. # cmdline::getoptions --
  108. #
  109. #    Process a set of command line options, filling in defaults
  110. #    for those not specified.  This also generates an error message
  111. #    that lists the allowed flags if an incorrect flag is specified.
  112. #
  113. # Arguments:
  114. #    arglistVar    The name of the argument list, typically argv
  115. #    optlist        A list-of-lists where each element specifies an option
  116. #            in the form:
  117. #                flag default comment
  118. #            If flag ends in ".arg" then the value is taken from the
  119. #            command line. Otherwise it is a boolean and appears in
  120. #            the result if present on the command line. If flag ends
  121. #            in ".secret", it will not be displayed in the usage.
  122. #    usage        Text to include in the usage display. Defaults to
  123. #            "options:"
  124. #
  125. # Results
  126. #    Name value pairs suitable for using with array set.
  127.  
  128. proc cmdline::getoptions {arglistVar optlist {usage options:}} {
  129.     upvar 1 $arglistVar argv
  130.     set opts {? help}
  131.     foreach opt $optlist {
  132.     set name [lindex $opt 0]
  133.     if {[regsub -- .secret$ $name {} name] == 1} {
  134.         # Need to hide this from the usage display and getopt
  135.     }   
  136.     lappend opts $name
  137.     if {[regsub -- .arg$ $name {} name] == 1} {
  138.  
  139.         # Set defaults for those that take values.
  140.  
  141.         set default [lindex $opt 1]
  142.         set result($name) $default
  143.     } else {
  144.         # The default for booleans is false
  145.         set result($name) 0
  146.     }
  147.     }
  148.     set argc [llength $argv]
  149.     while {[set err [cmdline::getopt argv $opts opt arg]]} {
  150.     if {$err < 0} {
  151.         error [cmdline::usage $optlist $usage]
  152.     }
  153.     set result($opt) $arg
  154.     }
  155.     if {[info exist result(?)] || [info exists result(help)]} {
  156.     error [cmdline::usage $optlist $usage]
  157.     }
  158.     return [array get result]
  159. }
  160.  
  161. # cmdline::usage --
  162. #
  163. #    Generate an error message that lists the allowed flags.
  164. #
  165. # Arguments:
  166. #    optlist        As for cmdline::getoptions
  167. #    usage        Text to include in the usage display. Defaults to
  168. #            "options:"
  169. #
  170. # Results
  171. #    A formatted usage message
  172.  
  173. proc cmdline::usage {optlist {usage {options:}}} {
  174.     set str "[cmdline::getArgv0] $usage\n"
  175.     foreach opt [concat $optlist \
  176.         {{help "Print this message"} {? "Print this message"}}] {
  177.     set name [lindex $opt 0]
  178.     if {[regsub -- .secret$ $name {} name] == 1} {
  179.         # Hidden option
  180.         continue
  181.     }
  182.     if {[regsub -- .arg$ $name {} name] == 1} {
  183.         set default [lindex $opt 1]
  184.         set comment [lindex $opt 2]
  185.         append str [format " %-20s %s <%s>\n" "-$name value" \
  186.             $comment $default]
  187.     } else {
  188.         set comment [lindex $opt 1]
  189.         append str [format " %-20s %s\n" "-$name" $comment]
  190.     }
  191.     }
  192.     return $str
  193. }
  194.  
  195. # cmdline::getfiles --
  196. #
  197. #    Given a list of file arguments from the command line, compute
  198. #    the set of valid files.  On windows, file globbing is performed
  199. #    on each argument.  On Unix, only file existence is tested.  If
  200. #    a file argument produces no valid files, a warning is optionally
  201. #    generated.
  202. #
  203. #    This code also uses the full path for each file.  If not
  204. #    given it prepends [pwd] to the filename.  This ensures that
  205. #    these files will never comflict with files in our zip file.
  206. #
  207. # Arguments:
  208. #    patterns    The file patterns specified by the user.
  209. #    quiet        If this flag is set, no warnings will be generated.
  210. #
  211. # Results:
  212. #    Returns the list of files that match the input patterns.
  213.  
  214. proc cmdline::getfiles {patterns quiet} {
  215.     set result {}
  216.     if {$::tcl_platform(platform) == "windows"} {
  217.     foreach pattern $patterns {
  218.         regsub -all -- {\\} $pattern {\\\\} pat
  219.         set files [glob -nocomplain -- $pat]
  220.         if {$files == {}} {
  221.         if {! $quiet} {
  222.             puts stdout "warning: no files match \"$pattern\""
  223.         }
  224.         } else {
  225.         foreach file $files {
  226.             lappend result $file
  227.         }
  228.         }
  229.     }
  230.     } else {
  231.     set result $patterns
  232.     }
  233.     set files {}
  234.     foreach file $result {
  235.     # Make file an absolute path so that we will never conflict
  236.     # with files that might be contained in our zip file.
  237.     set fullPath [file join [pwd] $file]
  238.     
  239.     if {[file isfile $fullPath]} {
  240.         lappend files $fullPath
  241.     } elseif {! $quiet} {
  242.         puts stdout "warning: no files match \"$file\""
  243.     }
  244.     }
  245.     return $files
  246. }
  247.  
  248. # cmdline::getArgv0 --
  249. #
  250. #    This command returns the "sanitized" version of argv0.  It will strip
  251. #    off the leading path and remove the ".bin" extensions that our apps
  252. #    use because they must be wrapped by a shell script.
  253. #
  254. # Arguments:
  255. #    None.
  256. #
  257. # Results:
  258. #    The application name that can be used in error messages.
  259.  
  260. proc cmdline::getArgv0 {} {
  261.     global argv0
  262.  
  263.     set name [file tail $argv0]
  264.     return [file rootname $name]
  265. }
  266.  
  267.  
  268.