| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 # Getopt::Long.pm -- Universal options parsing 2 3 package Getopt::Long; 4 5 # RCS Status : $Id: Long.pm,v 2.74 2007/09/29 13:40:13 jv Exp $ 6 # Author : Johan Vromans 7 # Created On : Tue Sep 11 15:00:12 1990 8 # Last Modified By: Johan Vromans 9 # Last Modified On: Sat Sep 29 15:38:55 2007 10 # Update Count : 1571 11 # Status : Released 12 13 ################ Copyright ################ 14 15 # This program is Copyright 1990,2007 by Johan Vromans. 16 # This program is free software; you can redistribute it and/or 17 # modify it under the terms of the Perl Artistic License or the 18 # GNU General Public License as published by the Free Software 19 # Foundation; either version 2 of the License, or (at your option) any 20 # later version. 21 # 22 # This program is distributed in the hope that it will be useful, 23 # but WITHOUT ANY WARRANTY; without even the implied warranty of 24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 25 # GNU General Public License for more details. 26 # 27 # If you do not have a copy of the GNU General Public License write to 28 # the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 29 # MA 02139, USA. 30 31 ################ Module Preamble ################ 32 33 use 5.004; 34 35 use strict; 36 37 use vars qw($VERSION); 38 $VERSION = 2.37; 39 # For testing versions only. 40 use vars qw($VERSION_STRING); 41 $VERSION_STRING = "2.37"; 42 43 use Exporter; 44 use vars qw(@ISA @EXPORT @EXPORT_OK); 45 @ISA = qw(Exporter); 46 47 # Exported subroutines. 48 sub GetOptions(@); # always 49 sub GetOptionsFromArray($@); # on demand 50 sub GetOptionsFromString($@); # on demand 51 sub Configure(@); # on demand 52 sub HelpMessage(@); # on demand 53 sub VersionMessage(@); # in demand 54 55 BEGIN { 56 # Init immediately so their contents can be used in the 'use vars' below. 57 @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); 58 @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure 59 &GetOptionsFromArray &GetOptionsFromString); 60 } 61 62 # User visible variables. 63 use vars @EXPORT, @EXPORT_OK; 64 use vars qw($error $debug $major_version $minor_version); 65 # Deprecated visible variables. 66 use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order 67 $passthrough); 68 # Official invisible variables. 69 use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); 70 71 # Public subroutines. 72 sub config(@); # deprecated name 73 74 # Private subroutines. 75 sub ConfigDefaults(); 76 sub ParseOptionSpec($$); 77 sub OptCtl($); 78 sub FindOption($$$$$); 79 sub ValidValue ($$$$$); 80 81 ################ Local Variables ################ 82 83 # $requested_version holds the version that was mentioned in the 'use' 84 # or 'require', if any. It can be used to enable or disable specific 85 # features. 86 my $requested_version = 0; 87 88 ################ Resident subroutines ################ 89 90 sub ConfigDefaults() { 91 # Handle POSIX compliancy. 92 if ( defined $ENV{"POSIXLY_CORRECT"} ) { 93 $genprefix = "(--|-)"; 94 $autoabbrev = 0; # no automatic abbrev of options 95 $bundling = 0; # no bundling of single letter switches 96 $getopt_compat = 0; # disallow '+' to start options 97 $order = $REQUIRE_ORDER; 98 } 99 else { 100 $genprefix = "(--|-|\\+)"; 101 $autoabbrev = 1; # automatic abbrev of options 102 $bundling = 0; # bundling off by default 103 $getopt_compat = 1; # allow '+' to start options 104 $order = $PERMUTE; 105 } 106 # Other configurable settings. 107 $debug = 0; # for debugging 108 $error = 0; # error tally 109 $ignorecase = 1; # ignore case when matching options 110 $passthrough = 0; # leave unrecognized options alone 111 $gnu_compat = 0; # require --opt=val if value is optional 112 $longprefix = "(--)"; # what does a long prefix look like 113 } 114 115 # Override import. 116 sub import { 117 my $pkg = shift; # package 118 my @syms = (); # symbols to import 119 my @config = (); # configuration 120 my $dest = \@syms; # symbols first 121 for ( @_ ) { 122 if ( $_ eq ':config' ) { 123 $dest = \@config; # config next 124 next; 125 } 126 push(@$dest, $_); # push 127 } 128 # Hide one level and call super. 129 local $Exporter::ExportLevel = 1; 130 push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions 131 $pkg->SUPER::import(@syms); 132 # And configure. 133 Configure(@config) if @config; 134 } 135 136 ################ Initialization ################ 137 138 # Values for $order. See GNU getopt.c for details. 139 ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); 140 # Version major/minor numbers. 141 ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; 142 143 ConfigDefaults(); 144 145 ################ OO Interface ################ 146 147 package Getopt::Long::Parser; 148 149 # Store a copy of the default configuration. Since ConfigDefaults has 150 # just been called, what we get from Configure is the default. 151 my $default_config = do { 152 Getopt::Long::Configure () 153 }; 154 155 sub new { 156 my $that = shift; 157 my $class = ref($that) || $that; 158 my %atts = @_; 159 160 # Register the callers package. 161 my $self = { caller_pkg => (caller)[0] }; 162 163 bless ($self, $class); 164 165 # Process config attributes. 166 if ( defined $atts{config} ) { 167 my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); 168 $self->{settings} = Getopt::Long::Configure ($save); 169 delete ($atts{config}); 170 } 171 # Else use default config. 172 else { 173 $self->{settings} = $default_config; 174 } 175 176 if ( %atts ) { # Oops 177 die(__PACKAGE__.": unhandled attributes: ". 178 join(" ", sort(keys(%atts)))."\n"); 179 } 180 181 $self; 182 } 183 184 sub configure { 185 my ($self) = shift; 186 187 # Restore settings, merge new settings in. 188 my $save = Getopt::Long::Configure ($self->{settings}, @_); 189 190 # Restore orig config and save the new config. 191 $self->{settings} = Getopt::Long::Configure ($save); 192 } 193 194 sub getoptions { 195 my ($self) = shift; 196 197 # Restore config settings. 198 my $save = Getopt::Long::Configure ($self->{settings}); 199 200 # Call main routine. 201 my $ret = 0; 202 $Getopt::Long::caller = $self->{caller_pkg}; 203 204 eval { 205 # Locally set exception handler to default, otherwise it will 206 # be called implicitly here, and again explicitly when we try 207 # to deliver the messages. 208 local ($SIG{__DIE__}) = '__DEFAULT__'; 209 $ret = Getopt::Long::GetOptions (@_); 210 }; 211 212 # Restore saved settings. 213 Getopt::Long::Configure ($save); 214 215 # Handle errors and return value. 216 die ($@) if $@; 217 return $ret; 218 } 219 220 package Getopt::Long; 221 222 ################ Back to Normal ################ 223 224 # Indices in option control info. 225 # Note that ParseOptions uses the fields directly. Search for 'hard-wired'. 226 use constant CTL_TYPE => 0; 227 #use constant CTL_TYPE_FLAG => ''; 228 #use constant CTL_TYPE_NEG => '!'; 229 #use constant CTL_TYPE_INCR => '+'; 230 #use constant CTL_TYPE_INT => 'i'; 231 #use constant CTL_TYPE_INTINC => 'I'; 232 #use constant CTL_TYPE_XINT => 'o'; 233 #use constant CTL_TYPE_FLOAT => 'f'; 234 #use constant CTL_TYPE_STRING => 's'; 235 236 use constant CTL_CNAME => 1; 237 238 use constant CTL_DEFAULT => 2; 239 240 use constant CTL_DEST => 3; 241 use constant CTL_DEST_SCALAR => 0; 242 use constant CTL_DEST_ARRAY => 1; 243 use constant CTL_DEST_HASH => 2; 244 use constant CTL_DEST_CODE => 3; 245 246 use constant CTL_AMIN => 4; 247 use constant CTL_AMAX => 5; 248 249 # FFU. 250 #use constant CTL_RANGE => ; 251 #use constant CTL_REPEAT => ; 252 253 # Rather liberal patterns to match numbers. 254 use constant PAT_INT => "[-+]?_*[0-9][0-9_]*"; 255 use constant PAT_XINT => 256 "(?:". 257 "[-+]?_*[1-9][0-9_]*". 258 "|". 259 "0x_*[0-9a-f][0-9a-f_]*". 260 "|". 261 "0b_*[01][01_]*". 262 "|". 263 "0[0-7_]*". 264 ")"; 265 use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?"; 266 267 sub GetOptions(@) { 268 # Shift in default array. 269 unshift(@_, \@ARGV); 270 # Try to keep caller() and Carp consitent. 271 goto &GetOptionsFromArray; 272 } 273 274 sub GetOptionsFromString($@) { 275 my ($string) = shift; 276 require Text::ParseWords; 277 my $args = [ Text::ParseWords::shellwords($string) ]; 278 $caller ||= (caller)[0]; # current context 279 my $ret = GetOptionsFromArray($args, @_); 280 return ( $ret, $args ) if wantarray; 281 if ( @$args ) { 282 $ret = 0; 283 warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n"); 284 } 285 $ret; 286 } 287 288 sub GetOptionsFromArray($@) { 289 290 my ($argv, @optionlist) = @_; # local copy of the option descriptions 291 my $argend = '--'; # option list terminator 292 my %opctl = (); # table of option specs 293 my $pkg = $caller || (caller)[0]; # current context 294 # Needed if linkage is omitted. 295 my @ret = (); # accum for non-options 296 my %linkage; # linkage 297 my $userlinkage; # user supplied HASH 298 my $opt; # current option 299 my $prefix = $genprefix; # current prefix 300 301 $error = ''; 302 303 if ( $debug ) { 304 # Avoid some warnings if debugging. 305 local ($^W) = 0; 306 print STDERR 307 ("Getopt::Long $Getopt::Long::VERSION (", 308 '$Revision: 2.74 $', ") ", 309 "called from package \"$pkg\".", 310 "\n ", 311 "argv: (@$argv)", 312 "\n ", 313 "autoabbrev=$autoabbrev,". 314 "bundling=$bundling,", 315 "getopt_compat=$getopt_compat,", 316 "gnu_compat=$gnu_compat,", 317 "order=$order,", 318 "\n ", 319 "ignorecase=$ignorecase,", 320 "requested_version=$requested_version,", 321 "passthrough=$passthrough,", 322 "genprefix=\"$genprefix\",", 323 "longprefix=\"$longprefix\".", 324 "\n"); 325 } 326 327 # Check for ref HASH as first argument. 328 # First argument may be an object. It's OK to use this as long 329 # as it is really a hash underneath. 330 $userlinkage = undef; 331 if ( @optionlist && ref($optionlist[0]) and 332 UNIVERSAL::isa($optionlist[0],'HASH') ) { 333 $userlinkage = shift (@optionlist); 334 print STDERR ("=> user linkage: $userlinkage\n") if $debug; 335 } 336 337 # See if the first element of the optionlist contains option 338 # starter characters. 339 # Be careful not to interpret '<>' as option starters. 340 if ( @optionlist && $optionlist[0] =~ /^\W+$/ 341 && !($optionlist[0] eq '<>' 342 && @optionlist > 0 343 && ref($optionlist[1])) ) { 344 $prefix = shift (@optionlist); 345 # Turn into regexp. Needs to be parenthesized! 346 $prefix =~ s/(\W)/\\$1/g; 347 $prefix = "([" . $prefix . "])"; 348 print STDERR ("=> prefix=\"$prefix\"\n") if $debug; 349 } 350 351 # Verify correctness of optionlist. 352 %opctl = (); 353 while ( @optionlist ) { 354 my $opt = shift (@optionlist); 355 356 unless ( defined($opt) ) { 357 $error .= "Undefined argument in option spec\n"; 358 next; 359 } 360 361 # Strip leading prefix so people can specify "--foo=i" if they like. 362 $opt = $+ if $opt =~ /^$prefix+(.*)$/s; 363 364 if ( $opt eq '<>' ) { 365 if ( (defined $userlinkage) 366 && !(@optionlist > 0 && ref($optionlist[0])) 367 && (exists $userlinkage->{$opt}) 368 && ref($userlinkage->{$opt}) ) { 369 unshift (@optionlist, $userlinkage->{$opt}); 370 } 371 unless ( @optionlist > 0 372 && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { 373 $error .= "Option spec <> requires a reference to a subroutine\n"; 374 # Kill the linkage (to avoid another error). 375 shift (@optionlist) 376 if @optionlist && ref($optionlist[0]); 377 next; 378 } 379 $linkage{'<>'} = shift (@optionlist); 380 next; 381 } 382 383 # Parse option spec. 384 my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); 385 unless ( defined $name ) { 386 # Failed. $orig contains the error message. Sorry for the abuse. 387 $error .= $orig; 388 # Kill the linkage (to avoid another error). 389 shift (@optionlist) 390 if @optionlist && ref($optionlist[0]); 391 next; 392 } 393 394 # If no linkage is supplied in the @optionlist, copy it from 395 # the userlinkage if available. 396 if ( defined $userlinkage ) { 397 unless ( @optionlist > 0 && ref($optionlist[0]) ) { 398 if ( exists $userlinkage->{$orig} && 399 ref($userlinkage->{$orig}) ) { 400 print STDERR ("=> found userlinkage for \"$orig\": ", 401 "$userlinkage->{$orig}\n") 402 if $debug; 403 unshift (@optionlist, $userlinkage->{$orig}); 404 } 405 else { 406 # Do nothing. Being undefined will be handled later. 407 next; 408 } 409 } 410 } 411 412 # Copy the linkage. If omitted, link to global variable. 413 if ( @optionlist > 0 && ref($optionlist[0]) ) { 414 print STDERR ("=> link \"$orig\" to $optionlist[0]\n") 415 if $debug; 416 my $rl = ref($linkage{$orig} = shift (@optionlist)); 417 418 if ( $rl eq "ARRAY" ) { 419 $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; 420 } 421 elsif ( $rl eq "HASH" ) { 422 $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; 423 } 424 elsif ( $rl eq "SCALAR" || $rl eq "REF" ) { 425 # if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { 426 # my $t = $linkage{$orig}; 427 # $$t = $linkage{$orig} = []; 428 # } 429 # elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { 430 # } 431 # else { 432 # Ok. 433 # } 434 } 435 elsif ( $rl eq "CODE" ) { 436 # Ok. 437 } 438 else { 439 $error .= "Invalid option linkage for \"$opt\"\n"; 440 } 441 } 442 else { 443 # Link to global $opt_XXX variable. 444 # Make sure a valid perl identifier results. 445 my $ov = $orig; 446 $ov =~ s/\W/_/g; 447 if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { 448 print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") 449 if $debug; 450 eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); 451 } 452 elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { 453 print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") 454 if $debug; 455 eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); 456 } 457 else { 458 print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") 459 if $debug; 460 eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); 461 } 462 } 463 } 464 465 # Bail out if errors found. 466 die ($error) if $error; 467 $error = 0; 468 469 # Supply --version and --help support, if needed and allowed. 470 if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { 471 if ( !defined($opctl{version}) ) { 472 $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; 473 $linkage{version} = \&VersionMessage; 474 } 475 $auto_version = 1; 476 } 477 if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { 478 if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { 479 $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; 480 $linkage{help} = \&HelpMessage; 481 } 482 $auto_help = 1; 483 } 484 485 # Show the options tables if debugging. 486 if ( $debug ) { 487 my ($arrow, $k, $v); 488 $arrow = "=> "; 489 while ( ($k,$v) = each(%opctl) ) { 490 print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); 491 $arrow = " "; 492 } 493 } 494 495 # Process argument list 496 my $goon = 1; 497 while ( $goon && @$argv > 0 ) { 498 499 # Get next argument. 500 $opt = shift (@$argv); 501 print STDERR ("=> arg \"", $opt, "\"\n") if $debug; 502 503 # Double dash is option list terminator. 504 if ( $opt eq $argend ) { 505 push (@ret, $argend) if $passthrough; 506 last; 507 } 508 509 # Look it up. 510 my $tryopt = $opt; 511 my $found; # success status 512 my $key; # key (if hash type) 513 my $arg; # option argument 514 my $ctl; # the opctl entry 515 516 ($found, $opt, $ctl, $arg, $key) = 517 FindOption ($argv, $prefix, $argend, $opt, \%opctl); 518 519 if ( $found ) { 520 521 # FindOption undefines $opt in case of errors. 522 next unless defined $opt; 523 524 my $argcnt = 0; 525 while ( defined $arg ) { 526 527 # Get the canonical name. 528 print STDERR ("=> cname for \"$opt\" is ") if $debug; 529 $opt = $ctl->[CTL_CNAME]; 530 print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; 531 532 if ( defined $linkage{$opt} ) { 533 print STDERR ("=> ref(\$L{$opt}) -> ", 534 ref($linkage{$opt}), "\n") if $debug; 535 536 if ( ref($linkage{$opt}) eq 'SCALAR' 537 || ref($linkage{$opt}) eq 'REF' ) { 538 if ( $ctl->[CTL_TYPE] eq '+' ) { 539 print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") 540 if $debug; 541 if ( defined ${$linkage{$opt}} ) { 542 ${$linkage{$opt}} += $arg; 543 } 544 else { 545 ${$linkage{$opt}} = $arg; 546 } 547 } 548 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { 549 print STDERR ("=> ref(\$L{$opt}) auto-vivified", 550 " to ARRAY\n") 551 if $debug; 552 my $t = $linkage{$opt}; 553 $$t = $linkage{$opt} = []; 554 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") 555 if $debug; 556 push (@{$linkage{$opt}}, $arg); 557 } 558 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { 559 print STDERR ("=> ref(\$L{$opt}) auto-vivified", 560 " to HASH\n") 561 if $debug; 562 my $t = $linkage{$opt}; 563 $$t = $linkage{$opt} = {}; 564 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") 565 if $debug; 566 $linkage{$opt}->{$key} = $arg; 567 } 568 else { 569 print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") 570 if $debug; 571 ${$linkage{$opt}} = $arg; 572 } 573 } 574 elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { 575 print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") 576 if $debug; 577 push (@{$linkage{$opt}}, $arg); 578 } 579 elsif ( ref($linkage{$opt}) eq 'HASH' ) { 580 print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") 581 if $debug; 582 $linkage{$opt}->{$key} = $arg; 583 } 584 elsif ( ref($linkage{$opt}) eq 'CODE' ) { 585 print STDERR ("=> &L{$opt}(\"$opt\"", 586 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", 587 ", \"$arg\")\n") 588 if $debug; 589 my $eval_error = do { 590 local $@; 591 local $SIG{__DIE__} = '__DEFAULT__'; 592 eval { 593 &{$linkage{$opt}} 594 (Getopt::Long::CallBack->new 595 (name => $opt, 596 ctl => $ctl, 597 opctl => \%opctl, 598 linkage => \%linkage, 599 prefix => $prefix, 600 ), 601 $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), 602 $arg); 603 }; 604 $@; 605 }; 606 print STDERR ("=> die($eval_error)\n") 607 if $debug && $eval_error ne ''; 608 if ( $eval_error =~ /^!/ ) { 609 if ( $eval_error =~ /^!FINISH\b/ ) { 610 $goon = 0; 611 } 612 } 613 elsif ( $eval_error ne '' ) { 614 warn ($eval_error); 615 $error++; 616 } 617 } 618 else { 619 print STDERR ("Invalid REF type \"", ref($linkage{$opt}), 620 "\" in linkage\n"); 621 die("Getopt::Long -- internal error!\n"); 622 } 623 } 624 # No entry in linkage means entry in userlinkage. 625 elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { 626 if ( defined $userlinkage->{$opt} ) { 627 print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") 628 if $debug; 629 push (@{$userlinkage->{$opt}}, $arg); 630 } 631 else { 632 print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") 633 if $debug; 634 $userlinkage->{$opt} = [$arg]; 635 } 636 } 637 elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { 638 if ( defined $userlinkage->{$opt} ) { 639 print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") 640 if $debug; 641 $userlinkage->{$opt}->{$key} = $arg; 642 } 643 else { 644 print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") 645 if $debug; 646 $userlinkage->{$opt} = {$key => $arg}; 647 } 648 } 649 else { 650 if ( $ctl->[CTL_TYPE] eq '+' ) { 651 print STDERR ("=> \$L{$opt} += \"$arg\"\n") 652 if $debug; 653 if ( defined $userlinkage->{$opt} ) { 654 $userlinkage->{$opt} += $arg; 655 } 656 else { 657 $userlinkage->{$opt} = $arg; 658 } 659 } 660 else { 661 print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; 662 $userlinkage->{$opt} = $arg; 663 } 664 } 665 666 $argcnt++; 667 last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; 668 undef($arg); 669 670 # Need more args? 671 if ( $argcnt < $ctl->[CTL_AMIN] ) { 672 if ( @$argv ) { 673 if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) { 674 $arg = shift(@$argv); 675 $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/; 676 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ 677 if $ctl->[CTL_DEST] == CTL_DEST_HASH; 678 next; 679 } 680 warn("Value \"$$argv[0]\" invalid for option $opt\n"); 681 $error++; 682 } 683 else { 684 warn("Insufficient arguments for option $opt\n"); 685 $error++; 686 } 687 } 688 689 # Any more args? 690 if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) { 691 $arg = shift(@$argv); 692 $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/; 693 ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ 694 if $ctl->[CTL_DEST] == CTL_DEST_HASH; 695 next; 696 } 697 } 698 } 699 700 # Not an option. Save it if we $PERMUTE and don't have a <>. 701 elsif ( $order == $PERMUTE ) { 702 # Try non-options call-back. 703 my $cb; 704 if ( (defined ($cb = $linkage{'<>'})) ) { 705 print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") 706 if $debug; 707 my $eval_error = do { 708 local $@; 709 local $SIG{__DIE__} = '__DEFAULT__'; 710 eval { &$cb ($tryopt) }; 711 $@; 712 }; 713 print STDERR ("=> die($eval_error)\n") 714 if $debug && $eval_error ne ''; 715 if ( $eval_error =~ /^!/ ) { 716 if ( $eval_error =~ /^!FINISH\b/ ) { 717 $goon = 0; 718 } 719 } 720 elsif ( $eval_error ne '' ) { 721 warn ($eval_error); 722 $error++; 723 } 724 } 725 else { 726 print STDERR ("=> saving \"$tryopt\" ", 727 "(not an option, may permute)\n") if $debug; 728 push (@ret, $tryopt); 729 } 730 next; 731 } 732 733 # ...otherwise, terminate. 734 else { 735 # Push this one back and exit. 736 unshift (@$argv, $tryopt); 737 return ($error == 0); 738 } 739 740 } 741 742 # Finish. 743 if ( @ret && $order == $PERMUTE ) { 744 # Push back accumulated arguments 745 print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") 746 if $debug; 747 unshift (@$argv, @ret); 748 } 749 750 return ($error == 0); 751 } 752 753 # A readable representation of what's in an optbl. 754 sub OptCtl ($) { 755 my ($v) = @_; 756 my @v = map { defined($_) ? ($_) : ("<undef>") } @$v; 757 "[". 758 join(",", 759 "\"$v[CTL_TYPE]\"", 760 "\"$v[CTL_CNAME]\"", 761 "\"$v[CTL_DEFAULT]\"", 762 ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], 763 $v[CTL_AMIN] || '', 764 $v[CTL_AMAX] || '', 765 # $v[CTL_RANGE] || '', 766 # $v[CTL_REPEAT] || '', 767 ). "]"; 768 } 769 770 # Parse an option specification and fill the tables. 771 sub ParseOptionSpec ($$) { 772 my ($opt, $opctl) = @_; 773 774 # Match option spec. 775 if ( $opt !~ m;^ 776 ( 777 # Option name 778 (?: \w+[-\w]* ) 779 # Alias names, or "?" 780 (?: \| (?: \? | \w[-\w]* )? )* 781 )? 782 ( 783 # Either modifiers ... 784 [!+] 785 | 786 # ... or a value/dest/repeat specification 787 [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )? 788 | 789 # ... or an optional-with-default spec 790 : (?: -?\d+ | \+ ) [@%]? 791 )? 792 $;x ) { 793 return (undef, "Error in option spec: \"$opt\"\n"); 794 } 795 796 my ($names, $spec) = ($1, $2); 797 $spec = '' unless defined $spec; 798 799 # $orig keeps track of the primary name the user specified. 800 # This name will be used for the internal or external linkage. 801 # In other words, if the user specifies "FoO|BaR", it will 802 # match any case combinations of 'foo' and 'bar', but if a global 803 # variable needs to be set, it will be $opt_FoO in the exact case 804 # as specified. 805 my $orig; 806 807 my @names; 808 if ( defined $names ) { 809 @names = split (/\|/, $names); 810 $orig = $names[0]; 811 } 812 else { 813 @names = (''); 814 $orig = ''; 815 } 816 817 # Construct the opctl entries. 818 my $entry; 819 if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { 820 # Fields are hard-wired here. 821 $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0]; 822 } 823 elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) { 824 my $def = $1; 825 my $dest = $2; 826 my $type = $def eq '+' ? 'I' : 'i'; 827 $dest ||= '$'; 828 $dest = $dest eq '@' ? CTL_DEST_ARRAY 829 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; 830 # Fields are hard-wired here. 831 $entry = [$type,$orig,$def eq '+' ? undef : $def, 832 $dest,0,1]; 833 } 834 else { 835 my ($mand, $type, $dest) = 836 $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/; 837 return (undef, "Cannot repeat while bundling: \"$opt\"\n") 838 if $bundling && defined($4); 839 my ($mi, $cm, $ma) = ($5, $6, $7); 840 return (undef, "{0} is useless in option spec: \"$opt\"\n") 841 if defined($mi) && !$mi && !defined($ma) && !defined($cm); 842 843 $type = 'i' if $type eq 'n'; 844 $dest ||= '$'; 845 $dest = $dest eq '@' ? CTL_DEST_ARRAY 846 : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; 847 # Default minargs to 1/0 depending on mand status. 848 $mi = $mand eq '=' ? 1 : 0 unless defined $mi; 849 # Adjust mand status according to minargs. 850 $mand = $mi ? '=' : ':'; 851 # Adjust maxargs. 852 $ma = $mi ? $mi : 1 unless defined $ma || defined $cm; 853 return (undef, "Max must be greater than zero in option spec: \"$opt\"\n") 854 if defined($ma) && !$ma; 855 return (undef, "Max less than min in option spec: \"$opt\"\n") 856 if defined($ma) && $ma < $mi; 857 858 # Fields are hard-wired here. 859 $entry = [$type,$orig,undef,$dest,$mi,$ma||-1]; 860 } 861 862 # Process all names. First is canonical, the rest are aliases. 863 my $dups = ''; 864 foreach ( @names ) { 865 866 $_ = lc ($_) 867 if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); 868 869 if ( exists $opctl->{$_} ) { 870 $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; 871 } 872 873 if ( $spec eq '!' ) { 874 $opctl->{"no$_"} = $entry; 875 $opctl->{"no-$_"} = $entry; 876 $opctl->{$_} = [@$entry]; 877 $opctl->{$_}->[CTL_TYPE] = ''; 878 } 879 else { 880 $opctl->{$_} = $entry; 881 } 882 } 883 884 if ( $dups && $^W ) { 885 foreach ( split(/\n+/, $dups) ) { 886 warn($_."\n"); 887 } 888 } 889 ($names[0], $orig); 890 } 891 892 # Option lookup. 893 sub FindOption ($$$$$) { 894 895 # returns (1, $opt, $ctl, $arg, $key) if okay, 896 # returns (1, undef) if option in error, 897 # returns (0) otherwise. 898 899 my ($argv, $prefix, $argend, $opt, $opctl) = @_; 900 901 print STDERR ("=> find \"$opt\"\n") if $debug; 902 903 return (0) unless $opt =~ /^$prefix(.*)$/s; 904 return (0) if $opt eq "-" && !defined $opctl->{''}; 905 906 $opt = $+; 907 my $starter = $1; 908 909 print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; 910 911 my $optarg; # value supplied with --opt=value 912 my $rest; # remainder from unbundling 913 914 # If it is a long option, it may include the value. 915 # With getopt_compat, only if not bundling. 916 if ( ($starter=~/^$longprefix$/ 917 || ($getopt_compat && ($bundling == 0 || $bundling == 2))) 918 && $opt =~ /^([^=]+)=(.*)$/s ) { 919 $opt = $1; 920 $optarg = $2; 921 print STDERR ("=> option \"", $opt, 922 "\", optarg = \"$optarg\"\n") if $debug; 923 } 924 925 #### Look it up ### 926 927 my $tryopt = $opt; # option to try 928 929 if ( $bundling && $starter eq '-' ) { 930 931 # To try overrides, obey case ignore. 932 $tryopt = $ignorecase ? lc($opt) : $opt; 933 934 # If bundling == 2, long options can override bundles. 935 if ( $bundling == 2 && length($tryopt) > 1 936 && defined ($opctl->{$tryopt}) ) { 937 print STDERR ("=> $starter$tryopt overrides unbundling\n") 938 if $debug; 939 } 940 else { 941 $tryopt = $opt; 942 # Unbundle single letter option. 943 $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; 944 $tryopt = substr ($tryopt, 0, 1); 945 $tryopt = lc ($tryopt) if $ignorecase > 1; 946 print STDERR ("=> $starter$tryopt unbundled from ", 947 "$starter$tryopt$rest\n") if $debug; 948 $rest = undef unless $rest ne ''; 949 } 950 } 951 952 # Try auto-abbreviation. 953 elsif ( $autoabbrev ) { 954 # Sort the possible long option names. 955 my @names = sort(keys (%$opctl)); 956 # Downcase if allowed. 957 $opt = lc ($opt) if $ignorecase; 958 $tryopt = $opt; 959 # Turn option name into pattern. 960 my $pat = quotemeta ($opt); 961 # Look up in option names. 962 my @hits = grep (/^$pat/, @names); 963 print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", 964 "out of ", scalar(@names), "\n") if $debug; 965 966 # Check for ambiguous results. 967 unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { 968 # See if all matches are for the same option. 969 my %hit; 970 foreach ( @hits ) { 971 my $hit = $_; 972 $hit = $opctl->{$hit}->[CTL_CNAME] 973 if defined $opctl->{$hit}->[CTL_CNAME]; 974 $hit{$hit} = 1; 975 } 976 # Remove auto-supplied options (version, help). 977 if ( keys(%hit) == 2 ) { 978 if ( $auto_version && exists($hit{version}) ) { 979 delete $hit{version}; 980 } 981 elsif ( $auto_help && exists($hit{help}) ) { 982 delete $hit{help}; 983 } 984 } 985 # Now see if it really is ambiguous. 986 unless ( keys(%hit) == 1 ) { 987 return (0) if $passthrough; 988 warn ("Option ", $opt, " is ambiguous (", 989 join(", ", @hits), ")\n"); 990 $error++; 991 return (1, undef); 992 } 993 @hits = keys(%hit); 994 } 995 996 # Complete the option name, if appropriate. 997 if ( @hits == 1 && $hits[0] ne $opt ) { 998 $tryopt = $hits[0]; 999 $tryopt = lc ($tryopt) if $ignorecase; 1000 print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") 1001 if $debug; 1002 } 1003 } 1004 1005 # Map to all lowercase if ignoring case. 1006 elsif ( $ignorecase ) { 1007 $tryopt = lc ($opt); 1008 } 1009 1010 # Check validity by fetching the info. 1011 my $ctl = $opctl->{$tryopt}; 1012 unless ( defined $ctl ) { 1013 return (0) if $passthrough; 1014 # Pretend one char when bundling. 1015 if ( $bundling == 1 && length($starter) == 1 ) { 1016 $opt = substr($opt,0,1); 1017 unshift (@$argv, $starter.$rest) if defined $rest; 1018 } 1019 warn ("Unknown option: ", $opt, "\n"); 1020 $error++; 1021 return (1, undef); 1022 } 1023 # Apparently valid. 1024 $opt = $tryopt; 1025 print STDERR ("=> found ", OptCtl($ctl), 1026 " for \"", $opt, "\"\n") if $debug; 1027 1028 #### Determine argument status #### 1029 1030 # If it is an option w/o argument, we're almost finished with it. 1031 my $type = $ctl->[CTL_TYPE]; 1032 my $arg; 1033 1034 if ( $type eq '' || $type eq '!' || $type eq '+' ) { 1035 if ( defined $optarg ) { 1036 return (0) if $passthrough; 1037 warn ("Option ", $opt, " does not take an argument\n"); 1038 $error++; 1039 undef $opt; 1040 } 1041 elsif ( $type eq '' || $type eq '+' ) { 1042 # Supply explicit value. 1043 $arg = 1; 1044 } 1045 else { 1046 $opt =~ s/^no-?//i; # strip NO prefix 1047 $arg = 0; # supply explicit value 1048 } 1049 unshift (@$argv, $starter.$rest) if defined $rest; 1050 return (1, $opt, $ctl, $arg); 1051 } 1052 1053 # Get mandatory status and type info. 1054 my $mand = $ctl->[CTL_AMIN]; 1055 1056 # Check if there is an option argument available. 1057 if ( $gnu_compat && defined $optarg && $optarg eq '' ) { 1058 return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand; 1059 $optarg = 0 unless $type eq 's'; 1060 } 1061 1062 # Check if there is an option argument available. 1063 if ( defined $optarg 1064 ? ($optarg eq '') 1065 : !(defined $rest || @$argv > 0) ) { 1066 # Complain if this option needs an argument. 1067 # if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) { 1068 if ( $mand ) { 1069 return (0) if $passthrough; 1070 warn ("Option ", $opt, " requires an argument\n"); 1071 $error++; 1072 return (1, undef); 1073 } 1074 if ( $type eq 'I' ) { 1075 # Fake incremental type. 1076 my @c = @$ctl; 1077 $c[CTL_TYPE] = '+'; 1078 return (1, $opt, \@c, 1); 1079 } 1080 return (1, $opt, $ctl, 1081 defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 1082 $type eq 's' ? '' : 0); 1083 } 1084 1085 # Get (possibly optional) argument. 1086 $arg = (defined $rest ? $rest 1087 : (defined $optarg ? $optarg : shift (@$argv))); 1088 1089 # Get key if this is a "name=value" pair for a hash option. 1090 my $key; 1091 if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { 1092 ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) 1093 : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 1094 ($mand ? undef : ($type eq 's' ? "" : 1))); 1095 if (! defined $arg) { 1096 warn ("Option $opt, key \"$key\", requires a value\n"); 1097 $error++; 1098 # Push back. 1099 unshift (@$argv, $starter.$rest) if defined $rest; 1100 return (1, undef); 1101 } 1102 } 1103 1104 #### Check if the argument is valid for this option #### 1105 1106 my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; 1107 1108 if ( $type eq 's' ) { # string 1109 # A mandatory string takes anything. 1110 return (1, $opt, $ctl, $arg, $key) if $mand; 1111 1112 # Same for optional string as a hash value 1113 return (1, $opt, $ctl, $arg, $key) 1114 if $ctl->[CTL_DEST] == CTL_DEST_HASH; 1115 1116 # An optional string takes almost anything. 1117 return (1, $opt, $ctl, $arg, $key) 1118 if defined $optarg || defined $rest; 1119 return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? 1120 1121 # Check for option or option list terminator. 1122 if ($arg eq $argend || 1123 $arg =~ /^$prefix.+/) { 1124 # Push back. 1125 unshift (@$argv, $arg); 1126 # Supply empty value. 1127 $arg = ''; 1128 } 1129 } 1130 1131 elsif ( $type eq 'i' # numeric/integer 1132 || $type eq 'I' # numeric/integer w/ incr default 1133 || $type eq 'o' ) { # dec/oct/hex/bin value 1134 1135 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT; 1136 1137 if ( $bundling && defined $rest 1138 && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { 1139 ($key, $arg, $rest) = ($1, $2, $+); 1140 chop($key) if $key; 1141 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; 1142 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne ''; 1143 } 1144 elsif ( $arg =~ /^$o_valid$/si ) { 1145 $arg =~ tr/_//d; 1146 $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; 1147 } 1148 else { 1149 if ( defined $optarg || $mand ) { 1150 if ( $passthrough ) { 1151 unshift (@$argv, defined $rest ? $starter.$rest : $arg) 1152 unless defined $optarg; 1153 return (0); 1154 } 1155 warn ("Value \"", $arg, "\" invalid for option ", 1156 $opt, " (", 1157 $type eq 'o' ? "extended " : '', 1158 "number expected)\n"); 1159 $error++; 1160 # Push back. 1161 unshift (@$argv, $starter.$rest) if defined $rest; 1162 return (1, undef); 1163 } 1164 else { 1165 # Push back. 1166 unshift (@$argv, defined $rest ? $starter.$rest : $arg); 1167 if ( $type eq 'I' ) { 1168 # Fake incremental type. 1169 my @c = @$ctl; 1170 $c[CTL_TYPE] = '+'; 1171 return (1, $opt, \@c, 1); 1172 } 1173 # Supply default value. 1174 $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; 1175 } 1176 } 1177 } 1178 1179 elsif ( $type eq 'f' ) { # real number, int is also ok 1180 # We require at least one digit before a point or 'e', 1181 # and at least one digit following the point and 'e'. 1182 # [-]NN[.NN][eNN] 1183 my $o_valid = PAT_FLOAT; 1184 if ( $bundling && defined $rest && 1185 $rest =~ /^($key_valid)($o_valid)(.*)$/s ) { 1186 $arg =~ tr/_//d; 1187 ($key, $arg, $rest) = ($1, $2, $+); 1188 chop($key) if $key; 1189 unshift (@$argv, $starter.$rest) if defined $rest && $rest ne ''; 1190 } 1191 elsif ( $arg =~ /^$o_valid$/ ) { 1192 $arg =~ tr/_//d; 1193 } 1194 else { 1195 if ( defined $optarg || $mand ) { 1196 if ( $passthrough ) { 1197 unshift (@$argv, defined $rest ? $starter.$rest : $arg) 1198 unless defined $optarg; 1199 return (0); 1200 } 1201 warn ("Value \"", $arg, "\" invalid for option ", 1202 $opt, " (real number expected)\n"); 1203 $error++; 1204 # Push back. 1205 unshift (@$argv, $starter.$rest) if defined $rest; 1206 return (1, undef); 1207 } 1208 else { 1209 # Push back. 1210 unshift (@$argv, defined $rest ? $starter.$rest : $arg); 1211 # Supply default value. 1212 $arg = 0.0; 1213 } 1214 } 1215 } 1216 else { 1217 die("Getopt::Long internal error (Can't happen)\n"); 1218 } 1219 return (1, $opt, $ctl, $arg, $key); 1220 } 1221 1222 sub ValidValue ($$$$$) { 1223 my ($ctl, $arg, $mand, $argend, $prefix) = @_; 1224 1225 if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { 1226 return 0 unless $arg =~ /[^=]+=(.*)/; 1227 $arg = $1; 1228 } 1229 1230 my $type = $ctl->[CTL_TYPE]; 1231 1232 if ( $type eq 's' ) { # string 1233 # A mandatory string takes anything. 1234 return (1) if $mand; 1235 1236 return (1) if $arg eq "-"; 1237 1238 # Check for option or option list terminator. 1239 return 0 if $arg eq $argend || $arg =~ /^$prefix.+/; 1240 return 1; 1241 } 1242 1243 elsif ( $type eq 'i' # numeric/integer 1244 || $type eq 'I' # numeric/integer w/ incr default 1245 || $type eq 'o' ) { # dec/oct/hex/bin value 1246 1247 my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT; 1248 return $arg =~ /^$o_valid$/si; 1249 } 1250 1251 elsif ( $type eq 'f' ) { # real number, int is also ok 1252 # We require at least one digit before a point or 'e', 1253 # and at least one digit following the point and 'e'. 1254 # [-]NN[.NN][eNN] 1255 my $o_valid = PAT_FLOAT; 1256 return $arg =~ /^$o_valid$/; 1257 } 1258 die("ValidValue: Cannot happen\n"); 1259 } 1260 1261 # Getopt::Long Configuration. 1262 sub Configure (@) { 1263 my (@options) = @_; 1264 1265 my $prevconfig = 1266 [ $error, $debug, $major_version, $minor_version, 1267 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, 1268 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, 1269 $longprefix ]; 1270 1271 if ( ref($options[0]) eq 'ARRAY' ) { 1272 ( $error, $debug, $major_version, $minor_version, 1273 $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, 1274 $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, 1275 $longprefix ) = @{shift(@options)}; 1276 } 1277 1278 my $opt; 1279 foreach $opt ( @options ) { 1280 my $try = lc ($opt); 1281 my $action = 1; 1282 if ( $try =~ /^no_?(.*)$/s ) { 1283 $action = 0; 1284 $try = $+; 1285 } 1286 if ( ($try eq 'default' or $try eq 'defaults') && $action ) { 1287 ConfigDefaults (); 1288 } 1289 elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { 1290 local $ENV{POSIXLY_CORRECT}; 1291 $ENV{POSIXLY_CORRECT} = 1 if $action; 1292 ConfigDefaults (); 1293 } 1294 elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { 1295 $autoabbrev = $action; 1296 } 1297 elsif ( $try eq 'getopt_compat' ) { 1298 $getopt_compat = $action; 1299 $genprefix = $action ? "(--|-|\\+)" : "(--|-)"; 1300 } 1301 elsif ( $try eq 'gnu_getopt' ) { 1302 if ( $action ) { 1303 $gnu_compat = 1; 1304 $bundling = 1; 1305 $getopt_compat = 0; 1306 $genprefix = "(--|-)"; 1307 $order = $PERMUTE; 1308 } 1309 } 1310 elsif ( $try eq 'gnu_compat' ) { 1311 $gnu_compat = $action; 1312 } 1313 elsif ( $try =~ /^(auto_?)?version$/ ) { 1314 $auto_version = $action; 1315 } 1316 elsif ( $try =~ /^(auto_?)?help$/ ) { 1317 $auto_help = $action; 1318 } 1319 elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { 1320 $ignorecase = $action; 1321 } 1322 elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) { 1323 $ignorecase = $action ? 2 : 0; 1324 } 1325 elsif ( $try eq 'bundling' ) { 1326 $bundling = $action; 1327 } 1328 elsif ( $try eq 'bundling_override' ) { 1329 $bundling = $action ? 2 : 0; 1330 } 1331 elsif ( $try eq 'require_order' ) { 1332 $order = $action ? $REQUIRE_ORDER : $PERMUTE; 1333 } 1334 elsif ( $try eq 'permute' ) { 1335 $order = $action ? $PERMUTE : $REQUIRE_ORDER; 1336 } 1337 elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { 1338 $passthrough = $action; 1339 } 1340 elsif ( $try =~ /^prefix=(.+)$/ && $action ) { 1341 $genprefix = $1; 1342 # Turn into regexp. Needs to be parenthesized! 1343 $genprefix = "(" . quotemeta($genprefix) . ")"; 1344 eval { '' =~ /$genprefix/; }; 1345 die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; 1346 } 1347 elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { 1348 $genprefix = $1; 1349 # Parenthesize if needed. 1350 $genprefix = "(" . $genprefix . ")" 1351 unless $genprefix =~ /^\(.*\)$/; 1352 eval { '' =~ m"$genprefix"; }; 1353 die("Getopt::Long: invalid pattern \"$genprefix\"") if $@; 1354 } 1355 elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { 1356 $longprefix = $1; 1357 # Parenthesize if needed. 1358 $longprefix = "(" . $longprefix . ")" 1359 unless $longprefix =~ /^\(.*\)$/; 1360 eval { '' =~ m"$longprefix"; }; 1361 die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@; 1362 } 1363 elsif ( $try eq 'debug' ) { 1364 $debug = $action; 1365 } 1366 else { 1367 die("Getopt::Long: unknown config parameter \"$opt\"") 1368 } 1369 } 1370 $prevconfig; 1371 } 1372 1373 # Deprecated name. 1374 sub config (@) { 1375 Configure (@_); 1376 } 1377 1378 # Issue a standard message for --version. 1379 # 1380 # The arguments are mostly the same as for Pod::Usage::pod2usage: 1381 # 1382 # - a number (exit value) 1383 # - a string (lead in message) 1384 # - a hash with options. See Pod::Usage for details. 1385 # 1386 sub VersionMessage(@) { 1387 # Massage args. 1388 my $pa = setup_pa_args("version", @_); 1389 1390 my $v = $main::VERSION; 1391 my $fh = $pa->{-output} || 1392 ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; 1393 1394 print $fh (defined($pa->{-message}) ? $pa->{-message} : (), 1395 $0, defined $v ? " version $v" : (), 1396 "\n", 1397 "(", __PACKAGE__, "::", "GetOptions", 1398 " version ", 1399 defined($Getopt::Long::VERSION_STRING) 1400 ? $Getopt::Long::VERSION_STRING : $VERSION, ";", 1401 " Perl version ", 1402 $] >= 5.006 ? sprintf("%vd", $^V) : $], 1403 ")\n"); 1404 exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; 1405 } 1406 1407 # Issue a standard message for --help. 1408 # 1409 # The arguments are the same as for Pod::Usage::pod2usage: 1410 # 1411 # - a number (exit value) 1412 # - a string (lead in message) 1413 # - a hash with options. See Pod::Usage for details. 1414 # 1415 sub HelpMessage(@) { 1416 eval { 1417 require Pod::Usage; 1418 import Pod::Usage; 1419 1; 1420 } || die("Cannot provide help: cannot load Pod::Usage\n"); 1421 1422 # Note that pod2usage will issue a warning if -exitval => NOEXIT. 1423 pod2usage(setup_pa_args("help", @_)); 1424 1425 } 1426 1427 # Helper routine to set up a normalized hash ref to be used as 1428 # argument to pod2usage. 1429 sub setup_pa_args($@) { 1430 my $tag = shift; # who's calling 1431 1432 # If called by direct binding to an option, it will get the option 1433 # name and value as arguments. Remove these, if so. 1434 @_ = () if @_ == 2 && $_[0] eq $tag; 1435 1436 my $pa; 1437 if ( @_ > 1 ) { 1438 $pa = { @_ }; 1439 } 1440 else { 1441 $pa = shift || {}; 1442 } 1443 1444 # At this point, $pa can be a number (exit value), string 1445 # (message) or hash with options. 1446 1447 if ( UNIVERSAL::isa($pa, 'HASH') ) { 1448 # Get rid of -msg vs. -message ambiguity. 1449 $pa->{-message} = $pa->{-msg}; 1450 delete($pa->{-msg}); 1451 } 1452 elsif ( $pa =~ /^-?\d+$/ ) { 1453 $pa = { -exitval => $pa }; 1454 } 1455 else { 1456 $pa = { -message => $pa }; 1457 } 1458 1459 # These are _our_ defaults. 1460 $pa->{-verbose} = 0 unless exists($pa->{-verbose}); 1461 $pa->{-exitval} = 0 unless exists($pa->{-exitval}); 1462 $pa; 1463 } 1464 1465 # Sneak way to know what version the user requested. 1466 sub VERSION { 1467 $requested_version = $_[1]; 1468 shift->SUPER::VERSION(@_); 1469 } 1470 1471 package Getopt::Long::CallBack; 1472 1473 sub new { 1474 my ($pkg, %atts) = @_; 1475 bless { %atts }, $pkg; 1476 } 1477 1478 sub name { 1479 my $self = shift; 1480 ''.$self->{name}; 1481 } 1482 1483 use overload 1484 # Treat this object as an oridinary string for legacy API. 1485 '""' => \&name, 1486 '0+' => sub { 0 }, 1487 fallback => 1; 1488 1489 1; 1490 1491 ################ Documentation ################ 1492 1493 =head1 NAME 1494 1495 Getopt::Long - Extended processing of command line options 1496 1497 =head1 SYNOPSIS 1498 1499 use Getopt::Long; 1500 my $data = "file.dat"; 1501 my $length = 24; 1502 my $verbose; 1503 $result = GetOptions ("length=i" => \$length, # numeric 1504 "file=s" => \$data, # string 1505 "verbose" => \$verbose); # flag 1506 1507 =head1 DESCRIPTION 1508 1509 The Getopt::Long module implements an extended getopt function called 1510 GetOptions(). This function adheres to the POSIX syntax for command 1511 line options, with GNU extensions. In general, this means that options 1512 have long names instead of single letters, and are introduced with a 1513 double dash "--". Support for bundling of command line options, as was 1514 the case with the more traditional single-letter approach, is provided 1515 but not enabled by default. 1516 1517 =head1 Command Line Options, an Introduction 1518 1519 Command line operated programs traditionally take their arguments from 1520 the command line, for example filenames or other information that the 1521 program needs to know. Besides arguments, these programs often take 1522 command line I<options> as well. Options are not necessary for the 1523 program to work, hence the name 'option', but are used to modify its 1524 default behaviour. For example, a program could do its job quietly, 1525 but with a suitable option it could provide verbose information about 1526 what it did. 1527 1528 Command line options come in several flavours. Historically, they are 1529 preceded by a single dash C<->, and consist of a single letter. 1530 1531 -l -a -c 1532 1533 Usually, these single-character options can be bundled: 1534 1535 -lac 1536 1537 Options can have values, the value is placed after the option 1538 character. Sometimes with whitespace in between, sometimes not: 1539 1540 -s 24 -s24 1541 1542 Due to the very cryptic nature of these options, another style was 1543 developed that used long names. So instead of a cryptic C<-l> one 1544 could use the more descriptive C<--long>. To distinguish between a 1545 bundle of single-character options and a long one, two dashes are used 1546 to precede the option name. Early implementations of long options used 1547 a plus C<+> instead. Also, option values could be specified either 1548 like 1549 1550 --size=24 1551 1552 or 1553 1554 --size 24 1555 1556 The C<+> form is now obsolete and strongly deprecated. 1557 1558 =head1 Getting Started with Getopt::Long 1559 1560 Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the 1561 first Perl module that provided support for handling the new style of 1562 command line options, hence the name Getopt::Long. This module also 1563 supports single-character options and bundling. Single character 1564 options may be any alphabetic character, a question mark, and a dash. 1565 Long options may consist of a series of letters, digits, and dashes. 1566 Although this is currently not enforced by Getopt::Long, multiple 1567 consecutive dashes are not allowed, and the option name must not end 1568 with a dash. 1569 1570 To use Getopt::Long from a Perl program, you must include the 1571 following line in your Perl program: 1572 1573 use Getopt::Long; 1574 1575 This will load the core of the Getopt::Long module and prepare your 1576 program for using it. Most of the actual Getopt::Long code is not 1577 loaded until you really call one of its functions. 1578 1579 In the default configuration, options names may be abbreviated to 1580 uniqueness, case does not matter, and a single dash is sufficient, 1581 even for long option names. Also, options may be placed between 1582 non-option arguments. See L<Configuring Getopt::Long> for more 1583 details on how to configure Getopt::Long. 1584 1585 =head2 Simple options 1586 1587 The most simple options are the ones that take no values. Their mere 1588 presence on the command line enables the option. Popular examples are: 1589 1590 --all --verbose --quiet --debug 1591 1592 Handling simple options is straightforward: 1593 1594 my $verbose = ''; # option variable with default value (false) 1595 my $all = ''; # option variable with default value (false) 1596 GetOptions ('verbose' => \$verbose, 'all' => \$all); 1597 1598 The call to GetOptions() parses the command line arguments that are 1599 present in C<@ARGV> and sets the option variable to the value C<1> if 1600 the option did occur on the command line. Otherwise, the option 1601 variable is not touched. Setting the option value to true is often 1602 called I<enabling> the option. 1603 1604 The option name as specified to the GetOptions() function is called 1605 the option I<specification>. Later we'll see that this specification 1606 can contain more than just the option name. The reference to the 1607 variable is called the option I<destination>. 1608 1609 GetOptions() will return a true value if the command line could be 1610 processed successfully. Otherwise, it will write error messages to 1611 STDERR, and return a false result. 1612 1613 =head2 A little bit less simple options 1614 1615 Getopt::Long supports two useful variants of simple options: 1616 I<negatable> options and I<incremental> options. 1617 1618 A negatable option is specified with an exclamation mark C<!> after the 1619 option name: 1620 1621 my $verbose = ''; # option variable with default value (false) 1622 GetOptions ('verbose!' => \$verbose); 1623 1624 Now, using C<--verbose> on the command line will enable C<$verbose>, 1625 as expected. But it is also allowed to use C<--noverbose>, which will 1626 disable C<$verbose> by setting its value to C<0>. Using a suitable 1627 default value, the program can find out whether C<$verbose> is false 1628 by default, or disabled by using C<--noverbose>. 1629 1630 An incremental option is specified with a plus C<+> after the 1631 option name: 1632 1633 my $verbose = ''; # option variable with default value (false) 1634 GetOptions ('verbose+' => \$verbose); 1635 1636 Using C<--verbose> on the command line will increment the value of 1637 C<$verbose>. This way the program can keep track of how many times the 1638 option occurred on the command line. For example, each occurrence of 1639 C<--verbose> could increase the verbosity level of the program. 1640 1641 =head2 Mixing command line option with other arguments 1642 1643 Usually programs take command line options as well as other arguments, 1644 for example, file names. It is good practice to always specify the 1645 options first, and the other arguments last. Getopt::Long will, 1646 however, allow the options and arguments to be mixed and 'filter out' 1647 all the options before passing the rest of the arguments to the 1648 program. To stop Getopt::Long from processing further arguments, 1649 insert a double dash C<--> on the command line: 1650 1651 --size 24 -- --all 1652 1653 In this example, C<--all> will I<not> be treated as an option, but 1654 passed to the program unharmed, in C<@ARGV>. 1655 1656 =head2 Options with values 1657 1658 For options that take values it must be specified whether the option 1659 value is required or not, and what kind of value the option expects. 1660 1661 Three kinds of values are supported: integer numbers, floating point 1662 numbers, and strings. 1663 1664 If the option value is required, Getopt::Long will take the 1665 command line argument that follows the option and assign this to the 1666 option variable. If, however, the option value is specified as 1667 optional, this will only be done if that value does not look like a 1668 valid command line option itself. 1669 1670 my $tag = ''; # option variable with default value 1671 GetOptions ('tag=s' => \$tag); 1672 1673 In the option specification, the option name is followed by an equals 1674 sign C<=> and the letter C<s>. The equals sign indicates that this 1675 option requires a value. The letter C<s> indicates that this value is 1676 an arbitrary string. Other possible value types are C<i> for integer 1677 values, and C<f> for floating point values. Using a colon C<:> instead 1678 of the equals sign indicates that the option value is optional. In 1679 this case, if no suitable value is supplied, string valued options get 1680 an empty string C<''> assigned, while numeric options are set to C<0>. 1681 1682 =head2 Options with multiple values 1683 1684 Options sometimes take several values. For example, a program could 1685 use multiple directories to search for library files: 1686 1687 --library lib/stdlib --library lib/extlib 1688 1689 To accomplish this behaviour, simply specify an array reference as the 1690 destination for the option: 1691 1692 GetOptions ("library=s" => \@libfiles); 1693 1694 Alternatively, you can specify that the option can have multiple 1695 values by adding a "@", and pass a scalar reference as the 1696 destination: 1697 1698 GetOptions ("library=s@" => \$libfiles); 1699 1700 Used with the example above, C<@libfiles> (or C<@$libfiles>) would 1701 contain two strings upon completion: C<"lib/srdlib"> and 1702 C<"lib/extlib">, in that order. It is also possible to specify that 1703 only integer or floating point numbers are acceptable values. 1704 1705 Often it is useful to allow comma-separated lists of values as well as 1706 multiple occurrences of the options. This is easy using Perl's split() 1707 and join() operators: 1708 1709 GetOptions ("library=s" => \@libfiles); 1710 @libfiles = split(/,/,join(',',@libfiles)); 1711 1712 Of course, it is important to choose the right separator string for 1713 each purpose. 1714 1715 Warning: What follows is an experimental feature. 1716 1717 Options can take multiple values at once, for example 1718 1719 --coordinates 52.2 16.4 --rgbcolor 255 255 149 1720 1721 This can be accomplished by adding a repeat specifier to the option 1722 specification. Repeat specifiers are very similar to the C<{...}> 1723 repeat specifiers that can be used with regular expression patterns. 1724 For example, the above command line would be handled as follows: 1725 1726 GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color); 1727 1728 The destination for the option must be an array or array reference. 1729 1730 It is also possible to specify the minimal and maximal number of 1731 arguments an option takes. C<foo=s{2,4}> indicates an option that 1732 takes at least two and at most 4 arguments. C<foo=s{,}> indicates one 1733 or more values; C<foo:s{,}> indicates zero or more option values. 1734 1735 =head2 Options with hash values 1736 1737 If the option destination is a reference to a hash, the option will 1738 take, as value, strings of the form I<key>C<=>I<value>. The value will 1739 be stored with the specified key in the hash. 1740 1741 GetOptions ("define=s" => \%defines); 1742 1743 Alternatively you can use: 1744 1745 GetOptions ("define=s%" => \$defines); 1746 1747 When used with command line options: 1748 1749 --define os=linux --define vendor=redhat 1750 1751 the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> 1752 with value C<"linux> and C<"vendor"> with value C<"redhat">. It is 1753 also possible to specify that only integer or floating point numbers 1754 are acceptable values. The keys are always taken to be strings. 1755 1756 =head2 User-defined subroutines to handle options 1757 1758 Ultimate control over what should be done when (actually: each time) 1759 an option is encountered on the command line can be achieved by 1760 designating a reference to a subroutine (or an anonymous subroutine) 1761 as the option destination. When GetOptions() encounters the option, it 1762 will call the subroutine with two or three arguments. The first 1763 argument is the name of the option. For a scalar or array destination, 1764 the second argument is the value to be stored. For a hash destination, 1765 the second arguments is the key to the hash, and the third argument 1766 the value to be stored. It is up to the subroutine to store the value, 1767 or do whatever it thinks is appropriate. 1768 1769 A trivial application of this mechanism is to implement options that 1770 are related to each other. For example: 1771 1772 my $verbose = ''; # option variable with default value (false) 1773 GetOptions ('verbose' => \$verbose, 1774 'quiet' => sub { $verbose = 0 }); 1775 1776 Here C<--verbose> and C<--quiet> control the same variable 1777 C<$verbose>, but with opposite values. 1778 1779 If the subroutine needs to signal an error, it should call die() with 1780 the desired error message as its argument. GetOptions() will catch the 1781 die(), issue the error message, and record that an error result must 1782 be returned upon completion. 1783 1784 If the text of the error message starts with an exclamation mark C<!> 1785 it is interpreted specially by GetOptions(). There is currently one 1786 special command implemented: C<die("!FINISH")> will cause GetOptions() 1787 to stop processing options, as if it encountered a double dash C<-->. 1788 1789 =head2 Options with multiple names 1790 1791 Often it is user friendly to supply alternate mnemonic names for 1792 options. For example C<--height> could be an alternate name for 1793 C<--length>. Alternate names can be included in the option 1794 specification, separated by vertical bar C<|> characters. To implement 1795 the above example: 1796 1797 GetOptions ('length|height=f' => \$length); 1798 1799 The first name is called the I<primary> name, the other names are 1800 called I<aliases>. When using a hash to store options, the key will 1801 always be the primary name. 1802 1803 Multiple alternate names are possible. 1804 1805 =head2 Case and abbreviations 1806 1807 Without additional configuration, GetOptions() will ignore the case of 1808 option names, and allow the options to be abbreviated to uniqueness. 1809 1810 GetOptions ('length|height=f' => \$length, "head" => \$head); 1811 1812 This call will allow C<--l> and C<--L> for the length option, but 1813 requires a least C<--hea> and C<--hei> for the head and height options. 1814 1815 =head2 Summary of Option Specifications 1816 1817 Each option specifier consists of two parts: the name specification 1818 and the argument specification. 1819 1820 The name specification contains the name of the option, optionally 1821 followed by a list of alternative names separated by vertical bar 1822 characters. 1823 1824 length option name is "length" 1825 length|size|l name is "length", aliases are "size" and "l" 1826 1827 The argument specification is optional. If omitted, the option is 1828 considered boolean, a value of 1 will be assigned when the option is 1829 used on the command line. 1830 1831 The argument specification can be 1832 1833 =over 4 1834 1835 =item ! 1836 1837 The option does not take an argument and may be negated by prefixing 1838 it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of 1839 1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of 1840 0 will be assigned). If the option has aliases, this applies to the 1841 aliases as well. 1842 1843 Using negation on a single letter option when bundling is in effect is 1844 pointless and will result in a warning. 1845 1846 =item + 1847 1848 The option does not take an argument and will be incremented by 1 1849 every time it appears on the command line. E.g. C<"more+">, when used 1850 with C<--more --more --more>, will increment the value three times, 1851 resulting in a value of 3 (provided it was 0 or undefined at first). 1852 1853 The C<+> specifier is ignored if the option destination is not a scalar. 1854 1855 =item = I<type> [ I<desttype> ] [ I<repeat> ] 1856 1857 The option requires an argument of the given type. Supported types 1858 are: 1859 1860 =over 4 1861 1862 =item s 1863 1864 String. An arbitrary sequence of characters. It is valid for the 1865 argument to start with C<-> or C<-->. 1866 1867 =item i 1868 1869 Integer. An optional leading plus or minus sign, followed by a 1870 sequence of digits. 1871 1872 =item o 1873 1874 Extended integer, Perl style. This can be either an optional leading 1875 plus or minus sign, followed by a sequence of digits, or an octal 1876 string (a zero, optionally followed by '0', '1', .. '7'), or a 1877 hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case 1878 insensitive), or a binary string (C<0b> followed by a series of '0' 1879 and '1'). 1880 1881 =item f 1882 1883 Real number. For example C<3.14>, C<-6.23E24> and so on. 1884 1885 =back 1886 1887 The I<desttype> can be C<@> or C<%> to specify that the option is 1888 list or a hash valued. This is only needed when the destination for 1889 the option value is not otherwise specified. It should be omitted when 1890 not needed. 1891 1892 The I<repeat> specifies the number of values this option takes per 1893 occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>. 1894 1895 I<min> denotes the minimal number of arguments. It defaults to 1 for 1896 options with C<=> and to 0 for options with C<:>, see below. Note that 1897 I<min> overrules the C<=> / C<:> semantics. 1898 1899 I<max> denotes the maximum number of arguments. It must be at least 1900 I<min>. If I<max> is omitted, I<but the comma is not>, there is no 1901 upper bound to the number of argument values taken. 1902 1903 =item : I<type> [ I<desttype> ] 1904 1905 Like C<=>, but designates the argument as optional. 1906 If omitted, an empty string will be assigned to string values options, 1907 and the value zero to numeric options. 1908 1909 Note that if a string argument starts with C<-> or C<-->, it will be 1910 considered an option on itself. 1911 1912 =item : I<number> [ I<desttype> ] 1913 1914 Like C<:i>, but if the value is omitted, the I<number> will be assigned. 1915 1916 =item : + [ I<desttype> ] 1917 1918 Like C<:i>, but if the value is omitted, the current value for the 1919 option will be incremented. 1920 1921 =back 1922 1923 =head1 Advanced Possibilities 1924 1925 =head2 Object oriented interface 1926 1927 Getopt::Long can be used in an object oriented way as well: 1928 1929 use Getopt::Long; 1930 $p = new Getopt::Long::Parser; 1931 $p->configure(...configuration options...); 1932 if ($p->getoptions(...options descriptions...)) ... 1933 1934 Configuration options can be passed to the constructor: 1935 1936 $p = new Getopt::Long::Parser 1937 config => [...configuration options...]; 1938 1939 =head2 Thread Safety 1940 1941 Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is 1942 I<not> thread safe when using the older (experimental and now 1943 obsolete) threads implementation that was added to Perl 5.005. 1944 1945 =head2 Documentation and help texts 1946 1947 Getopt::Long encourages the use of Pod::Usage to produce help 1948 messages. For example: 1949 1950 use Getopt::Long; 1951 use Pod::Usage; 1952 1953 my $man = 0; 1954 my $help = 0; 1955 1956 GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); 1957 pod2usage(1) if $help; 1958 pod2usage(-exitstatus => 0, -verbose => 2) if $man; 1959 1960 __END__ 1961 1962 =head1 NAME 1963 1964 sample - Using Getopt::Long and Pod::Usage 1965 1966 =head1 SYNOPSIS 1967 1968 sample [options] [file ...] 1969 1970 Options: 1971 -help brief help message 1972 -man full documentation 1973 1974 =head1 OPTIONS 1975 1976 =over 8 1977 1978 =item B<-help> 1979 1980 Print a brief help message and exits. 1981 1982 =item B<-man> 1983 1984 Prints the manual page and exits. 1985 1986 =back 1987 1988 =head1 DESCRIPTION 1989 1990 B<This program> will read the given input file(s) and do something 1991 useful with the contents thereof. 1992 1993 =cut 1994 1995 See L<Pod::Usage> for details. 1996 1997 =head2 Parsing options from an arbitrary array 1998 1999 By default, GetOptions parses the options that are present in the 2000 global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be 2001 used to parse options from an arbitrary array. 2002 2003 use Getopt::Long qw(GetOptionsFromArray); 2004 $ret = GetOptionsFromArray(\@myopts, ...); 2005 2006 When used like this, the global C<@ARGV> is not touched at all. 2007 2008 The following two calls behave identically: 2009 2010 $ret = GetOptions( ... ); 2011 $ret = GetOptionsFromArray(\@ARGV, ... ); 2012 2013 =head2 Parsing options from an arbitrary string 2014 2015 A special entry C<GetOptionsFromString> can be used to parse options 2016 from an arbitrary string. 2017 2018 use Getopt::Long qw(GetOptionsFromString); 2019 $ret = GetOptionsFromString($string, ...); 2020 2021 The contents of the string are split into arguments using a call to 2022 C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the 2023 global C<@ARGV> is not touched. 2024 2025 It is possible that, upon completion, not all arguments in the string 2026 have been processed. C<GetOptionsFromString> will, when called in list 2027 context, return both the return status and an array reference to any 2028 remaining arguments: 2029 2030 ($ret, $args) = GetOptionsFromString($string, ... ); 2031 2032 If any arguments remain, and C<GetOptionsFromString> was not called in 2033 list context, a message will be given and C<GetOptionsFromString> will 2034 return failure. 2035 2036 =head2 Storing options values in a hash 2037 2038 Sometimes, for example when there are a lot of options, having a 2039 separate variable for each of them can be cumbersome. GetOptions() 2040 supports, as an alternative mechanism, storing options values in a 2041 hash. 2042 2043 To obtain this, a reference to a hash must be passed I<as the first 2044 argument> to GetOptions(). For each option that is specified on the 2045 command line, the option value will be stored in the hash with the 2046 option name as key. Options that are not actually used on the command 2047 line will not be put in the hash, on other words, 2048 C<exists($h{option})> (or defined()) can be used to test if an option 2049 was used. The drawback is that warnings will be issued if the program 2050 runs under C<use strict> and uses C<$h{option}> without testing with 2051 exists() or defined() first. 2052 2053 my %h = (); 2054 GetOptions (\%h, 'length=i'); # will store in $h{length} 2055 2056 For options that take list or hash values, it is necessary to indicate 2057 this by appending an C<@> or C<%> sign after the type: 2058 2059 GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} 2060 2061 To make things more complicated, the hash may contain references to 2062 the actual destinations, for example: 2063 2064 my $len = 0; 2065 my %h = ('length' => \$len); 2066 GetOptions (\%h, 'length=i'); # will store in $len 2067 2068 This example is fully equivalent with: 2069 2070 my $len = 0; 2071 GetOptions ('length=i' => \$len); # will store in $len 2072 2073 Any mixture is possible. For example, the most frequently used options 2074 could be stored in variables while all other options get stored in the 2075 hash: 2076 2077 my $verbose = 0; # frequently referred 2078 my $debug = 0; # frequently referred 2079 my %h = ('verbose' => \$verbose, 'debug' => \$debug); 2080 GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); 2081 if ( $verbose ) { ... } 2082 if ( exists $h{filter} ) { ... option 'filter' was specified ... } 2083 2084 =head2 Bundling 2085 2086 With bundling it is possible to set several single-character options 2087 at once. For example if C<a>, C<v> and C<x> are all valid options, 2088 2089 -vax 2090 2091 would set all three. 2092 2093 Getopt::Long supports two levels of bundling. To enable bundling, a 2094 call to Getopt::Long::Configure is required. 2095 2096 The first level of bundling can be enabled with: 2097 2098 Getopt::Long::Configure ("bundling"); 2099 2100 Configured this way, single-character options can be bundled but long 2101 options B<must> always start with a double dash C<--> to avoid 2102 ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid 2103 options, 2104 2105 -vax 2106 2107 would set C<a>, C<v> and C<x>, but 2108 2109 --vax 2110 2111 would set C<vax>. 2112 2113 The second level of bundling lifts this restriction. It can be enabled 2114 with: 2115 2116 Getopt::Long::Configure ("bundling_override"); 2117 2118 Now, C<-vax> would set the option C<vax>. 2119 2120 When any level of bundling is enabled, option values may be inserted 2121 in the bundle. For example: 2122 2123 -h24w80 2124 2125 is equivalent to 2126 2127 -h 24 -w 80 2128 2129 When configured for bundling, single-character options are matched 2130 case sensitive while long options are matched case insensitive. To 2131 have the single-character options matched case insensitive as well, 2132 use: 2133 2134 Getopt::Long::Configure ("bundling", "ignorecase_always"); 2135 2136 It goes without saying that bundling can be quite confusing. 2137 2138 =head2 The lonesome dash 2139 2140 Normally, a lone dash C<-> on the command line will not be considered 2141 an option. Option processing will terminate (unless "permute" is 2142 configured) and the dash will be left in C<@ARGV>. 2143 2144 It is possible to get special treatment for a lone dash. This can be 2145 achieved by adding an option specification with an empty name, for 2146 example: 2147 2148 GetOptions ('' => \$stdio); 2149 2150 A lone dash on the command line will now be a legal option, and using 2151 it will set variable C<$stdio>. 2152 2153 =head2 Argument callback 2154 2155 A special option 'name' C<< <> >> can be used to designate a subroutine 2156 to handle non-option arguments. When GetOptions() encounters an 2157 argument that does not look like an option, it will immediately call this 2158 subroutine and passes it one parameter: the argument name. 2159 2160 For example: 2161 2162 my $width = 80; 2163 sub process { ... } 2164 GetOptions ('width=i' => \$width, '<>' => \&process); 2165 2166 When applied to the following command line: 2167 2168 arg1 --width=72 arg2 --width=60 arg3 2169 2170 This will call 2171 C<process("arg1")> while C<$width> is C<80>, 2172 C<process("arg2")> while C<$width> is C<72>, and 2173 C<process("arg3")> while C<$width> is C<60>. 2174 2175 This feature requires configuration option B<permute>, see section 2176 L<Configuring Getopt::Long>. 2177 2178 =head1 Configuring Getopt::Long 2179 2180 Getopt::Long can be configured by calling subroutine 2181 Getopt::Long::Configure(). This subroutine takes a list of quoted 2182 strings, each specifying a configuration option to be enabled, e.g. 2183 C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not 2184 matter. Multiple calls to Configure() are possible. 2185 2186 Alternatively, as of version 2.24, the configuration options may be 2187 passed together with the C<use> statement: 2188 2189 use Getopt::Long qw(:config no_ignore_case bundling); 2190 2191 The following options are available: 2192 2193 =over 12 2194 2195 =item default 2196 2197 This option causes all configuration options to be reset to their 2198 default values. 2199 2200 =item posix_default 2201 2202 This option causes all configuration options to be reset to their 2203 default values as if the environment variable POSIXLY_CORRECT had 2204 been set. 2205 2206 =item auto_abbrev 2207 2208 Allow option names to be abbreviated to uniqueness. 2209 Default is enabled unless environment variable 2210 POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled. 2211 2212 =item getopt_compat 2213 2214 Allow C<+> to start options. 2215 Default is enabled unless environment variable 2216 POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled. 2217 2218 =item gnu_compat 2219 2220 C<gnu_compat> controls whether C<--opt=> is allowed, and what it should 2221 do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>, 2222 C<--opt=> will give option C<opt> and empty value. 2223 This is the way GNU getopt_long() does it. 2224 2225 =item gnu_getopt 2226 2227 This is a short way of setting C<gnu_compat> C<bundling> C<permute> 2228 C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be 2229 fully compatible with GNU getopt_long(). 2230 2231 =item require_order 2232 2233 Whether command line arguments are allowed to be mixed with options. 2234 Default is disabled unless environment variable 2235 POSIXLY_CORRECT has been set, in which case C<require_order> is enabled. 2236 2237 See also C<permute>, which is the opposite of C<require_order>. 2238 2239 =item permute 2240 2241 Whether command line arguments are allowed to be mixed with options. 2242 Default is enabled unless environment variable 2243 POSIXLY_CORRECT has been set, in which case C<permute> is disabled. 2244 Note that C<permute> is the opposite of C<require_order>. 2245 2246 If C<permute> is enabled, this means that 2247 2248 --foo arg1 --bar arg2 arg3 2249 2250 is equivalent to 2251 2252 --foo --bar arg1 arg2 arg3 2253 2254 If an argument callback routine is specified, C<@ARGV> will always be 2255 empty upon successful return of GetOptions() since all options have been 2256 processed. The only exception is when C<--> is used: 2257 2258 --foo arg1 --bar arg2 -- arg3 2259 2260 This will call the callback routine for arg1 and arg2, and then 2261 terminate GetOptions() leaving C<"arg3"> in C<@ARGV>. 2262 2263 If C<require_order> is enabled, options processing 2264 terminates when the first non-option is encountered. 2265 2266 --foo arg1 --bar arg2 arg3 2267 2268 is equivalent to 2269 2270 --foo -- arg1 --bar arg2 arg3 2271 2272 If C<pass_through> is also enabled, options processing will terminate 2273 at the first unrecognized option, or non-option, whichever comes 2274 first. 2275 2276 =item bundling (default: disabled) 2277 2278 Enabling this option will allow single-character options to be 2279 bundled. To distinguish bundles from long option names, long options 2280 I<must> be introduced with C<--> and bundles with C<->. 2281 2282 Note that, if you have options C<a>, C<l> and C<all>, and 2283 auto_abbrev enabled, possible arguments and option settings are: 2284 2285 using argument sets option(s) 2286 ------------------------------------------ 2287 -a, --a a 2288 -l, --l l 2289 -al, -la, -ala, -all,... a, l 2290 --al, --all all 2291 2292 The surprising part is that C<--a> sets option C<a> (due to auto 2293 completion), not C<all>. 2294 2295 Note: disabling C<bundling> also disables C<bundling_override>. 2296 2297 =item bundling_override (default: disabled) 2298 2299 If C<bundling_override> is enabled, bundling is enabled as with 2300 C<bundling> but now long option names override option bundles. 2301 2302 Note: disabling C<bundling_override> also disables C<bundling>. 2303 2304 B<Note:> Using option bundling can easily lead to unexpected results, 2305 especially when mixing long options and bundles. Caveat emptor. 2306 2307 =item ignore_case (default: enabled) 2308 2309 If enabled, case is ignored when matching long option names. If, 2310 however, bundling is enabled as well, single character options will be 2311 treated case-sensitive. 2312 2313 With C<ignore_case>, option specifications for options that only 2314 differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as 2315 duplicates. 2316 2317 Note: disabling C<ignore_case> also disables C<ignore_case_always>. 2318 2319 =item ignore_case_always (default: disabled) 2320 2321 When bundling is in effect, case is ignored on single-character 2322 options also. 2323 2324 Note: disabling C<ignore_case_always> also disables C<ignore_case>. 2325 2326 =item auto_version (default:disabled) 2327 2328 Automatically provide support for the B<--version> option if 2329 the application did not specify a handler for this option itself. 2330 2331 Getopt::Long will provide a standard version message that includes the 2332 program name, its version (if $main::VERSION is defined), and the 2333 versions of Getopt::Long and Perl. The message will be written to 2334 standard output and processing will terminate. 2335 2336 C<auto_version> will be enabled if the calling program explicitly 2337 specified a version number higher than 2.32 in the C<use> or 2338 C<require> statement. 2339 2340 =item auto_help (default:disabled) 2341 2342 Automatically provide support for the B<--help> and B<-?> options if 2343 the application did not specify a handler for this option itself. 2344 2345 Getopt::Long will provide a help message using module L<Pod::Usage>. The 2346 message, derived from the SYNOPSIS POD section, will be written to 2347 standard output and processing will terminate. 2348 2349 C<auto_help> will be enabled if the calling program explicitly 2350 specified a version number higher than 2.32 in the C<use> or 2351 C<require> statement. 2352 2353 =item pass_through (default: disabled) 2354 2355 Options that are unknown, ambiguous or supplied with an invalid option 2356 value are passed through in C<@ARGV> instead of being flagged as 2357 errors. This makes it possible to write wrapper scripts that process 2358 only part of the user supplied command line arguments, and pass the 2359 remaining options to some other program. 2360 2361 If C<require_order> is enabled, options processing will terminate at 2362 the first unrecognized option, or non-option, whichever comes first. 2363 However, if C<permute> is enabled instead, results can become confusing. 2364 2365 Note that the options terminator (default C<-->), if present, will 2366 also be passed through in C<@ARGV>. 2367 2368 =item prefix 2369 2370 The string that starts options. If a constant string is not 2371 sufficient, see C<prefix_pattern>. 2372 2373 =item prefix_pattern 2374 2375 A Perl pattern that identifies the strings that introduce options. 2376 Default is C<--|-|\+> unless environment variable 2377 POSIXLY_CORRECT has been set, in which case it is C<--|->. 2378 2379 =item long_prefix_pattern 2380 2381 A Perl pattern that allows the disambiguation of long and short 2382 prefixes. Default is C<-->. 2383 2384 Typically you only need to set this if you are using nonstandard 2385 prefixes and want some or all of them to have the same semantics as 2386 '--' does under normal circumstances. 2387 2388 For example, setting prefix_pattern to C<--|-|\+|\/> and 2389 long_prefix_pattern to C<--|\/> would add Win32 style argument 2390 handling. 2391 2392 =item debug (default: disabled) 2393 2394 Enable debugging output. 2395 2396 =back 2397 2398 =head1 Exportable Methods 2399 2400 =over 2401 2402 =item VersionMessage 2403 2404 This subroutine provides a standard version message. Its argument can be: 2405 2406 =over 4 2407 2408 =item * 2409 2410 A string containing the text of a message to print I<before> printing 2411 the standard message. 2412 2413 =item * 2414 2415 A numeric value corresponding to the desired exit status. 2416 2417 =item * 2418 2419 A reference to a hash. 2420 2421 =back 2422 2423 If more than one argument is given then the entire argument list is 2424 assumed to be a hash. If a hash is supplied (either as a reference or 2425 as a list) it should contain one or more elements with the following 2426 keys: 2427 2428 =over 4 2429 2430 =item C<-message> 2431 2432 =item C<-msg> 2433 2434 The text of a message to print immediately prior to printing the 2435 program's usage message. 2436 2437 =item C<-exitval> 2438 2439 The desired exit status to pass to the B<exit()> function. 2440 This should be an integer, or else the string "NOEXIT" to 2441 indicate that control should simply be returned without 2442 terminating the invoking process. 2443 2444 =item C<-output> 2445 2446 A reference to a filehandle, or the pathname of a file to which the 2447 usage message should be written. The default is C<\*STDERR> unless the 2448 exit value is less than 2 (in which case the default is C<\*STDOUT>). 2449 2450 =back 2451 2452 You cannot tie this routine directly to an option, e.g.: 2453 2454 GetOptions("version" => \&VersionMessage); 2455 2456 Use this instead: 2457 2458 GetOptions("version" => sub { VersionMessage() }); 2459 2460 =item HelpMessage 2461 2462 This subroutine produces a standard help message, derived from the 2463 program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same 2464 arguments as VersionMessage(). In particular, you cannot tie it 2465 directly to an option, e.g.: 2466 2467 GetOptions("help" => \&HelpMessage); 2468 2469 Use this instead: 2470 2471 GetOptions("help" => sub { HelpMessage() }); 2472 2473 =back 2474 2475 =head1 Return values and Errors 2476 2477 Configuration errors and errors in the option definitions are 2478 signalled using die() and will terminate the calling program unless 2479 the call to Getopt::Long::GetOptions() was embedded in C<eval { ... 2480 }>, or die() was trapped using C<$SIG{__DIE__}>. 2481 2482 GetOptions returns true to indicate success. 2483 It returns false when the function detected one or more errors during 2484 option parsing. These errors are signalled using warn() and can be 2485 trapped with C<$SIG{__WARN__}>. 2486 2487 =head1 Legacy 2488 2489 The earliest development of C<newgetopt.pl> started in 1990, with Perl 2490 version 4. As a result, its development, and the development of 2491 Getopt::Long, has gone through several stages. Since backward 2492 compatibility has always been extremely important, the current version 2493 of Getopt::Long still supports a lot of constructs that nowadays are 2494 no longer necessary or otherwise unwanted. This section describes 2495 briefly some of these 'features'. 2496 2497 =head2 Default destinations 2498 2499 When no destination is specified for an option, GetOptions will store 2500 the resultant value in a global variable named C<opt_>I<XXX>, where 2501 I<XXX> is the primary name of this option. When a progam executes 2502 under C<use strict> (recommended), these variables must be 2503 pre-declared with our() or C<use vars>. 2504 2505 our $opt_length = 0; 2506 GetOptions ('length=i'); # will store in $opt_length 2507 2508 To yield a usable Perl variable, characters that are not part of the 2509 syntax for variables are translated to underscores. For example, 2510 C<--fpp-struct-return> will set the variable 2511 C<$opt_fpp_struct_return>. Note that this variable resides in the 2512 namespace of the calling program, not necessarily C<main>. For 2513 example: 2514 2515 GetOptions ("size=i", "sizes=i@"); 2516 2517 with command line "-size 10 -sizes 24 -sizes 48" will perform the 2518 equivalent of the assignments 2519 2520 $opt_size = 10; 2521 @opt_sizes = (24, 48); 2522 2523 =head2 Alternative option starters 2524 2525 A string of alternative option starter characters may be passed as the 2526 first argument (or the first argument after a leading hash reference 2527 argument). 2528 2529 my $len = 0; 2530 GetOptions ('/', 'length=i' => $len); 2531 2532 Now the command line may look like: 2533 2534 /length 24 -- arg 2535 2536 Note that to terminate options processing still requires a double dash 2537 C<-->. 2538 2539 GetOptions() will not interpret a leading C<< "<>" >> as option starters 2540 if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as 2541 option starters, use C<< "><" >>. Confusing? Well, B<using a starter 2542 argument is strongly deprecated> anyway. 2543 2544 =head2 Configuration variables 2545 2546 Previous versions of Getopt::Long used variables for the purpose of 2547 configuring. Although manipulating these variables still work, it is 2548 strongly encouraged to use the C<Configure> routine that was introduced 2549 in version 2.17. Besides, it is much easier. 2550 2551 =head1 Tips and Techniques 2552 2553 =head2 Pushing multiple values in a hash option 2554 2555 Sometimes you want to combine the best of hashes and arrays. For 2556 example, the command line: 2557 2558 --list add=first --list add=second --list add=third 2559 2560 where each successive 'list add' option will push the value of add 2561 into array ref $list->{'add'}. The result would be like 2562 2563 $list->{add} = [qw(first second third)]; 2564 2565 This can be accomplished with a destination routine: 2566 2567 GetOptions('list=s%' => 2568 sub { push(@{$list{$_[1]}}, $_[2]) }); 2569 2570 =head1 Trouble Shooting 2571 2572 =head2 GetOptions does not return a false result when an option is not supplied 2573 2574 That's why they're called 'options'. 2575 2576 =head2 GetOptions does not split the command line correctly 2577 2578 The command line is not split by GetOptions, but by the command line 2579 interpreter (CLI). On Unix, this is the shell. On Windows, it is 2580 COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. 2581 2582 It is important to know that these CLIs may behave different when the 2583 command line contains special characters, in particular quotes or 2584 backslashes. For example, with Unix shells you can use single quotes 2585 (C<'>) and double quotes (C<">) to group words together. The following 2586 alternatives are equivalent on Unix: 2587 2588 "two words" 2589 'two words' 2590 two\ words 2591 2592 In case of doubt, insert the following statement in front of your Perl 2593 program: 2594 2595 print STDERR (join("|",@ARGV),"\n"); 2596 2597 to verify how your CLI passes the arguments to the program. 2598 2599 =head2 Undefined subroutine &main::GetOptions called 2600 2601 Are you running Windows, and did you write 2602 2603 use GetOpt::Long; 2604 2605 (note the capital 'O')? 2606 2607 =head2 How do I put a "-?" option into a Getopt::Long? 2608 2609 You can only obtain this using an alias, and Getopt::Long of at least 2610 version 2.13. 2611 2612 use Getopt::Long; 2613 GetOptions ("help|?"); # -help and -? will both set $opt_help 2614 2615 =head1 AUTHOR 2616 2617 Johan Vromans <jvromans@squirrel.nl> 2618 2619 =head1 COPYRIGHT AND DISCLAIMER 2620 2621 This program is Copyright 1990,2007 by Johan Vromans. 2622 This program is free software; you can redistribute it and/or 2623 modify it under the terms of the Perl Artistic License or the 2624 GNU General Public License as published by the Free Software 2625 Foundation; either version 2 of the License, or (at your option) any 2626 later version. 2627 2628 This program is distributed in the hope that it will be useful, 2629 but WITHOUT ANY WARRANTY; without even the implied warranty of 2630 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 2631 GNU General Public License for more details. 2632 2633 If you do not have a copy of the GNU General Public License write to 2634 the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 2635 MA 02139, USA. 2636 2637 =cut 2638
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |