362 lines
10 KiB
Perl
362 lines
10 KiB
Perl
|
#---------------------------------------------------------------------
|
||
|
|
package ParseArgs;
|
||
|
|
#
|
||
|
|
# Copyright (c) Microsoft Corporation. All rights reserved.
|
||
|
|
#
|
||
|
|
# Version: 1.00 06/30/2000 JeremyD inital version
|
||
|
|
# 1.01 07/03/2000 JeremyD flags now overwrite pre-existing
|
||
|
|
# values
|
||
|
|
# 1.02 10/17/2000 JeremyD renamed parseargv as parseargv,
|
||
|
|
# removed the old parseargs
|
||
|
|
# 2.00 11/22/2000 JeremyD numerous bug fixes, operate in
|
||
|
|
# place on @ARGV, leaving unparsed
|
||
|
|
# arguments in place. See HISTORY.
|
||
|
|
#---------------------------------------------------------------------
|
||
|
|
use strict;
|
||
|
|
use vars qw(@ISA @EXPORT $VERSION);
|
||
|
|
use Carp;
|
||
|
|
use Exporter;
|
||
|
|
@ISA = qw(Exporter);
|
||
|
|
@EXPORT = qw(parseargs);
|
||
|
|
|
||
|
|
$VERSION = '2.00';
|
||
|
|
|
||
|
|
sub parseargs {
|
||
|
|
my @spec = @_;
|
||
|
|
my @pass_thru = ();
|
||
|
|
|
||
|
|
my %named_coderefs;
|
||
|
|
my %wants_param;
|
||
|
|
|
||
|
|
NAMED_SPEC:
|
||
|
|
# walk through the specification, taking off (name, storage location) pairs
|
||
|
|
while (@spec >= 2) {
|
||
|
|
# if we hit a storage location instead of a flag name then we've
|
||
|
|
# reached the end of the named paramaters, there are only positional
|
||
|
|
# storage locations left
|
||
|
|
if (ref $spec[0]) {
|
||
|
|
last NAMED_SPEC;
|
||
|
|
}
|
||
|
|
|
||
|
|
my $spec = shift @spec;
|
||
|
|
my $store = shift @spec;
|
||
|
|
|
||
|
|
# a trailing colon indicates this flag can take a paramater
|
||
|
|
my ($flag, $param) = $spec =~ /([\w\?]+)(:)?/;
|
||
|
|
|
||
|
|
# this flag takes a paramater
|
||
|
|
if ($param) {
|
||
|
|
# remember that this flag wants a paramater,
|
||
|
|
# this will change our parsing behavior below
|
||
|
|
$wants_param{$flag}++;
|
||
|
|
|
||
|
|
# clear our storage location and set a callback to write to it
|
||
|
|
if (ref $store eq 'SCALAR') {
|
||
|
|
$$store = undef;
|
||
|
|
$named_coderefs{$flag} = sub { $$store = $_[0] };
|
||
|
|
} elsif (ref $store eq 'ARRAY') {
|
||
|
|
@$store = ();
|
||
|
|
$named_coderefs{$flag} = sub { push @$store, $_[0] };
|
||
|
|
} elsif (ref $store eq 'CODE') {
|
||
|
|
$named_coderefs{$flag} = $store;
|
||
|
|
} else {
|
||
|
|
# will ignore flag
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# this flag does not take a paramater
|
||
|
|
else {
|
||
|
|
# clear our storage location and set a callback to write to it
|
||
|
|
if (ref $store eq 'SCALAR') {
|
||
|
|
$$store = undef;
|
||
|
|
$named_coderefs{$flag} = sub { $$store++ };
|
||
|
|
} elsif (ref $store eq 'ARRAY') {
|
||
|
|
carp "Unsupported storage method!";
|
||
|
|
} elsif (ref $store eq 'CODE') {
|
||
|
|
$named_coderefs{$flag} = $store;
|
||
|
|
} else {
|
||
|
|
# will ignore flag
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# remaining items in @spec should be storage locations for positional args
|
||
|
|
# we'll use the leftovers in @spec below
|
||
|
|
for my $store (@spec) {
|
||
|
|
# create an array of code
|
||
|
|
if (ref $store eq 'SCALAR') {
|
||
|
|
$$store = undef;
|
||
|
|
} elsif (ref $store eq 'ARRAY') {
|
||
|
|
@$store = ();
|
||
|
|
} else {
|
||
|
|
# can't initialize a coderef
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# loop through the given arguments checking them against our spec
|
||
|
|
while (my $arg = shift @ARGV) {
|
||
|
|
# this looks like a flag
|
||
|
|
if ($arg =~ /^[\/-]([\w\?]+)(?::(.*))?$/) {
|
||
|
|
my $flag = $1;
|
||
|
|
my $param = $2;
|
||
|
|
|
||
|
|
# this flag can take a param
|
||
|
|
if ($wants_param{$flag} and not defined $param) {
|
||
|
|
# the next arg does not look like a flag, use it
|
||
|
|
if (@ARGV and $ARGV[0] !~ /^[\/-]/) {
|
||
|
|
$param = shift @ARGV;
|
||
|
|
}
|
||
|
|
|
||
|
|
# use the empty string if we can't find anything
|
||
|
|
else {
|
||
|
|
$param = '';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# this flag is recognized
|
||
|
|
if ($named_coderefs{$flag}) {
|
||
|
|
&{$named_coderefs{$flag}}($param);
|
||
|
|
}
|
||
|
|
|
||
|
|
# this flag is not recognized
|
||
|
|
else {
|
||
|
|
# too short to split
|
||
|
|
if (length $flag == 1) {
|
||
|
|
# pass through $arg we don't recognize it and we
|
||
|
|
# can't split it, let the user deal with it
|
||
|
|
push @pass_thru, $arg;
|
||
|
|
}
|
||
|
|
|
||
|
|
# flag is long enough for unbundling to have some meaning
|
||
|
|
else {
|
||
|
|
my @split_flags = split //, $flag;
|
||
|
|
|
||
|
|
# don't understand at least one flag in the bundle
|
||
|
|
if (grep { !$named_coderefs{$_} } @split_flags) {
|
||
|
|
# pass through $arg
|
||
|
|
push @pass_thru, $arg;
|
||
|
|
}
|
||
|
|
|
||
|
|
# all the flags in the bundle candidate are ok
|
||
|
|
else {
|
||
|
|
# make them look like flags and put them in the front
|
||
|
|
# of the list
|
||
|
|
unshift @ARGV, map { "-$_" } @split_flags;
|
||
|
|
}
|
||
|
|
} # else length
|
||
|
|
} # else named_coderefs
|
||
|
|
} # if $arg =~
|
||
|
|
|
||
|
|
# this does not look like a flag
|
||
|
|
else {
|
||
|
|
# try our positional storage locations
|
||
|
|
if (ref $spec[0] eq 'SCALAR') {
|
||
|
|
${$spec[0]} = $arg;
|
||
|
|
shift @spec; # can't recycle a scalar storage location
|
||
|
|
} elsif (ref $spec[0] eq 'ARRAY') {
|
||
|
|
push @{$spec[0]}, $arg;
|
||
|
|
} elsif (ref $spec[0] eq 'CODE') {
|
||
|
|
&{$spec[0]}($arg);
|
||
|
|
} else {
|
||
|
|
# pass through $arg if we run out of positional locations
|
||
|
|
push @pass_thru, $arg;
|
||
|
|
}
|
||
|
|
} # else $arg =~
|
||
|
|
} # while $arg
|
||
|
|
|
||
|
|
# set @ARGV to just the values we couldn't handle
|
||
|
|
# we also return the array, but that isn't documented yet so don't count on it
|
||
|
|
@ARGV = @pass_thru;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
|
||
|
|
__END__
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
ParseArgs - A flexible command line parser
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
use ParseArgs;
|
||
|
|
parseargs('?' => \&Usage,
|
||
|
|
'v' => \$verbose,
|
||
|
|
'l:' => \$lang,
|
||
|
|
'word:' => \@magic_words,
|
||
|
|
\$filename
|
||
|
|
);
|
||
|
|
|
||
|
|
|
||
|
|
=head1 DESCRIPTION
|
||
|
|
|
||
|
|
The ParseArgs module exports the function parseargs, a flexible command
|
||
|
|
line parser.
|
||
|
|
|
||
|
|
=over 4
|
||
|
|
|
||
|
|
=item parseargs( @parse_spec )
|
||
|
|
|
||
|
|
parseargs parses the command line found in @ARGV. Parsed arguments are
|
||
|
|
removed leaving only unparsed arguments in @ARGV. The parse specification
|
||
|
|
is best understood by reading through the examples below.
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
The following flag formats are supported:
|
||
|
|
|
||
|
|
-a # single letter flag
|
||
|
|
-flag # word flag
|
||
|
|
param1 param2 param3 ... # positional paramaters
|
||
|
|
-abc # expands to -a -b -c
|
||
|
|
# if -abc is not flag and
|
||
|
|
# -a, -b and -c are
|
||
|
|
|
||
|
|
Paramaters to a flag can be in the following formats:
|
||
|
|
|
||
|
|
-a param
|
||
|
|
-a:param
|
||
|
|
-a "quoted string"
|
||
|
|
-a:"quoted string"
|
||
|
|
|
||
|
|
=head1 EXAMPLES
|
||
|
|
|
||
|
|
=head2 FLAG EXAMPLES
|
||
|
|
|
||
|
|
Example of a simple flag
|
||
|
|
|
||
|
|
parseargs('v' => \$verbose);
|
||
|
|
if ($verbose) { print "Welcome to the wonderful world of verbosity\n" }
|
||
|
|
|
||
|
|
>script.pl -v
|
||
|
|
|
||
|
|
Example of a simple flag that takes a paramater
|
||
|
|
|
||
|
|
parseargs('l:' => \$lang);
|
||
|
|
if ($lang) { print "I don\'t speak $lang\n" }
|
||
|
|
|
||
|
|
>script.pl -l russian
|
||
|
|
|
||
|
|
Example of a simple flag that takes multiple paramaters
|
||
|
|
|
||
|
|
parseargs('l:' => \@langs);
|
||
|
|
foreach $lang (@langs) { print "I don\'t speak $lang\n" }
|
||
|
|
|
||
|
|
>script.pl -l russian -l german -l french
|
||
|
|
|
||
|
|
=head2 POSITIONAL EXAMPLES
|
||
|
|
|
||
|
|
Example of a positional paramater
|
||
|
|
|
||
|
|
parseargs(\$filename);
|
||
|
|
if ($filename) { print "I will do something to $filename\n" }
|
||
|
|
|
||
|
|
>script.pl foobar.txt
|
||
|
|
|
||
|
|
Example of several positional paramaters
|
||
|
|
|
||
|
|
parseargs(\$filename, \$targetdir);
|
||
|
|
if (-e $filename and -d $targetdir) { print "Copy sanity check passed" }
|
||
|
|
|
||
|
|
>script.pl foobar.txt \backup\foobars\
|
||
|
|
|
||
|
|
Example of varying number of positional paramaters
|
||
|
|
|
||
|
|
parseargs(\@files);
|
||
|
|
foreach $file (@files) { print "Found $file\n" if -e $file }
|
||
|
|
|
||
|
|
>script.pl foobar.txt foobaz.txt widget.txt ...
|
||
|
|
|
||
|
|
|
||
|
|
=head2 CALLBACK EXAMPLES
|
||
|
|
|
||
|
|
Example of a flag that triggers a callback
|
||
|
|
|
||
|
|
sub Usage { print "This is a usage message"; exit(1) }
|
||
|
|
parseargs('?' => \&Usage);
|
||
|
|
|
||
|
|
>script.pl -?
|
||
|
|
|
||
|
|
Example of a flag that triggers a callback with paramaters
|
||
|
|
|
||
|
|
sub Usage { $topic = shift; print "Here is help for $topic\n"; exit(1) }
|
||
|
|
parseargs('?:' =>\&Usage);
|
||
|
|
|
||
|
|
>script.pl -? "build lab monkeys"
|
||
|
|
|
||
|
|
Example of positional paramaters triggering a callback
|
||
|
|
|
||
|
|
sub JustEcho { $arg = shift; print "$arg\n" }
|
||
|
|
parseargs(\&JustEcho);
|
||
|
|
|
||
|
|
>script.pl one two three four
|
||
|
|
|
||
|
|
=head2 MORE INTERESTING EXAMPLES
|
||
|
|
|
||
|
|
Example of mixed simple flags and positional paramaters
|
||
|
|
|
||
|
|
parseargs('v' => \$verbose, \$src_file, \$dest_file);
|
||
|
|
|
||
|
|
>script.pl original.txt munged.txt
|
||
|
|
>script.pl -v original.txt munged.txt
|
||
|
|
or even
|
||
|
|
>script.pl original.txt -v munged.txt
|
||
|
|
|
||
|
|
Example of mixing flags that take paramaters with positional paramaters
|
||
|
|
|
||
|
|
parseargs('l:' => \$lang, \$src_file, \$dest_file);
|
||
|
|
|
||
|
|
>script.pl -l german original.txt deutch.txt
|
||
|
|
>script.pl original.txt us-en.txt -l # $l = ""
|
||
|
|
>script.pl -l: original.txt us-en.txt # $l = ""
|
||
|
|
but note
|
||
|
|
>script.pl -l original.txt us-en.txt # $l = "original.txt"..
|
||
|
|
|
||
|
|
=head1 NOTES
|
||
|
|
|
||
|
|
Any positional flags must be at the end of the specification list.
|
||
|
|
|
||
|
|
Flags on the command line must be preceeded with either '-' or '/'
|
||
|
|
|
||
|
|
Flag names must match the regex [\w\?]+
|
||
|
|
|
||
|
|
Everything is case sensitive
|
||
|
|
|
||
|
|
Positional paramaters can be mixed with flags on the command line
|
||
|
|
|
||
|
|
Flags that can take a paramater will always swallow the next word unless it
|
||
|
|
begins with '-' or '/'
|
||
|
|
|
||
|
|
Flags that can take a paramater will '' (the empty string) if a paramater is
|
||
|
|
not specified on the command line
|
||
|
|
|
||
|
|
Single letter flags may be bundled together as long as the resulting bundle
|
||
|
|
does not conflit with a longer flag name
|
||
|
|
|
||
|
|
=head1 HISTORY
|
||
|
|
|
||
|
|
New for you in version 2
|
||
|
|
|
||
|
|
Parsed items are removed from @ARGV. This lets you handle the command line on
|
||
|
|
your own after parseargs does its thing.
|
||
|
|
|
||
|
|
Unhandled storage methods are caught when the spec is loaded.
|
||
|
|
|
||
|
|
Removed some previously fatal error conditions.
|
||
|
|
|
||
|
|
=head1 SEE ALSO
|
||
|
|
|
||
|
|
GetParams
|
||
|
|
GetOpt::Long
|
||
|
|
|
||
|
|
=head1 AUTHOR
|
||
|
|
|
||
|
|
Jeremy Devenport <JeremyD>
|
||
|
|
|
||
|
|
=head1 COPYRIGHT
|
||
|
|
|
||
|
|
Copyright (c) Microsoft Corporation. All rights reserved.
|
||
|
|
|
||
|
|
=cut
|