Getopt-Tabular-0.3/ 40755 764 144 0 6703002422 12434 5ustar gregusersGetopt-Tabular-0.3/demo100555 764 144 6170 6703001420 13402 0ustar gregusers#!/usr/local/bin/perl5 -w # Example program for the Getopt::Tabular package. See Getopt/Tabular.pod # for detailed explanation of How Things Work. # # originally by Greg Ward 1995/07/06 - 1995/07/09 (for ParseArgs package) # adapted to Getopt::Tabular 1996/11/10 use Getopt::Tabular qw/GetOptions SetError/; # Data needed for parsing command line options @Ints = (0, 0); # you don't really need to supply pre-defined $Float = 0; # values -- I just do it here to avoid $String = ""; # "Identifier used only once" warnings @UStrings = (); $Flag = 0; @Foo = (); $help = <<"EOH"; This is a pretty useless program. All it does is demonstrate my Getopt::Tabular package. EOH $usage = <<"EOH"; Usage: $0 [options] EOH # Here's the important bit: the option table. The *first* element of each # entry is the option name, which can be whatever you like; the *second* # element is the option type, which must be one of string, integer, float, # constant, boolean, copy, arrayconst, hashconst, call, or eval. &Getopt::Tabular::AddPatternType ("upperstring", "[A-Z]+", ["string of uppercase letters", "strings of uppercase letters"]); @opt_table = (["-int", "integer", 2, \@Ints, "two integers", "i1 i2"], ["-float", "float", 1, \$Float, "a floating-point number" ], ["-string", "string", 1, \$String, "a string" ], ["-ustring","upperstring",3,\@UStrings, "an uppercase string (example of a user-defined pattern type)"], ["-flag", "boolean", 0, \$Flag, "a boolean flag" ], ["-foo", "call", 0, \&get_foo, "do nothing important"], ["-show", "eval", 0, 'print "Ints = @Ints\n";', "print the current values of -int option"] ); # Here's an example subroutine used by the "-foo" option -- note that # it modifies the list referenced by its second argument, which is perfectly # legal; this modification propagates back up to change @ARGV after # &GetOptions is finished. sub get_foo { my ($arg, $args) = @_; my $next; print "Hello, you have used the $arg option\n"; unless (@$args) { &SetError ("bad_foo", "no arguments found for $arg option"); return 0; } while ($next = shift @$args) { last if $next =~ /^-/; push (@Foo, $next); print "Got $next from \@\$args\n"; } if (defined $next) # not the last option? { print "Putting $next back on \@\$args\n"; unshift (@$args, $next); } 1; } # Here's where we actually do real work -- set the two help messages # (the summary of options is generated automatically) and then parse # those arguments. &Getopt::Tabular::SetHelp ($help, $usage); #&GetOptions (\@opt_table, \@ARGV) || exit 1; if (! &GetOptions (\@opt_table, \@ARGV, \@newARGV)) { die "GetOptions returned error status; reason: $Getopt::Tabular::ErrorClass\n"; } print <<"END"; Values after parsing: \$Ints = @Ints \$Float = $Float \$String = $String \@UStrings = @UStrings \$Flag = $Flag \@Foo = @Foo END print " Original arguments: @ARGV\n"; print "Remaining arguments: @newARGV\n"; Getopt-Tabular-0.3/Tabular.pm100444 764 144 64414 6703001304 14506 0ustar greguserspackage Getopt::Tabular; # # Getopt/Tabular.pm # # Perl module for table-driven argument parsing, somewhat like Tk's # ParseArgv. To use the package, you just have to set up an argument table # (a list of array references), and call &GetOptions (the name is exported # from the module). &GetOptions takes two or three arguments; a reference # to your argument table (which is not modified), a reference to the list # of command line arguments, e.g. @ARGV (or a copy of it), and (optionally) # a reference to a new empty array. In the two argument form, the second # argument is modified in place to remove all options and their arguments. # In the three argument form, the second argument is unmodified, and the # third argument is set to a copy of it with options removed. # # The argument table consists of one element per valid command-line option; # each element should be a reference to a list of the form: # # ( option_name, type, num_values, option_data, help_string, arg_desc ) # # See Getopt/Tabular.pod for complete information. # # originally by Greg Ward 1995/07/06-07/09 as ParseArgs.pm # renamed to Getopt::Tabular and somewhat reorganized/reworked, # 1996/11/08-11/10 # # $Id: Tabular.pm,v 1.8 1999/04/08 01:11:24 greg Exp $ # Copyright (c) 1995-98 Greg Ward. All rights reserved. This package is # free software; you can redistribute it and/or modify it under the same # terms as Perl itself. require Exporter; use Carp; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use vars qw/%Patterns %OptionHandlers %TypeDescriptions @OptionPatterns %SpoofCode $OptionTerminator $HelpOption $LongHelp $Usage $ErrorClass $ErrorMessage/; $VERSION = 0.3; @ISA = qw/Exporter/; @EXPORT = qw/GetOptions/; @EXPORT_OK = qw/SetHelp SetHelpOption SetError GetError SpoofGetOptions/; # -------------------------------------------------------------------- # # Private global variables # # -------------------------------------------------------------------- # # The regexp for floating point numbers here is a little more permissive # than the C standard -- it recognizes "0", "0.", ".0", and "0.0" (where 0 # can be substituted by any string of one or more digits), preceded by an # optional sign, and followed by an optional exponent. %Patterns = ('integer' => '[+-]?\d+', 'float' => '[+-]? ( \d+(\.\d*)? | \.\d+ ) ([Ee][+-]?\d+)?', 'string' => '.*'); # This hash defines the allowable option types, and what to do when we # see an argument of a given type in the argument list. New types # can be added by calling AddType, as long as you supply an option # handler that acts like one of the existing handlers. (Ie. takes # the same three arguments, returns 1 for success and 0 for failure, # and calls SetError appropriately.) %OptionHandlers = ("string", \&process_pattern_option, "integer", \&process_pattern_option, "float", \&process_pattern_option, "boolean", \&process_boolean_option, "const", \&process_constant_option, "copy", \&process_constant_option, "arrayconst",\&process_constant_option, "hashconst", \&process_constant_option, "call", \&process_call_option, "eval", \&process_eval_option, "section", undef); # This hash is used for building error messages for pattern types. A # subtle point is that the description should be such that it can be # pluralized by adding an "s". OK, OK, you can supply an alternate # plural form by making the description a reference to a two-element list, # singular and plural forms. I18N fanatics should be happy. %TypeDescriptions = ("integer" => "integer", "float" => "floating-point number", "string" => "string"); @OptionPatterns = ('(-)(\w+)'); # two parts: "prefix" and "body" $OptionTerminator = "--"; $HelpOption = "-help"; # The %SpoofCode hash is for storing alternate versions of callbacks # for call or eval options. The alternate versions should have no side # effects apart from changing the argument list identically to their # "real" alternatives. %SpoofCode = (); $ErrorClass = ""; # can be "bad_option", "bad_value", # "bad_eval", or "help" $ErrorMessage = ""; # can be anything # -------------------------------------------------------------------- # # Public (but not exported) subroutines used to set options before # # calling GetOptions. # # -------------------------------------------------------------------- # sub SetHelp { $LongHelp = shift; $Usage = shift; } sub SetOptionPatterns { @OptionPatterns = @_; } sub SetHelpOption { $HelpOption = shift; } sub SetTerminator { $OptionTerminator = shift; } sub UnsetTerminator { undef $OptionTerminator; } sub AddType { my ($type, $handler) = @_; croak "AddType: \$handler must be a code ref" unless ref $handler eq 'CODE'; $OptionHandlers{$type} = $handler; } sub AddPatternType { my ($type, $pattern, $description) = @_; $OptionHandlers{$type} = \&process_pattern_option; $Patterns{$type} = $pattern; $TypeDescriptions{$type} = ($description || $type); } sub GetPattern { my ($type) = @_; $Patterns{$type}; } sub SetSpoofCodes { my ($option, $code); croak "Even number of arguments required" unless (@_ > 0 && @_ % 2 == 0); while (@_) { ($option, $code) = (shift, shift); $SpoofCode{$option} = $code; } } sub SetError { $ErrorClass = shift; $ErrorMessage = shift; } sub GetError { ($ErrorClass, $ErrorMessage); } # -------------------------------------------------------------------- # Private utility subroutines: # quote_strings # print_help # scan_table # match_abbreviation # option_error # check_value # split_option # find_calling_package # -------------------------------------------------------------------- # # "e_strings # # prepares strings for printing in a list of default values (for the # help text). If a string is empty or contains whitespace, it is quoted; # otherwise, it is left alone. The input list of strings is returned # concatenated into a single space-separated string. This is *not* # rigorous by any stretch; it's just to make the help text look nice. # sub quote_strings { my @strings = @_; my $string; foreach $string (@strings) { $string = qq["$string"] if ($string eq '' || $string =~ /\s/); } return join (' ', @strings); } # # &print_help # # walks through an argument table and prints out nicely-formatted # option help for all entries that provide it. Also does the Right Thing # (trust me) if you supply "argument description" text after the help. # # Don't read this code if you can possibly avoid it. It's pretty gross. # sub print_help { confess ("internal error, wrong number of input args to &print_help") if (scalar (@_) != 1); my ($argtable) = @_; my ($maxoption, $maxargdesc, $numcols, $opt, $breakers); my ($textlength, $std_format, $alt_format); my ($option, $type, $num, $value, $help, $argdesc); $maxoption = 0; $maxargdesc = 0; # Loop over all options to determine the length of the longest option name foreach $opt (@$argtable) { my ($argdesclen, $neg_option); my ($option, $type, $help, $argdesc) = @{$opt} [0,1,4,5]; next if $type eq "section" or ! defined $help; # Boolean options contribute *two* lines to the help: one for the # option, and one for its negative. Other options just contribute # one line, so they're a bit simpler. if ($type eq 'boolean') { my ($pos, $neg) = &split_option ($opt); my $pos_len = length ($pos); my $neg_len = length ($neg); $maxoption = $pos_len if ($pos_len > $maxoption); $maxoption = $neg_len if ($pos_len > $maxoption); carp "Getopt::Tabular: argument descriptions ignored " . "for boolean option \"$option\"" if defined $argdesc; } else { my $optlen = length ($option); $maxoption = $optlen if ($optlen > $maxoption); if (defined $argdesc) { $argdesclen = length ($argdesc); $maxargdesc = $argdesclen if ($argdesclen > $maxargdesc); } } } # We need to construct and eval code that looks something like this: # format STANDARD = # @<<<<<<<<<<<<<<< ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # $option, $help # ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # $help # . # # with an alternative format like this: # format ALTERNATIVE = # @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # $option, $argdesc # ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # $help # ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< # $help # . # in order to nicely print out the help. Can't hardcode a format, # though, because we don't know until now how much space to allocate # for the option (ie. $maxoption). local $: = " \n"; local $~; $numcols = 80; # not always accurate, but faster! # width of text = width of terminal, with columns removed as follows: # 3 (for left margin), $maxoption (option names), 2 (gutter between # option names and help text), and 2 (right margin) $textlength = $numcols - 3 - $maxoption - 2 - 2; $std_format = "format STANDARD =\n" . " @" . ("<" x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n". "\$option, \$help\n" . "~~ " . (" " x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n" . "\$help\n."; $alt_format = "format ALTERNATIVE =\n" . " @" . ("<" x ($maxoption + $maxargdesc)) . "\n" . "\$option\n" . " " . (" " x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n" . "\$help\n" . "~~ " . (" " x $maxoption) . " ^" . ("<" x ($textlength-1)) . "\n" . "\$help\n."; eval $std_format; confess ("internal error with format \"$std_format\": $@") if $@; eval $alt_format; confess ("internal error with format \"$alt_format\": $@") if $@; my $show_defaults = 1; print $LongHelp . "\n" if defined $LongHelp; print "Summary of options:\n"; foreach $opt (@$argtable) { ($option, $type, $num, $value, $help, $argdesc) = @$opt; if ($type eq "section") { printf "\n-- %s %s\n", $option, "-" x ($numcols-4-length($option)); next; } next unless defined $help; $argdesc = "" unless defined $argdesc; my $show_default = $show_defaults && $help !~ /\[default/; $~ = 'STANDARD'; if ($type eq 'boolean') { undef $option; # arg! why is this necessary? my ($pos, $neg) = &split_option ($opt); $option = $pos; $help .= ' [default]' if $show_default && defined $$value && $$value; write; $help = "opposite of $pos"; $help .= ' [default]' if $show_default && defined $$value && ! $$value; $option = $neg; write; } else { # If the option type is of the argument-taking variety, then # we'll try to help out by saying what the default value(s) # is/are if ($OptionHandlers{$type} == \&process_pattern_option) { if ($num == 1) # expectes a scalar value { $help .= ' [default: ' . quote_strings ($$value) . ']' if ($show_default && defined $$value); } else # expects a vector value { $help .= ' [default: ' . quote_strings (@$value) . ']' if ($show_default && @$value && ! grep (! defined $_, @$value)); } } if ($argdesc) { my $expanded_option = $option . " " . $argdesc if $argdesc; $option = $expanded_option; if (length ($expanded_option) > $maxoption+1) { $~ = 'ALTERNATIVE'; } } write; } } print "\n"; print $Usage if defined $Usage; } # # &scan_table # # walks through an argument table, building a hash that lets us quickly # and painlessly look up an option. # sub scan_table { my ($argtable, $arghash) = @_; my ($opt, $option, $type, $value); my $i; for $i (0 .. $#$argtable) { $opt = $argtable->[$i]; ($option, $type, $value) = @$opt; unless (exists $OptionHandlers{$type}) { croak "Unknown option type \"$type\" supplied for option $option"; } if ($type eq "boolean") { my ($pos,$neg) = &split_option($opt); $arghash->{$pos} = $i; $arghash->{$neg} = $i if defined $neg; } elsif ($type ne "section") { $arghash->{$option} = $i; } } } # # &match_abbreviation # # Given a string $s and a list of words @$words, finds the word for which # $s is a non-ambiguous abbreviation. If $s is found to be ambiguous or # doesn't match, a clear and concise error message is printed, using # $err_format as a format for sprintf. Suggested form for $err_format is # "%s option: %s"; the first %s will be substituted with either "ambiguous" # or "unknown" (depending on the problem), and the second will be # substituted with $s. Thus, with this format, the error message will look # something like "unknown option: -foo" or "ambiguous option: -f". # sub match_abbreviation { my ($s, $words, $err_format) = @_; my ($match); my $word; foreach $word (@$words) { # If $s is a prefix of $word, it's at least an approximate match, # so try to do better next unless ($s eq substr ($word, 0, length ($s))); # We have an exact match, so return it now return $word if ($s eq $word); # We have an approx. match, and already had one before if ($match) { &SetError ("bad_option", sprintf ("$err_format", "ambiguous", $s)); return 0; } $match = $word; } &SetError ("bad_option", sprintf ("$err_format", "unknown", $s)) if !$match; $match; } # # &option_error # # Constructs a useful error message to deal with an option that expects # a certain number of values of certain types, but a command-line that # falls short of this mark. $option should be the option that triggers # the situation; $type should be the expected type; $n should be the # number of values expected. # # The error message (returned by the function) will look something like # "-foo option must be followed by an integer" (yes, it does pick "a" # or "an", depending on whether the description of the type starts # with a vowel) or "-bar option must be followed by 3 strings". # # The error message is put in the global $ErrorMessage, as well as returned # by the function. Also, the global $ErrorClass is set to "bad_value". # sub option_error { my ($option, $type, $n) = @_; my ($typedesc, $singular, $plural, $article, $desc); $typedesc = $TypeDescriptions{$type}; ($singular,$plural) = (ref $typedesc eq 'ARRAY') ? @$typedesc : ($typedesc, $typedesc . "s"); $article = ($typedesc =~ /^[aeiou]/) ? "an" : "a"; $desc = ($n > 1) ? "$n $plural" : "$article $singular"; &SetError ("bad_value", "$option option must be followed by $desc"); } # # &check_value # # Verifies that a value (presumably from the command line) satisfies # the requirements for the expected type. # # Calls &option_error (to set $ErrorClass and $ErrorMessage globals) and returns # 0 if the value isn't up to scratch. # sub check_value { my ($val, $option, $type, $n) = @_; unless (defined $val && $val =~ /^$Patterns{$type}$/x) { &option_error ($option, $type, $n); return 0; } } # # &split_option # # Splits a boolean option into positive and negative alternatives. The # two alternatives are returned as a two-element array. # # Croaks if it can't figure out the alternatives, or if there appear to be # more than 2 alternatives specified. # sub split_option { my ($opt_desc) = @_; my ($option, @options); $option = $opt_desc->[0]; return ($option) if $opt_desc->[1] ne "boolean"; @options = split ('\|', $option); if (@options == 2) { return @options; } elsif (@options == 1) { my ($pattern, $prefix, $positive_alt, $negative_alt); for $pattern (@OptionPatterns) { my ($prefix, $body); if (($prefix, $body) = $option =~ /^$pattern$/) { $negative_alt = $prefix . "no" . $body; return ($option, $negative_alt); } } croak "Boolean option \"$option\" did not match " . "any option prefixes - unable to guess negative alternative"; return ($option); } else { croak "Too many alternatives supplied for boolean option \"$option\""; } } # # &find_calling_package # # walks up the call stack until we find a caller in a different package # from the current one. (Handy for `eval' options, when we want to # eval a chunk of code in the package that called GetOptions.) # sub find_calling_package { my ($i, $this_pkg, $up_pkg, @caller); $i = 0; $this_pkg = (caller(0))[0]; while (@caller = caller($i++)) { $up_pkg = $caller[0]; last if $up_pkg ne $this_pkg; } $up_pkg; } # ---------------------------------------------------------------------- # Option-handling routines: # process_constant_option # process_boolean_option # process_call_option # process_eval_option # ---------------------------------------------------------------------- # General description of these routines: # * each one is passed exactly four options: # $arg - the argument that triggered this routine, expanded # into unabbreviated form # $arglist - reference to list containing rest of command line # $opt_desc - reference to an option descriptor list # $spoof - flag: if true, then no side effects # * they are called from GetOptions, through code references in the # %OptionHandlers hash # * if they return a false value, then GetOptions immediately returns # 0 to its caller, with no error message -- thus, the option handlers # should print out enough of an error message for the end user to # figure out what went wrong; also, the option handlers should be # careful to explicitly return 1 if everything went well! sub process_constant_option { my ($arg, $arglist, $opt_desc, $spoof) = @_; my ($type, $n, $value) = @$opt_desc[1,2,3]; return 1 if $spoof; if ($type eq "const") { $$value = $n; } elsif ($type eq "copy") { $$value = (defined $n) ? ($n) : ($arg); } elsif ($type eq "arrayconst") { @$value = @$n; } elsif ($type eq "hashconst") { %$value = %$n; } else { confess ("internal error: can't handle option type \"$type\""); } 1; } sub process_boolean_option { my ($arg, $arglist, $opt_desc, $spoof) = @_; my ($value) = $$opt_desc[3]; return 1 if $spoof; my ($pos,$neg) = &split_option ($opt_desc); confess ("internal error: option $arg not found in argument hash") if ($arg ne $pos && $arg ne $neg); $$value = ($arg eq $pos) ? 1 : 0; 1; } sub process_call_option { my ($arg, $arglist, $opt_desc, $spoof) = @_; my ($option, $args, $value) = @$opt_desc[0,2,3]; croak "Invalid option table entry for option \"$option\" -- \"value\" " . "field must be a code reference" unless (ref $value eq 'CODE'); # This will crash 'n burn big time if there is no spoof code for # this option -- but that's why we check %SpoofCode against the # arg table from GetOptions! $value = $SpoofCode{$arg} if ($spoof); my @args = (ref $args eq 'ARRAY') ? (@$args) : (); my $result = &$value ($arg, $arglist, @args); if (!$result) { # Wouldn't it be neat if we could get the sub name from the code ref? &SetError ($ErrorClass || "bad_call", $ErrorMessage || "subroutine call from option \"$arg\" failed"); } return $result; } # &process_call_option sub process_eval_option { my ($arg, $arglist, $opt_desc, $spoof) = @_; my ($value) = $$opt_desc[3]; $value = $SpoofCode{$arg} if ($spoof); my $up_pkg = &find_calling_package (); # print "package $up_pkg; $value"; # DEBUG ONLY my $result = eval "package $up_pkg; no strict; $value"; if ($@) # any error string set? { &SetError ("bad_eval", "error evaluating \"$value\" (from $arg option): $@"); return 0; } if (!$result) { &SetError ($ErrorClass || "bad_call", $ErrorMessage || "code eval'd for option \"$arg\" failed"); } return $result; } sub process_pattern_option { my ($arg, $arglist, $opt_desc, $spoof) = @_; my ($type, $n, $value) = @$opt_desc[1,2,3]; my ($dummy, @dummies); # This code looks a little more complicated than you might at first # think necessary. But the ugliness is necessary because $value might # reference a scalar or an array, depending on whether $n is 1 (scalar) # or not (array). Thus, we can't just assume that either @$value or # $$value is valid -- we always have to check which of the two it should # be. if ($n == 1) # scalar-valued option (one argument) { croak "GetOptions: \"$arg\" option must be associated with a scalar ref" unless ref $value eq 'SCALAR'; $value = \$dummy if $spoof; $$value = shift @$arglist; return 0 unless &check_value ($$value, $arg, $type, $n); } else # it's a "vector-valued" option { # (fixed number of arguments) croak "GetOptions: \"$arg\" option must be associated with an array ref" unless ref $value eq 'ARRAY'; $value = \@dummies if $spoof; @$value = splice (@$arglist, 0, $n); if (scalar @$value != $n) { &option_error ($arg, $type, $n); return 0; } my $val; foreach $val (@$value) { return 0 unless &check_value ($val, $arg, $type, $n); } } # else return 1; } # &process_pattern_option # -------------------------------------------------------------------- # The main public subroutine: GetOptions # -------------------------------------------------------------------- sub GetOptions { my ($opt_table, $arglist, $new_arglist, $spoof) = @_; my (%argpos, $arg, $pos, $opt_ref); my ($option_re, @option_list); $new_arglist = $arglist if !defined $new_arglist; &SetError ("", ""); # Build a hash mapping option -> position in option table &scan_table ($opt_table, \%argpos); # Regexp to let us recognize options on the command line $option_re = join ("|", @OptionPatterns); # Build a list of all acceptable options -- used to match abbreviations my $opt_desc; foreach $opt_desc (@$opt_table) { push (@option_list, &split_option ($opt_desc)) unless $opt_desc->[1] eq "section"; } push (@option_list, $HelpOption) if $HelpOption; # If in spoof mode: make sure we have spoof code for all call/eval options if ($spoof) { my ($opt, $type, $spoof); foreach $opt_desc (@$opt_table) { $opt = $opt_desc->[0]; $type = $opt_desc->[1]; $spoof = $SpoofCode{$opt}; next unless $type eq 'call' || $type eq 'eval'; croak "No alternate code supplied for option $opt in spoof mode" unless defined $spoof; croak "Alternate code must be a CODE ref for option $opt" if ($type eq 'call' && ref $spoof ne 'CODE'); croak "Alternate code must be a string for option $opt" if ($type eq 'eval' && ref $spoof); } } # Now walk over the argument list my @tmp_arglist = @$arglist; @$new_arglist = (); while (defined ($arg = shift @tmp_arglist)) { # print "arg: $arg\n"; # If this argument is the option terminator (usually "--") then # transfer all remaining arguments to the new arg list and stop # processing immediately. if (defined $OptionTerminator && $arg eq $OptionTerminator) { push (@$new_arglist, @tmp_arglist); last; } # If this argument isn't an option at all, just append it to # @$new_arglist and go to the next one. if ($arg !~ /^($option_re)/o) { push (@$new_arglist, $arg); next; } # We know we have something that looks like an option; see if it # matches or is an abbreviation for one of the strings in # @option_list $arg = &match_abbreviation ($arg, \@option_list, "%s option: %s"); if (! $arg) { warn $Usage if defined $Usage; warn "$ErrorMessage\n"; return 0; } # If it's the help option, print out the help and return # (even if in spoof mode!) if ($arg eq $HelpOption) { &print_help ($opt_table); &SetError ("help", ""); return 0; } # Now we know it's a valid option, and it's not the help option -- # so it must be in the caller's option table. Look up its # entry there, and use that for the actual option processing. $pos = $argpos{$arg}; confess ("internal error: didn't find arg in arg hash even " . "after resolving abbreviation") unless defined $pos; my $opt_desc = $opt_table->[$pos]; my $type = $opt_desc->[1]; my $handler = $OptionHandlers{$type}; if (defined $handler && ref ($handler) eq 'CODE') { if (! &$handler ($arg, \@tmp_arglist, $opt_desc, $spoof)) { warn $Usage if defined $Usage; warn "$ErrorMessage\n"; return 0; } } else { croak "Unknown option type \"$type\" (found for arg $arg)"; } } # while ($arg = shift @$arglist) return 1; } # GetOptions sub SpoofGetOptions { &GetOptions (@_[0..2], 1); } 1; Getopt-Tabular-0.3/MANIFEST100444 764 144 110 6352300617 13637 0ustar gregusersMANIFEST README Changes Makefile.PL Tabular.pm Tabular.pod demo test.pl Getopt-Tabular-0.3/Makefile.PL100444 764 144 426 6702773212 14476 0ustar gregusersuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Getopt::Tabular', 'VERSION_FROM' => 'Tabular.pm', 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" } ); Getopt-Tabular-0.3/Changes100444 764 144 1051 6703002250 14016 0ustar gregusersVersion 0.3 (7 Apr 1999, Greg Ward ) ----------- * help string now shows default parameter values and "negative" boolean options * no more dependence on `tput cols` for width of help text -- just hard-code 80 columns! Version 0.2 (18 Jun 1997, Greg Ward ) ----------- * changed to support "spoof" argument parsing (for minimal-side-effect checking of command-line) * added test program Version 0.1 (10 Nov 1996, Greg Ward ) ----------- * first public release Getopt-Tabular-0.3/test.pl100444 764 144 14367 6372661640 14115 0ustar gregusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) my $loaded; BEGIN { $| = 1; print "1..9\n"; } END {print "not ok 1\n" unless $loaded;} use strict; use Getopt::Tabular; $loaded = 1; print "ok 1\n"; my $test_count = 1; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): my $warning; my $num_warnings = 0; sub catch_warn { $warning = $_[0]; $num_warnings++; } sub warning { my $w = $warning; undef $warning; $w; } sub list_equal { my ($eq, $a, $b) = @_; die "lequal: \$a and \$b not lists" unless ref $a eq 'ARRAY' && ref $b eq 'ARRAY'; return 0 unless @$a == @$b; # compare lengths my @eq = map { &$eq ($a->[$_], $b->[$_]) } (0 .. $#$a); return 0 unless (grep ($_ == 1, @eq)) == @eq; } sub slist_equal { my ($a, $b) = @_; list_equal (sub { $_[0] eq $_[1] }, $a, $b); } sub nlist_equal { my ($a, $b) = @_; list_equal (sub { $_[0] == $_[1] }, $a, $b); } sub clear_values { my ($types, $vals) = @_; my ($k, $t); foreach $k (keys %$types) { $t = $types->{$k}; ($t =~ /^[bns]$/) and undef $vals->{$k}; ($t =~ /^[ns]l$/) and @{$vals->{$k}} = (); } } sub values_equal { my ($types, $a, $b) = @_; my ($k, $t); # return 0 # unless slist_equal ([keys %$types], [keys %$a]) && # slist_equal ([keys %$a], [keys %$b]); foreach $k (keys %$types) { $t = $types->{$k}; # next unless exists $a->{$k} && exists $b->{$k}; # first make sure that the defined-ness of $a->{$k} and $b->{$k} # are the same !(defined $a->{$k} xor defined $b->{$k}) || return 0; # now the type-dependent comparison ($t eq 'b') && (( !($a->{$k} xor $b->{$k}) || return 0), next); ($t eq 'n') && (($a->{$k} == $b->{$k} || return 0), next); ($t eq 's') && (($a->{$k} eq $b->{$k} || return 0), next); ($t eq 'nl') && ((nlist_equal ($a->{$k}, $b->{$k}) || return 0), next); ($t eq 'sl') && ((slist_equal ($a->{$k}, $b->{$k}) || return 0), next); die "unknown type \"$t\""; } return 1; } sub test { my ($ok) = @_; printf "%s %d\n", ($ok ? "ok" : "not ok"), ++$test_count; } sub test_parse { my ($opt_table, $args, $types, $values, $exp_leftovers, $exp_values, $exp_output, $exp_error) = @_; my ($k, $leftovers, $ok); $SIG{'__WARN__'} = \&catch_warn; clear_values ($types, $values); $leftovers = []; GetOptions ($opt_table, $args, $leftovers); delete $SIG{'__WARN__'}; $ok = 1; unless (slist_equal ($leftovers, $exp_leftovers)) { warn "leftovers don't match\n"; $ok = 0; } unless (values_equal ($types, $values, $exp_values)) { warn "values don't match\n"; $ok = 0; } if ($exp_error && warning !~ /$exp_error/) { warn "warning message doesn't match\n"; $ok = 0; } test ($ok); } # &test my @foo = (); sub get_foo { my ($arg, $args) = @_; my $next; # print "Hello, you have used the $arg option\n"; unless (@$args) { &Getopt::Tabular::SetError ("bad_foo", "no arguments found for $arg option"); return 0; } while ($next = shift @$args) { last if $next =~ /^-/; push (@foo, $next); # print "Got $next from \@\$args\n"; } if (defined $next) # not the last option? { # print "Putting $next back on \@\$args\n"; unshift (@$args, $next); } 1; } my %vals = (ints => [], float => undef, string => undef, flag => undef); my %types = (ints => 'nl', float => 'n', string => 's', flag => 'b'); my @opt_table = (['-int', 'integer', 2, $vals{ints}, 'two integers', 'i1 i2'], ['-float', 'float', 1, \$vals{float}, 'a floating-point number' ], ['-string', 'string', 1, \$vals{string}, 'a string' ], ['-flag', 'boolean', 0, \$vals{flag}, 'a boolean flag' ], ['-foo', 'call', 0, \&get_foo, 'do nothing important'], ['-show', 'eval', 0, 'print "Ints = @Ints\n";', 'print the current values of -int option'] ); # command line with no options: leftovers should be same as whole arg list test_parse (\@opt_table, [qw(hello there)], \%types, \%vals, [qw(hello there)], { ints => [] }, '', ''); # with options, but no leftovers: test_parse (\@opt_table, [qw(-int 3 4 -string FOO!)], \%types, \%vals, [], { ints => [3, 4], string => 'FOO!' }, '', ''); # options and leftovers mixed up together test_parse (\@opt_table, [qw(hello -int 2 -5 there -string barf)], \%types, \%vals, [qw(hello there)], { ints => [2, -5], string => 'barf' }, '', ''); # similar, but add boolean option test_parse (\@opt_table, [qw(-flag how -int 2 -5 are you -string frab)], \%types, \%vals, [qw(how are you)], { ints => [2, -5], string => 'frab', flag => 1 }, '', ''); # now add callback option test_parse (\@opt_table, [qw(-flag how -int 2 -5 are you -foo x1 x2 -string frab)], \%types, \%vals, [qw(how are you)], { ints => [2, -5], string => 'frab', flag => 1 }, '', ''); test (slist_equal (\@foo, [qw(x1 x2)])); # same, but with a negation of the boolean option later in the arg list # and a different way of using the callback test_parse (\@opt_table, [qw(-flag bang -int 2 -5 pow! -noflag -foo bing bong bang)], \%types, \%vals, [qw(bang pow!)], { ints => [2, -5], flag => 0 }, '', ''); test (slist_equal (\@foo, [qw(x1 x2 bing bong bang)])); # still need to test: # argument errors (ie. warnings) # table errors (catch `die') # custom patterns (eg. uppercase string) # spoof parsing Getopt-Tabular-0.3/Tabular.pod100444 764 144 117737 6461144155 14720 0ustar gregusersNOTE to myself -- this pod needs to be updated to have option patterns described! =head1 NAME Getopt::Tabular - table-driven argument parsing for Perl 5 =head1 SYNOPSIS use Getopt::Tabular; (or) use Getopt::Tabular qw/GetOptions SetHelp SetHelpOption SetError GetError/; ... &Getopt::Tabular::SetHelp (long_help, usage_string); @opt_table = ( [section_description, "section"], [option, type, num_values, option_data, help_string], ... ); &GetOptions (\@opt_table, \@ARGV [, \@newARGV]) || exit 1; =head1 DESCRIPTION B is a Perl 5 module for table-driven argument parsing, vaguely inspired by John Ousterhout's Tk_ParseArgv. All you really need to do to use the package is set up a table describing all your command-line options, and call &GetOptions with three arguments: a reference to your option table, a reference to C<@ARGV> (or something like it), and an optional third array reference (say, to C<@newARGV>). &GetOptions will process all arguments in C<@ARGV>, and copy any leftover arguments (i.e. those that are not options or arguments to some option) to the C<@newARGV> array. (If the C<@newARGV> argument is not supplied, C will replace C<@ARGV> with the stripped-down argument list.) If there are any invalid options, C will print an error message and return 0. Before I tell you all about why Getopt::Tabular is a wonderful thing, let me explain some of the terminology that will keep popping up here. =over 4 =item argument any single word appearing on the command-line, i.e. one element of the C<@ARGV> array. =item option an argument that starts with a certain sequence of characters; the default is "-". (If you like GNU-style options, you can change this to "--".) In most Getopt::Tabular-based applications, options can come anywhere on the command line, and their order is unimportant (unless one option overrides a previous option). Also, Getopt::Tabular will allow any non-ambiguous abbreviation of options. =item option argument (or I) an argument that immediately follows certain types of options. For instance, if C<-foo> is a scalar-valued integer option, and C<-foo 3> appears on the command line, then C<3> will be the argument to C<-foo>. =item option type controls how C deals with an option and the arguments that follow it. (Actually, for most option types, the type interacts with the C field, which determines whether the option is scalar- or vector-valued. This will be fully explained in due course.) =back =head1 FEATURES Now for the advertising, i.e. why Getopt::Tabular is a good thing. =over 4 =item * Command-line arguments are carefully type-checked, both by pattern and number---e.g. if an option requires two integers, GetOptions makes sure that exactly two integers follow it! =item * The valid command-line arguments are specified in a data structure separate from the call to GetOptions; this makes it easier to have very long lists of options, and to parse options from multiple sources (e.g. the command line, an environment variable, and a configuration file). =item * Getopt::Tabular can intelligently generate help text based on your option descriptions. =item * The type system is extensible, and if you can define your desired argument type using a single Perl regular expression then it's particularly easy to extend. =item * To make your program look smarter, options can be abbreviated and come in any order. =item * You can parse options in a "spoof" mode that has no side-effects -- this is useful for making a validation pass over the command line without actually doing anything. =back In general, I have found that Getopt::Tabular tends to encourage programs with long lists of sophisticated options, leading to great flexibility, intelligent operation, and the potential for insanely long command lines. =head1 BASIC OPERATION The basic operation of Getopt::Tabular is driven by an I