=head1 NAME
-getopt - Process single-character switches with switch clustering
-
-getopts - Process single-character switches with switch clustering
+getopt, getopts - Process single-character switches with switch clustering
=head1 SYNOPSIS
The getopt() function processes single-character switches with switch
clustering. Pass one argument which is a string containing all switches
that take an argument. For each switch found, sets $opt_x (where x is the
-switch name) to the value of the argument, or 1 if no argument. Switches
-which take an argument don't care whether there is a space between the
-switch and the argument.
+switch name) to the value of the argument if an argument is expected,
+or 1 otherwise. Switches which take an argument don't care whether
+there is a space between the switch and the argument.
The getopts() function is similar, but you should pass to it the list of all
switches to be recognized. If unspecified switches are found on the
command-line, the user will be warned that an unknown option was given.
+The getopts() function returns true unless an invalid option was found.
Note that, if your code is running under the recommended C<use strict
'vars'> pragma, you will need to declare these package variables
both functions will stop processing switches when they see the argument
C<-->. The C<--> will be removed from @ARGV.
+=head1 C<--help> and C<--version>
+
+If C<-> is not a recognized switch letter, getopts() supports arguments
+C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or
+C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are
+the output file handle, the name of option-processing package, its version,
+and the switches string. If the subroutines are not defined, an attempt is
+made to generate intelligent messages; for best results, define $main::VERSION.
+
+If embedded documentation (in pod format, see L<perlpod>) is detected
+in the script, C<--help> will also show how to access the documentation.
+
+Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION
+isn't true (the default is false), then the messages are printed on STDERR,
+and the processing continues after the messages are printed. This being
+the opposite of the standard-conforming behaviour, it is strongly recommended
+to set $Getopt::Std::STANDARD_HELP_VERSION to true.
+
+One can change the output file handle of the messages by setting
+$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help>
+(without the C<Usage:> line) and C<--version> by calling functions help_mess()
+and version_mess() with the switches string as an argument.
+
=cut
@ISA = qw(Exporter);
@EXPORT = qw(getopt getopts);
-$VERSION = '1.03';
+$VERSION = '1.06';
+# uncomment the next line to disable 1.03-backward compatibility paranoia
+# $STANDARD_HELP_VERSION = 1;
# Process single-character switches with switch clustering. Pass one argument
# which is a string containing all switches that take an argument. For each
}
}
+sub output_h () {
+ return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION;
+ return \*STDOUT if $STANDARD_HELP_VERSION;
+ return \*STDERR;
+}
+
+sub try_exit () {
+ exit 0 if $STANDARD_HELP_VERSION;
+ my $p = __PACKAGE__;
+ print {output_h()} <<EOM;
+ [Now continuing due to backward compatibility and excessive paranoia.
+ See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.]
+EOM
+}
+
+sub version_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::VERSION_MESSAGE) {
+ main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my $v = $main::VERSION;
+ $v = '[unknown]' unless defined $v;
+ my $myv = $VERSION;
+ $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION;
+ my $perlv = $];
+ $perlv = sprintf "%vd", $^V if $] >= 5.006;
+ print $h <<EOH;
+$0 version $v calling Getopt::Std::getopts (version $myv),
+running under Perl version $perlv.
+EOH
+ }
+}
+
+sub help_mess ($;$) {
+ my $args = shift;
+ my $h = output_h;
+ if (@_ and defined &main::HELP_MESSAGE) {
+ main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args);
+ } else {
+ my (@witharg) = ($args =~ /(\S)\s*:/g);
+ my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g);
+ my ($help, $arg) = ('', '');
+ if (@witharg) {
+ $help .= "\n\tWith arguments: -" . join " -", @witharg;
+ $arg = "\nSpace is not required between options and their arguments.";
+ }
+ if (@rest) {
+ $help .= "\n\tBoolean (without arguments): -" . join " -", @rest;
+ }
+ my ($scr) = ($0 =~ m,([^/\\]+)$,);
+ print $h <<EOH if @_; # Let the script override this
+
+Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
+EOH
+ print $h <<EOH;
+
+The following single-character options are accepted:$help
+
+Options may be merged together. -- stops processing of options.$arg
+EOH
+ my $has_pod;
+ if ( defined $0 and $0 ne '-e' and -f $0 and -r $0
+ and open my $script, '<', $0 ) {
+ while (<$script>) {
+ $has_pod = 1, last if /^=(pod|head1)/;
+ }
+ }
+ print $h <<EOH if $has_pod;
+
+For more details run
+ perldoc -F $0
+EOH
+ }
+}
+
# Usage:
# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
# # side effect.
sub getopts ($;$) {
my ($argumentative, $hash) = @_;
- my (@args,$first,$rest);
+ my (@args,$first,$rest,$exit);
my $errs = 0;
local $_;
local @EXPORT;
@args = split( / */, $argumentative );
- while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
+ while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) {
($first,$rest) = ($1,$2);
if (/^--$/) { # early exit if --
shift @ARGV;
last;
}
- $pos = index($argumentative,$first);
+ my $pos = index($argumentative,$first);
if ($pos >= 0) {
if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) {
shift(@ARGV);
}
}
else {
+ if ($first eq '-' and $rest eq 'help') {
+ version_mess($argumentative, 'main');
+ help_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ } elsif ($first eq '-' and $rest eq 'version') {
+ version_mess($argumentative, 'main');
+ try_exit();
+ shift(@ARGV);
+ next;
+ }
warn "Unknown option: $first\n";
++$errs;
if ($rest ne '') {
projects / p5sagit/p5-mst-13.2.git / blobdiff