Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

361 lines
11 KiB

  1. #---------------------------------------------------------------------
  2. package ParseArgs;
  3. #
  4. # Copyright (c) Microsoft Corporation. All rights reserved.
  5. #
  6. # Version: 1.00 06/30/2000 JeremyD inital version
  7. # 1.01 07/03/2000 JeremyD flags now overwrite pre-existing
  8. # values
  9. # 1.02 10/17/2000 JeremyD renamed parseargv as parseargv,
  10. # removed the old parseargs
  11. # 2.00 11/22/2000 JeremyD numerous bug fixes, operate in
  12. # place on @ARGV, leaving unparsed
  13. # arguments in place. See HISTORY.
  14. #---------------------------------------------------------------------
  15. use strict;
  16. use vars qw(@ISA @EXPORT $VERSION);
  17. use Carp;
  18. use Exporter;
  19. @ISA = qw(Exporter);
  20. @EXPORT = qw(parseargs);
  21. $VERSION = '2.00';
  22. sub parseargs {
  23. my @spec = @_;
  24. my @pass_thru = ();
  25. my %named_coderefs;
  26. my %wants_param;
  27. NAMED_SPEC:
  28. # walk through the specification, taking off (name, storage location) pairs
  29. while (@spec >= 2) {
  30. # if we hit a storage location instead of a flag name then we've
  31. # reached the end of the named paramaters, there are only positional
  32. # storage locations left
  33. if (ref $spec[0]) {
  34. last NAMED_SPEC;
  35. }
  36. my $spec = shift @spec;
  37. my $store = shift @spec;
  38. # a trailing colon indicates this flag can take a paramater
  39. my ($flag, $param) = $spec =~ /([\w\?]+)(:)?/;
  40. # this flag takes a paramater
  41. if ($param) {
  42. # remember that this flag wants a paramater,
  43. # this will change our parsing behavior below
  44. $wants_param{$flag}++;
  45. # clear our storage location and set a callback to write to it
  46. if (ref $store eq 'SCALAR') {
  47. $$store = undef;
  48. $named_coderefs{$flag} = sub { $$store = $_[0] };
  49. } elsif (ref $store eq 'ARRAY') {
  50. @$store = ();
  51. $named_coderefs{$flag} = sub { push @$store, $_[0] };
  52. } elsif (ref $store eq 'CODE') {
  53. $named_coderefs{$flag} = $store;
  54. } else {
  55. # will ignore flag
  56. }
  57. }
  58. # this flag does not take a paramater
  59. else {
  60. # clear our storage location and set a callback to write to it
  61. if (ref $store eq 'SCALAR') {
  62. $$store = undef;
  63. $named_coderefs{$flag} = sub { $$store++ };
  64. } elsif (ref $store eq 'ARRAY') {
  65. carp "Unsupported storage method!";
  66. } elsif (ref $store eq 'CODE') {
  67. $named_coderefs{$flag} = $store;
  68. } else {
  69. # will ignore flag
  70. }
  71. }
  72. }
  73. # remaining items in @spec should be storage locations for positional args
  74. # we'll use the leftovers in @spec below
  75. for my $store (@spec) {
  76. # create an array of code
  77. if (ref $store eq 'SCALAR') {
  78. $$store = undef;
  79. } elsif (ref $store eq 'ARRAY') {
  80. @$store = ();
  81. } else {
  82. # can't initialize a coderef
  83. }
  84. }
  85. # loop through the given arguments checking them against our spec
  86. while (my $arg = shift @ARGV) {
  87. # this looks like a flag
  88. if ($arg =~ /^[\/-]([\w\?]+)(?::(.*))?$/) {
  89. my $flag = $1;
  90. my $param = $2;
  91. # this flag can take a param
  92. if ($wants_param{$flag} and not defined $param) {
  93. # the next arg does not look like a flag, use it
  94. if (@ARGV and $ARGV[0] !~ /^[\/-]/) {
  95. $param = shift @ARGV;
  96. }
  97. # use the empty string if we can't find anything
  98. else {
  99. $param = '';
  100. }
  101. }
  102. # this flag is recognized
  103. if ($named_coderefs{$flag}) {
  104. &{$named_coderefs{$flag}}($param);
  105. }
  106. # this flag is not recognized
  107. else {
  108. # too short to split
  109. if (length $flag == 1) {
  110. # pass through $arg we don't recognize it and we
  111. # can't split it, let the user deal with it
  112. push @pass_thru, $arg;
  113. }
  114. # flag is long enough for unbundling to have some meaning
  115. else {
  116. my @split_flags = split //, $flag;
  117. # don't understand at least one flag in the bundle
  118. if (grep { !$named_coderefs{$_} } @split_flags) {
  119. # pass through $arg
  120. push @pass_thru, $arg;
  121. }
  122. # all the flags in the bundle candidate are ok
  123. else {
  124. # make them look like flags and put them in the front
  125. # of the list
  126. unshift @ARGV, map { "-$_" } @split_flags;
  127. }
  128. } # else length
  129. } # else named_coderefs
  130. } # if $arg =~
  131. # this does not look like a flag
  132. else {
  133. # try our positional storage locations
  134. if (ref $spec[0] eq 'SCALAR') {
  135. ${$spec[0]} = $arg;
  136. shift @spec; # can't recycle a scalar storage location
  137. } elsif (ref $spec[0] eq 'ARRAY') {
  138. push @{$spec[0]}, $arg;
  139. } elsif (ref $spec[0] eq 'CODE') {
  140. &{$spec[0]}($arg);
  141. } else {
  142. # pass through $arg if we run out of positional locations
  143. push @pass_thru, $arg;
  144. }
  145. } # else $arg =~
  146. } # while $arg
  147. # set @ARGV to just the values we couldn't handle
  148. # we also return the array, but that isn't documented yet so don't count on it
  149. @ARGV = @pass_thru;
  150. }
  151. 1;
  152. __END__
  153. =head1 NAME
  154. ParseArgs - A flexible command line parser
  155. =head1 SYNOPSIS
  156. use ParseArgs;
  157. parseargs('?' => \&Usage,
  158. 'v' => \$verbose,
  159. 'l:' => \$lang,
  160. 'word:' => \@magic_words,
  161. \$filename
  162. );
  163. =head1 DESCRIPTION
  164. The ParseArgs module exports the function parseargs, a flexible command
  165. line parser.
  166. =over 4
  167. =item parseargs( @parse_spec )
  168. parseargs parses the command line found in @ARGV. Parsed arguments are
  169. removed leaving only unparsed arguments in @ARGV. The parse specification
  170. is best understood by reading through the examples below.
  171. =back
  172. The following flag formats are supported:
  173. -a # single letter flag
  174. -flag # word flag
  175. param1 param2 param3 ... # positional paramaters
  176. -abc # expands to -a -b -c
  177. # if -abc is not flag and
  178. # -a, -b and -c are
  179. Paramaters to a flag can be in the following formats:
  180. -a param
  181. -a:param
  182. -a "quoted string"
  183. -a:"quoted string"
  184. =head1 EXAMPLES
  185. =head2 FLAG EXAMPLES
  186. Example of a simple flag
  187. parseargs('v' => \$verbose);
  188. if ($verbose) { print "Welcome to the wonderful world of verbosity\n" }
  189. >script.pl -v
  190. Example of a simple flag that takes a paramater
  191. parseargs('l:' => \$lang);
  192. if ($lang) { print "I don\'t speak $lang\n" }
  193. >script.pl -l russian
  194. Example of a simple flag that takes multiple paramaters
  195. parseargs('l:' => \@langs);
  196. foreach $lang (@langs) { print "I don\'t speak $lang\n" }
  197. >script.pl -l russian -l german -l french
  198. =head2 POSITIONAL EXAMPLES
  199. Example of a positional paramater
  200. parseargs(\$filename);
  201. if ($filename) { print "I will do something to $filename\n" }
  202. >script.pl foobar.txt
  203. Example of several positional paramaters
  204. parseargs(\$filename, \$targetdir);
  205. if (-e $filename and -d $targetdir) { print "Copy sanity check passed" }
  206. >script.pl foobar.txt \backup\foobars\
  207. Example of varying number of positional paramaters
  208. parseargs(\@files);
  209. foreach $file (@files) { print "Found $file\n" if -e $file }
  210. >script.pl foobar.txt foobaz.txt widget.txt ...
  211. =head2 CALLBACK EXAMPLES
  212. Example of a flag that triggers a callback
  213. sub Usage { print "This is a usage message"; exit(1) }
  214. parseargs('?' => \&Usage);
  215. >script.pl -?
  216. Example of a flag that triggers a callback with paramaters
  217. sub Usage { $topic = shift; print "Here is help for $topic\n"; exit(1) }
  218. parseargs('?:' =>\&Usage);
  219. >script.pl -? "build lab monkeys"
  220. Example of positional paramaters triggering a callback
  221. sub JustEcho { $arg = shift; print "$arg\n" }
  222. parseargs(\&JustEcho);
  223. >script.pl one two three four
  224. =head2 MORE INTERESTING EXAMPLES
  225. Example of mixed simple flags and positional paramaters
  226. parseargs('v' => \$verbose, \$src_file, \$dest_file);
  227. >script.pl original.txt munged.txt
  228. >script.pl -v original.txt munged.txt
  229. or even
  230. >script.pl original.txt -v munged.txt
  231. Example of mixing flags that take paramaters with positional paramaters
  232. parseargs('l:' => \$lang, \$src_file, \$dest_file);
  233. >script.pl -l german original.txt deutch.txt
  234. >script.pl original.txt us-en.txt -l # $l = ""
  235. >script.pl -l: original.txt us-en.txt # $l = ""
  236. but note
  237. >script.pl -l original.txt us-en.txt # $l = "original.txt"..
  238. =head1 NOTES
  239. Any positional flags must be at the end of the specification list.
  240. Flags on the command line must be preceeded with either '-' or '/'
  241. Flag names must match the regex [\w\?]+
  242. Everything is case sensitive
  243. Positional paramaters can be mixed with flags on the command line
  244. Flags that can take a paramater will always swallow the next word unless it
  245. begins with '-' or '/'
  246. Flags that can take a paramater will '' (the empty string) if a paramater is
  247. not specified on the command line
  248. Single letter flags may be bundled together as long as the resulting bundle
  249. does not conflit with a longer flag name
  250. =head1 HISTORY
  251. New for you in version 2
  252. Parsed items are removed from @ARGV. This lets you handle the command line on
  253. your own after parseargs does its thing.
  254. Unhandled storage methods are caught when the spec is loaded.
  255. Removed some previously fatal error conditions.
  256. =head1 SEE ALSO
  257. GetParams
  258. GetOpt::Long
  259. =head1 AUTHOR
  260. Jeremy Devenport <JeremyD>
  261. =head1 COPYRIGHT
  262. Copyright (c) Microsoft Corporation. All rights reserved.
  263. =cut