Implement support for --help and --version in Getopt::Std

Subject: Re: [PATCH 5.8.1 @19053] Getopt::Std
Message-ID: <20030408000714.GA953@math.berkeley.edu>

p4raw-id: //depot/perl@19171

1 files changed, 99 insertions, 4 deletions

diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm
index 4599ec54d8..99e9269676 100644
--- a/lib/Getopt/Std.pm
+++ b/lib/Getopt/Std.pm
@@ -46,11 +46,33 @@ To allow programs to process arguments that look like switches, but aren'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 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.
+
+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.04';
+# 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
@@ -112,25 +134,86 @@ sub getopt (;$$) {
     }
 }
 
+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
+    }
+}
+
 # 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);
@@ -163,6 +246,18 @@ sub getopts ($;$) {
 	    }
 	}
 	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 '') {