[PATCH 5.8.1 @19053] Getopt::Std

Front page | perl.perl5.porters | Postings from April 2003

[PATCH 5.8.1 @19053] Getopt::Std

Thread Next

From:

Ilya Zakharevich

Date:

April 1, 2003 15:58

Subject:

[PATCH 5.8.1 @19053] Getopt::Std

Message ID:

20030401235830.GA4912@math.berkeley.edu

This patch updates getopts() to the world of today.

Please think about how to make the messages more readable.

Enjoy,
Ilya

--- ./lib/Getopt/Std.pm-pre	Fri Jul 19 16:49:48 2002
+++ ./lib/Getopt/Std.pm	Tue Apr  1 15:54:48 2003
@@ -46,11 +46,26 @@ To allow programs to process arguments t
 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 option letter, getopts() supports arguments
+C<--help> and C<--version>.  If C<HELP_MESSAGE()> or C<VERSION_MESSAGE()> are
+defined in the package C<main>, they are called (with the switches string
+and C<GetOpt::Std> version as arguments); if not, an attempt is made to
+generate intelligent messages; for best results, define $main::VERSION.
+
+In presence of these arguments getopts() calls
+C<exit($GetOpt::Std::EXIT_ON_HELP_VERSION)> if
+$GetOpt::Std::EXIT_ON_HELP_VERSION is defined.
+
+One can print the messages of C<--help> 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.04';
 
 # Process single-character switches with switch clustering.  Pass one argument
 # which is a string containing all switches that take an argument.  For each
@@ -112,19 +127,57 @@ sub getopt (;$$) {
     }
 }
 
+sub version_mess ($;$) {
+    my $args = shift;
+    if (@ARGV and defined &main::VERSION_MESSAGE) {
+	main::VERSION_MESSAGE($args, $VERSION);
+    } else {
+	my $v = $main::VERSION;
+	$v = '[unknown]' unless defined $v;
+	print <<EOH;
+$0 version $v calling Getopt::Std::getopts (version $VERSION),
+running under Perl version $].
+EOH
+    }
+}
+
+sub help_mess ($;$) {
+    my $args = shift;
+    if (@ARGV and defined &main::HELP_MESSAGE) {
+	main::HELP_MESSAGE($args, $VERSION);
+    } 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 <<EOH;
+Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...]
+The following single-character options are accepted:$help
+Options may be merged together.  -- stops processing of options.$arg
+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;
@@ -163,6 +216,18 @@ sub getopts ($;$) {
 	    }
 	}
 	else {
+	    if ($first eq '-' and $rest eq 'help') {
+		version_mess($argumentative, 'main');
+		help_mess($argumentative, 'main');
+		shift(@ARGV);
+		$exit = 1;
+		next;
+	    } elsif ($first eq '-' and $rest eq 'version') {
+		version_mess($argumentative, 'main');
+		shift(@ARGV);
+		$exit = 1;
+		next;
+	    }
 	    warn "Unknown option: $first\n";
 	    ++$errs;
 	    if ($rest ne '') {
@@ -177,6 +242,7 @@ sub getopts ($;$) {
 	local $Exporter::ExportLevel = 1;
 	import Getopt::Std;
     }
+    exit $EXIT_ON_HELP_VERSION if $exit and defined $EXIT_ON_HELP_VERSION;
     $errs == 0;
 }

Thread Next