develooper Front page | perl.perl5.porters | Postings from December 2001

[BUG] & [PATCH] (tentative) GetOpt::Long

From:
Wolfgang Laun
Date:
December 20, 2001 03:20
Subject:
[BUG] & [PATCH] (tentative) GetOpt::Long
Message ID:
3C21C950.24F5ED65@alcatel.at
Gunter Welker wrote:
> 
> The problem arose from a students' exercise. There we had more options
> (besides -a -l --all also --almost-all) and we expected a message like
> Ambiguous option --a when entering --a. In such a case it really does
> not make sense to set $opt_a! This made me write the bug report to have
> this function work as expected. Thanks for your help.
> 

Hi Johan,

I couldn't resist and had a go at that problem. Then I found out that
a simple repetetion of an option definition:

   GetOptions ("foo=i" => \$fooi,
               "foo=s" => \$foos );

does not cause an error, and that an error in an option with linkage:

   GetOptions (":foo" => \$foo );

prints 2 errors:
   Error in option spec: ":foo"
   Error in option spec: "SCALAR(0x80f642c)"


I've corrected these (I hope) in the patch below, which also includes
an option to force uniqueness, in the sense that no option may be the
initial substring of another (except between aliases: "foofoo|foo" is ok).

Would you please have a look, and decide whatever you seem fit.

Thanks
-W

--- lib/Getopt/Long.pm.old	Thu Dec 20 10:26:20 2001
+++ lib/Getopt/Long.pm	Thu Dec 20 11:50:37 2001
@@ -56,7 +56,7 @@
 use vars qw($error $debug $major_version $minor_version);
 # Deprecated visible variables.
 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
-	    $passthrough);
+	    $passthrough $unique);
 # Official invisible variables.
 use vars qw($genprefix $caller $gnu_compat);
 
@@ -98,6 +98,7 @@
     $ignorecase = 1;		# ignore case when matching options
     $passthrough = 0;		# leave unrecognized options alone
     $gnu_compat = 0;		# require --opt=val if value is optional
+    $unique = 0;                # option may be another's initial substr
 }
 
 # Override import.
@@ -270,7 +271,8 @@
 		  "\n  ",
 		  "ignorecase=$ignorecase,",
 		  "passthrough=$passthrough,",
-		  "genprefix=\"$genprefix\".",
+		  "genprefix=\"$genprefix\",",
+                  "unique=\"$unique\".",
 		  "\n")
 	if $debug;
 
@@ -327,7 +329,10 @@
 	unless ( defined $name ) {
 	    # Failed. $orig contains the error message. Sorry for the abuse.
 	    $error .= $orig;
-	    next;
+            # kill the linkage (to avoid another error)
+	    shift (@optionlist)
+		if @optionlist > 0 && ref($optionlist[0]);
+            next;
 	}
 
 	# If no linkage is supplied in the @optionlist, copy it from
@@ -574,7 +579,7 @@
 
 	# ...otherwise, terminate.
 	else {
-	    # Push this one back and exit.
+    # Push this one back and exit.
 	    unshift (@ARGV, $tryopt);
 	    return ($error == 0);
 	}
@@ -666,11 +671,16 @@
     }
 
     # Process all names. First is canonical, the rest are aliases.
+    my( @tocheck, $err );
     foreach ( @names ) {
-
 	$_ = lc ($_)
 	  if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
+        push( @tocheck,  $spec eq '!' ? ($_, "no$_") : ( $_ ) );
+    }
+    $err = checkunique( $opctl, @tocheck );
+    return ( undef, $err ) if $err;
 
+    foreach ( @names ) {
 	if ( $spec eq '!' ) {
 	    $opctl->{"no$_"} = $entry;
 	    $opctl->{$_} = [@$entry];
@@ -680,10 +690,35 @@
 	    $opctl->{$_} = $entry;
 	}
     }
-
     ($names[0], $orig);
 }
 
+
+sub checkunique($@){
+    my $opctl = shift();
+    my $err = '';
+
+    for my $name ( @_ ){
+        # Check for unique: no option may be the initial substring of
+        # another one.
+        if( $unique ){
+            for my $opt ( keys( %$opctl ) ){
+                if( $name =~ /^$opt.+$/ || $opt =~ /^$name.+$/ ){
+                    $err .= "unique: \"$name\" and \"$opt\" mutually exclusive\n";
+                }
+            }
+        }
+
+        # An exact repetition is always an error
+        #
+        if( exists( $opctl->{$name} ) ){
+            $err .= "Duplicate definition for option \"$name\"\n";
+        }
+    }
+    return $err;
+}
+
+
 # Option lookup.
 sub FindOption ($$$$) {
 
@@ -969,12 +1004,12 @@
     my $prevconfig =
       [ $error, $debug, $major_version, $minor_version,
 	$autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
-	$gnu_compat, $passthrough, $genprefix ];
+	$gnu_compat, $passthrough, $genprefix, $unique ];
 
     if ( ref($options[0]) eq 'ARRAY' ) {
 	( $error, $debug, $major_version, $minor_version,
 	  $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
-	  $gnu_compat, $passthrough, $genprefix ) = @{shift(@options)};
+	  $gnu_compat, $passthrough, $genprefix, $unique ) = @{shift(@options)};
     }
 
     my $opt;
@@ -1049,6 +1084,9 @@
 	elsif ( $try eq 'debug' ) {
 	    $debug = $action;
 	}
+	elsif ( $try eq 'unique' ) {
+	    $unique = $action;
+	}
 	else {
 	    Croak ("Getopt::Long: unknown config parameter \"$opt\"")
 	}
@@ -1815,6 +1853,13 @@
 A Perl pattern that identifies the strings that introduce options.
 Default is C<(--|-|\+)> unless environment variable
 POSIXLY_CORRECT has been set, in which case it is C<(--|-)>.
+
+=item unique (default: disabled)
+
+This disallows any option that is the initial substring of another
+option. If disabled, options C<foo> I<and> C<foobar> could be used:
+C<--f> and C<--fo> would cause an error; C<--foo> would mean C<foo>,
+and C<--foob> etc. would mean C<foobar>.
 
 =item debug (default: disabled)



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About