1# This program is copyright 2007-2011 Baron Schwartz, 2011 Percona Ireland Ltd. 2# Feedback and improvements are welcome. 3# 4# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 5# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 6# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 7# 8# This program is free software; you can redistribute it and/or modify it under 9# the terms of the GNU General Public License as published by the Free Software 10# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar 11# systems, you can issue `man perlgpl' or `man perlartistic' to read these 12# licenses. 13# 14# You should have received a copy of the GNU General Public License along with 15# this program; if not, write to the Free Software Foundation, Inc., 59 Temple 16# Place, Suite 330, Boston, MA 02111-1307 USA. 17# ########################################################################### 18# OptionParser package 19# ########################################################################### 20{ 21package OptionParser; 22 23use strict; 24use warnings FATAL => 'all'; 25use English qw(-no_match_vars); 26use constant PTDEBUG => $ENV{PTDEBUG} || 0; 27 28use List::Util qw(max); 29use Getopt::Long; 30use Data::Dumper; 31 32my $POD_link_re = '[LC]<"?([^">]+)"?>'; 33 34# Sub: new 35# 36# Parameters: 37# %args - Arguments 38# 39# Optional Arguments: 40# file - Filename to parse POD stuff from. Several subs take 41# a $file param mostly for testing purposes. This arg 42# provides a "global" default for even easier testing. 43# description - Tool's description (overrides description from SYNOPSIS). 44# usage - Tool's usage line (overrides Usage from SYNOPSIS). 45# head1 - head1 heading under which options are listed 46# skip_rules - Don't read paras before options as rules 47# item - Regex pattern to match options after =item 48# attributes - Hashref of allowed option attributes 49# parse_attributes - Coderef for parsing option attributes 50# 51# Returns: 52# OptionParser object 53sub new { 54 my ( $class, %args ) = @_; 55 my @required_args = qw(); 56 foreach my $arg ( @required_args ) { 57 die "I need a $arg argument" unless $args{$arg}; 58 } 59 60 my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/; 61 $program_name ||= $PROGRAM_NAME; 62 my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.'; 63 64 # Default attributes. 65 my %attributes = ( 66 'type' => 1, 67 'short form' => 1, 68 'group' => 1, 69 'default' => 1, 70 'cumulative' => 1, 71 'negatable' => 1, 72 'repeatable' => 1, # means it can be specified more than once 73 ); 74 75 my $self = { 76 head1 => 'OPTIONS', # These args are used internally 77 skip_rules => 0, # to instantiate another Option- 78 item => '--(.*)', # Parser obj that parses the 79 attributes => \%attributes, # DSN OPTIONS section. Tools 80 parse_attributes => \&_parse_attribs, # don't tinker with these args. 81 82 # override the above optional args' default 83 %args, 84 85 # private, not configurable args 86 strict => 1, # disabled by a special rule 87 program_name => $program_name, 88 opts => {}, 89 got_opts => 0, 90 short_opts => {}, 91 defaults => {}, 92 groups => {}, 93 allowed_groups => {}, 94 errors => [], 95 rules => [], # desc of rules for --help 96 mutex => [], # rule: opts are mutually exclusive 97 atleast1 => [], # rule: at least one opt is required 98 disables => {}, # rule: opt disables other opts 99 defaults_to => {}, # rule: opt defaults to value of other opt 100 DSNParser => undef, 101 default_files => [ 102 "/etc/percona-toolkit/percona-toolkit.conf", 103 "/etc/percona-toolkit/$program_name.conf", 104 "$home/.percona-toolkit.conf", 105 "$home/.$program_name.conf", 106 ], 107 types => { 108 string => 's', # standard Getopt type 109 int => 'i', # standard Getopt type 110 float => 'f', # standard Getopt type 111 Hash => 'H', # hash, formed from a comma-separated list 112 hash => 'h', # hash as above, but only if a value is given 113 Array => 'A', # array, similar to Hash 114 array => 'a', # array, similar to hash 115 DSN => 'd', # DSN 116 size => 'z', # size with kMG suffix (powers of 2^10) 117 time => 'm', # time, with an optional suffix of s/h/m/d 118 }, 119 }; 120 121 return bless $self, $class; 122} 123 124# Sub: get_specs 125# Read and parse options from the OPTIONS section of the POD. This sub 126# should be called first, then <get_opts()>. <_pod_to_specs()> 127# and <_parse_specs()> do most of the work. If the POD has a 128# DSN OPTIONS section then a <DSNParser> object is created which 129# can be accessed with <DSNParser()>. 130# 131# Parameters: 132# $file - File name to read, __FILE__ if none given 133sub get_specs { 134 my ( $self, $file ) = @_; 135 $file ||= $self->{file} || __FILE__; 136 my @specs = $self->_pod_to_specs($file); 137 $self->_parse_specs(@specs); 138 139 # Check file for DSN OPTIONS section. If present, parse 140 # it and create a DSNParser obj. 141 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 142 my $contents = do { local $/ = undef; <$fh> }; 143 close $fh; 144 if ( $contents =~ m/^=head1 DSN OPTIONS/m ) { 145 PTDEBUG && _d('Parsing DSN OPTIONS'); 146 my $dsn_attribs = { 147 dsn => 1, 148 copy => 1, 149 }; 150 my $parse_dsn_attribs = sub { 151 my ( $self, $option, $attribs ) = @_; 152 map { 153 my $val = $attribs->{$_}; 154 if ( $val ) { 155 $val = $val eq 'yes' ? 1 156 : $val eq 'no' ? 0 157 : $val; 158 $attribs->{$_} = $val; 159 } 160 } keys %$attribs; 161 return { 162 key => $option, 163 %$attribs, 164 }; 165 }; 166 my $dsn_o = new OptionParser( 167 description => 'DSN OPTIONS', 168 head1 => 'DSN OPTIONS', 169 dsn => 0, # XXX don't infinitely recurse! 170 item => '\* (.)', # key opts are a single character 171 skip_rules => 1, # no rules before opts 172 attributes => $dsn_attribs, 173 parse_attributes => $parse_dsn_attribs, 174 ); 175 my @dsn_opts = map { 176 my $opts = { 177 key => $_->{spec}->{key}, 178 dsn => $_->{spec}->{dsn}, 179 copy => $_->{spec}->{copy}, 180 desc => $_->{desc}, 181 }; 182 $opts; 183 } $dsn_o->_pod_to_specs($file); 184 $self->{DSNParser} = DSNParser->new(opts => \@dsn_opts); 185 } 186 187 if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) { 188 $self->{version} = $1; 189 PTDEBUG && _d($self->{version}); 190 } 191 192 return; 193} 194 195# Sub: DSNParser 196# Return the <DSNParser> object automatically created for DSN type opts. 197# 198# Returns: 199# <DSNParser> object 200sub DSNParser { 201 my ( $self ) = @_; 202 return $self->{DSNParser}; 203}; 204 205# Sub: get_defaults_files 206# Return the program's defaults files. 207# 208# Returns: 209# Array of defaults files 210sub get_defaults_files { 211 my ( $self ) = @_; 212 return @{$self->{default_files}}; 213} 214 215# Sub: _pod_to_specs() 216# Parse basic specs for each option. Each opt spec is a 217# hashref like: 218# (start code) 219# { 220# spec => GetOpt::Long specification, 221# desc => short description for --help 222# group => option group (default: 'default') 223# } 224# (end code) 225# This is step 1 of 2 of parsing the POD opts. The second is 226# C<_parse_specs()>. 227# 228# Parameters: 229# $file - File name to read, __FILE__ if none given 230# 231# Returns: 232# Array of opt spec hashrefs to pass to <_parse_specs()>. 233sub _pod_to_specs { 234 my ( $self, $file ) = @_; 235 $file ||= $self->{file} || __FILE__; 236 open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR"; 237 238 my @specs = (); 239 my @rules = (); 240 my $para; 241 242 # Read a paragraph at a time from the file. Skip everything until options 243 # are reached... 244 local $INPUT_RECORD_SEPARATOR = ''; 245 while ( $para = <$fh> ) { 246 next unless $para =~ m/^=head1 $self->{head1}/; 247 last; 248 } 249 250 # ... then read any option rules... 251 while ( $para = <$fh> ) { 252 last if $para =~ m/^=over/; 253 next if $self->{skip_rules}; 254 chomp $para; 255 $para =~ s/\s+/ /g; 256 $para =~ s/$POD_link_re/$1/go; 257 PTDEBUG && _d('Option rule:', $para); 258 push @rules, $para; 259 } 260 261 die "POD has no $self->{head1} section" unless $para; 262 263 # ... then start reading options. 264 do { 265 if ( my ($option) = $para =~ m/^=item $self->{item}/ ) { 266 chomp $para; 267 PTDEBUG && _d($para); 268 my %attribs; 269 270 $para = <$fh>; # read next paragraph, possibly attributes 271 272 if ( $para =~ m/: / ) { # attributes 273 $para =~ s/\s+\Z//g; 274 %attribs = map { 275 my ( $attrib, $val) = split(/: /, $_); 276 die "Unrecognized attribute for --$option: $attrib" 277 unless $self->{attributes}->{$attrib}; 278 ($attrib, $val); 279 } split(/; /, $para); 280 if ( $attribs{'short form'} ) { 281 $attribs{'short form'} =~ s/-//; 282 } 283 $para = <$fh>; # read next paragraph, probably short help desc 284 } 285 else { 286 PTDEBUG && _d('Option has no attributes'); 287 } 288 289 # Remove extra spaces and POD formatting (L<"">). 290 $para =~ s/\s+\Z//g; 291 $para =~ s/\s+/ /g; 292 $para =~ s/$POD_link_re/$1/go; 293 294 # Take the first period-terminated sentence as the option's short help 295 # description. 296 $para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s; 297 PTDEBUG && _d('Short help:', $para); 298 299 die "No description after option spec $option" if $para =~ m/^=item/; 300 301 # Change [no]foo to foo and set negatable attrib. See issue 140. 302 if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) { 303 $option = $base_option; 304 $attribs{'negatable'} = 1; 305 } 306 307 push @specs, { 308 spec => $self->{parse_attributes}->($self, $option, \%attribs), 309 desc => $para 310 . (defined $attribs{default} ? " (default $attribs{default})" : ''), 311 group => ($attribs{'group'} ? $attribs{'group'} : 'default'), 312 attributes => \%attribs 313 }; 314 } 315 while ( $para = <$fh> ) { 316 last unless $para; 317 if ( $para =~ m/^=head1/ ) { 318 $para = undef; # Can't 'last' out of a do {} block. 319 last; 320 } 321 last if $para =~ m/^=item /; 322 } 323 } while ( $para ); 324 325 die "No valid specs in $self->{head1}" unless @specs; 326 327 close $fh; 328 return @specs, @rules; 329} 330 331# Sub: _parse_specs 332# Parse option specs and rules. The opt specs and rules are returned 333# by <_pod_to_specs()>. The following attributes are added to each opt spec: 334# (start code) 335# short => the option's short key (-A for --charset) 336# is_cumulative => true if the option is cumulative 337# is_negatable => true if the option is negatable 338# is_required => true if the option is required 339# type => the option's type, one of $self->{types} 340# got => true if the option was given explicitly on the cmd line 341# value => the option's value 342# (end code) 343# 344# Parameters: 345# @specs - Opt specs and rules from <_pod_to_specs()> 346sub _parse_specs { 347 my ( $self, @specs ) = @_; 348 my %disables; # special rule that requires deferred checking 349 350 foreach my $opt ( @specs ) { 351 if ( ref $opt ) { # It's an option spec, not a rule. 352 PTDEBUG && _d('Parsing opt spec:', 353 map { ($_, '=>', $opt->{$_}) } keys %$opt); 354 355 my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/; 356 if ( !$long ) { 357 # This shouldn't happen. 358 die "Cannot parse long option from spec $opt->{spec}"; 359 } 360 $opt->{long} = $long; 361 362 die "Duplicate long option --$long" if exists $self->{opts}->{$long}; 363 $self->{opts}->{$long} = $opt; 364 365 if ( length $long == 1 ) { 366 PTDEBUG && _d('Long opt', $long, 'looks like short opt'); 367 $self->{short_opts}->{$long} = $long; 368 } 369 370 if ( $short ) { 371 die "Duplicate short option -$short" 372 if exists $self->{short_opts}->{$short}; 373 $self->{short_opts}->{$short} = $long; 374 $opt->{short} = $short; 375 } 376 else { 377 $opt->{short} = undef; 378 } 379 380 $opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0; 381 $opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0; 382 $opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0; 383 $opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0; 384 385 $opt->{group} ||= 'default'; 386 $self->{groups}->{ $opt->{group} }->{$long} = 1; 387 388 $opt->{value} = undef; 389 $opt->{got} = 0; 390 391 my ( $type ) = $opt->{spec} =~ m/=(.)/; 392 $opt->{type} = $type; 393 PTDEBUG && _d($long, 'type:', $type); 394 395 # This check is no longer needed because we'll create a DSNParser 396 # object for ourself if DSN OPTIONS exists in the POD. 397 # if ( $type && $type eq 'd' && !$self->{dp} ) { 398 # die "$opt->{long} is type DSN (d) but no dp argument " 399 # . "was given when this OptionParser object was created"; 400 # } 401 402 # Option has a non-Getopt type: HhAadzm. Use Getopt type 's'. 403 $opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ ); 404 405 # Option has a default value if its desc says 'default' or 'default X'. 406 # These defaults from the POD may be overridden by later calls 407 # to set_defaults(). 408 if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) { 409 $self->{defaults}->{$long} = defined $def ? $def : 1; 410 PTDEBUG && _d($long, 'default:', $def); 411 } 412 413 # Handle special behavior for --config. 414 if ( $long eq 'config' ) { 415 $self->{defaults}->{$long} = join(',', $self->get_defaults_files()); 416 } 417 418 # Option disable another option if its desc says 'disable'. 419 if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) { 420 # Defer checking till later because of possible forward references. 421 $disables{$long} = $dis; 422 PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis); 423 } 424 425 # Save the option. 426 $self->{opts}->{$long} = $opt; 427 } 428 else { # It's an option rule, not a spec. 429 PTDEBUG && _d('Parsing rule:', $opt); 430 push @{$self->{rules}}, $opt; 431 my @participants = $self->_get_participants($opt); 432 my $rule_ok = 0; 433 434 if ( $opt =~ m/mutually exclusive|one and only one/ ) { 435 $rule_ok = 1; 436 push @{$self->{mutex}}, \@participants; 437 PTDEBUG && _d(@participants, 'are mutually exclusive'); 438 } 439 if ( $opt =~ m/at least one|one and only one/ ) { 440 $rule_ok = 1; 441 push @{$self->{atleast1}}, \@participants; 442 PTDEBUG && _d(@participants, 'require at least one'); 443 } 444 if ( $opt =~ m/default to/ ) { 445 $rule_ok = 1; 446 # Example: "DSN values in L<"--dest"> default to values 447 # from L<"--source">." 448 $self->{defaults_to}->{$participants[0]} = $participants[1]; 449 PTDEBUG && _d($participants[0], 'defaults to', $participants[1]); 450 } 451 if ( $opt =~ m/restricted to option groups/ ) { 452 $rule_ok = 1; 453 my ($groups) = $opt =~ m/groups ([\w\s\,]+)/; 454 my @groups = split(',', $groups); 455 %{$self->{allowed_groups}->{$participants[0]}} = map { 456 s/\s+//; 457 $_ => 1; 458 } @groups; 459 } 460 if( $opt =~ m/accepts additional command-line arguments/ ) { 461 # The full rule text should be: "This tool accepts additional 462 # command-line arguments. Refer to the synopsis and usage 463 # information for details." 464 $rule_ok = 1; 465 $self->{strict} = 0; 466 PTDEBUG && _d("Strict mode disabled by rule"); 467 } 468 469 die "Unrecognized option rule: $opt" unless $rule_ok; 470 } 471 } 472 473 # Check forward references in 'disables' rules. 474 foreach my $long ( keys %disables ) { 475 # _get_participants() will check that each opt exists. 476 my @participants = $self->_get_participants($disables{$long}); 477 $self->{disables}->{$long} = \@participants; 478 PTDEBUG && _d('Option', $long, 'disables', @participants); 479 } 480 481 return; 482} 483 484# Sub: _get_participants 485# Extract option names from a string. This is used to 486# find the "participants" of option rules (i.e. the options to 487# which a rule applies). 488# 489# Parameters: 490# $str - String containing option names like "Options L<"--[no]foo"> and 491# --bar are mutually exclusive." 492# 493# Returns: 494# Array of option names 495sub _get_participants { 496 my ( $self, $str ) = @_; 497 my @participants; 498 foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) { 499 die "Option --$long does not exist while processing rule $str" 500 unless exists $self->{opts}->{$long}; 501 push @participants, $long; 502 } 503 PTDEBUG && _d('Participants for', $str, ':', @participants); 504 return @participants; 505} 506 507# Sub: opts 508# 509# Returns: 510# A copy of the internal opts hash 511sub opts { 512 my ( $self ) = @_; 513 my %opts = %{$self->{opts}}; 514 return %opts; 515} 516 517# Sub: short_opts 518# 519# Returns: 520# A copy of the internal short_opts hash 521sub short_opts { 522 my ( $self ) = @_; 523 my %short_opts = %{$self->{short_opts}}; 524 return %short_opts; 525} 526 527# Sub: set_defaults 528# Set default values for options. 529sub set_defaults { 530 my ( $self, %defaults ) = @_; 531 $self->{defaults} = {}; 532 foreach my $long ( keys %defaults ) { 533 die "Cannot set default for nonexistent option $long" 534 unless exists $self->{opts}->{$long}; 535 $self->{defaults}->{$long} = $defaults{$long}; 536 PTDEBUG && _d('Default val for', $long, ':', $defaults{$long}); 537 } 538 return; 539} 540 541sub get_defaults { 542 my ( $self ) = @_; 543 return $self->{defaults}; 544} 545 546sub get_groups { 547 my ( $self ) = @_; 548 return $self->{groups}; 549} 550 551# Sub: _set_option 552# Getopt::Long calls this sub for each opt it finds on the 553# cmd line. We have to do this in order to know which opts 554# were "got" on the cmd line. 555sub _set_option { 556 my ( $self, $opt, $val ) = @_; 557 my $long = exists $self->{opts}->{$opt} ? $opt 558 : exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt} 559 : die "Getopt::Long gave a nonexistent option: $opt"; 560 # Reassign $opt. 561 $opt = $self->{opts}->{$long}; 562 if ( $opt->{is_cumulative} ) { 563 $opt->{value}++; 564 } 565 elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) { 566 # https://bugs.launchpad.net/percona-toolkit/+bug/1199589 567 my $next_opt = $1; 568 if ( exists $self->{opts}->{$next_opt} 569 || exists $self->{short_opts}->{$next_opt} ) { 570 $self->save_error("--$long requires a string value"); 571 return; 572 } 573 else { 574 # have to make value an array if it is 'repeatable' 575 if ($opt->{is_repeatable}) { 576 push @{$opt->{value}} , $val; 577 } 578 else { 579 $opt->{value} = $val; 580 } 581 } 582 } 583 else { 584 # have to make value an array if it is 'repeatable' 585 if ($opt->{is_repeatable}) { 586 push @{$opt->{value}} , $val; 587 } 588 else { 589 $opt->{value} = $val; 590 } 591 } 592 $opt->{got} = 1; 593 PTDEBUG && _d('Got option', $long, '=', $val); 594} 595 596# Sub: get_opts 597# Get command line options and enforce option rules. 598# Option values are saved internally in $self->{opts} and accessed 599# later by <get()>, <got()>, and <set()>. Call <get_specs()> 600# before calling this sub. 601sub get_opts { 602 my ( $self ) = @_; 603 604 # Reset opts. 605 foreach my $long ( keys %{$self->{opts}} ) { 606 $self->{opts}->{$long}->{got} = 0; 607 $self->{opts}->{$long}->{value} 608 = exists $self->{defaults}->{$long} ? $self->{defaults}->{$long} 609 : $self->{opts}->{$long}->{is_cumulative} ? 0 610 : undef; 611 } 612 $self->{got_opts} = 0; 613 614 # Reset errors. 615 $self->{errors} = []; 616 617 # --config is special-case; parse them manually and remove them from @ARGV 618 if ( @ARGV && $ARGV[0] =~/^--config=/ ) { 619 $ARGV[0] = substr($ARGV[0],9); 620 # Clean '" independently because we need to match start/end with the same char ' or " 621 $ARGV[0] =~ s/^'(.*)'$/$1/; 622 $ARGV[0] =~ s/^"(.*)"$/$1/; 623 $self->_set_option('config', shift @ARGV); 624 } 625 if ( @ARGV && $ARGV[0] eq "--config" ) { 626 shift @ARGV; 627 $self->_set_option('config', shift @ARGV); 628 } 629 if ( $self->has('config') ) { 630 my @extra_args; 631 foreach my $filename ( split(',', $self->get('config')) ) { 632 # Try to open the file. If it was set explicitly, it's an error if it 633 # can't be opened, but the built-in defaults are to be ignored if they 634 # can't be opened. 635 eval { 636 push @extra_args, $self->_read_config_file($filename); 637 }; 638 if ( $EVAL_ERROR ) { 639 if ( $self->got('config') ) { 640 die $EVAL_ERROR; 641 } 642 elsif ( PTDEBUG ) { 643 _d($EVAL_ERROR); 644 } 645 } 646 } 647 unshift @ARGV, @extra_args; 648 } 649 650 Getopt::Long::Configure('no_ignore_case', 'bundling'); 651 GetOptions( 652 # Make Getopt::Long specs for each option with custom handler subs. 653 map { $_->{spec} => sub { $self->_set_option(@_); } } 654 grep { $_->{long} ne 'config' } # --config is handled specially above. 655 values %{$self->{opts}} 656 ) or $self->save_error('Error parsing options'); 657 658 if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) { 659 if ( $self->{version} ) { 660 print $self->{version}, "\n"; 661 exit 0; 662 } 663 else { 664 print "Error parsing version. See the VERSION section of the tool's documentation.\n"; 665 exit 1; 666 } 667 } 668 669 if ( @ARGV && $self->{strict} ) { 670 $self->save_error("Unrecognized command-line options @ARGV"); 671 } 672 673 # Check mutex options. 674 foreach my $mutex ( @{$self->{mutex}} ) { 675 my @set = grep { $self->{opts}->{$_}->{got} } @$mutex; 676 if ( @set > 1 ) { 677 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 678 @{$mutex}[ 0 .. scalar(@$mutex) - 2] ) 679 . ' and --'.$self->{opts}->{$mutex->[-1]}->{long} 680 . ' are mutually exclusive.'; 681 $self->save_error($err); 682 } 683 } 684 685 foreach my $required ( @{$self->{atleast1}} ) { 686 my @set = grep { $self->{opts}->{$_}->{got} } @$required; 687 if ( @set == 0 ) { 688 my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" } 689 @{$required}[ 0 .. scalar(@$required) - 2] ) 690 .' or --'.$self->{opts}->{$required->[-1]}->{long}; 691 $self->save_error("Specify at least one of $err"); 692 } 693 } 694 695 $self->_check_opts( keys %{$self->{opts}} ); 696 $self->{got_opts} = 1; 697 return; 698} 699 700# Sub: _check_opts 701# Check options against rules and group restrictions. 702# 703# Parameters: 704# @long - Array of option names 705sub _check_opts { 706 my ( $self, @long ) = @_; 707 my $long_last = scalar @long; 708 while ( @long ) { 709 foreach my $i ( 0..$#long ) { 710 my $long = $long[$i]; 711 next unless $long; 712 my $opt = $self->{opts}->{$long}; 713 if ( $opt->{got} ) { 714 # Rule: opt disables other opts. 715 if ( exists $self->{disables}->{$long} ) { 716 my @disable_opts = @{$self->{disables}->{$long}}; 717 map { $self->{opts}->{$_}->{value} = undef; } @disable_opts; 718 PTDEBUG && _d('Unset options', @disable_opts, 719 'because', $long,'disables them'); 720 } 721 722 # Group restrictions. 723 if ( exists $self->{allowed_groups}->{$long} ) { 724 # This option is only allowed with other options from 725 # certain groups. Check that no options from restricted 726 # groups were gotten. 727 728 my @restricted_groups = grep { 729 !exists $self->{allowed_groups}->{$long}->{$_} 730 } keys %{$self->{groups}}; 731 732 my @restricted_opts; 733 foreach my $restricted_group ( @restricted_groups ) { 734 RESTRICTED_OPT: 735 foreach my $restricted_opt ( 736 keys %{$self->{groups}->{$restricted_group}} ) 737 { 738 next RESTRICTED_OPT if $restricted_opt eq $long; 739 push @restricted_opts, $restricted_opt 740 if $self->{opts}->{$restricted_opt}->{got}; 741 } 742 } 743 744 if ( @restricted_opts ) { 745 my $err; 746 if ( @restricted_opts == 1 ) { 747 $err = "--$restricted_opts[0]"; 748 } 749 else { 750 $err = join(', ', 751 map { "--$self->{opts}->{$_}->{long}" } 752 grep { $_ } 753 @restricted_opts[0..scalar(@restricted_opts) - 2] 754 ) 755 . ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long}; 756 } 757 $self->save_error("--$long is not allowed with $err"); 758 } 759 } 760 761 } 762 elsif ( $opt->{is_required} ) { 763 $self->save_error("Required option --$long must be specified"); 764 } 765 766 $self->_validate_type($opt); 767 if ( $opt->{parsed} ) { 768 delete $long[$i]; 769 } 770 else { 771 PTDEBUG && _d('Temporarily failed to parse', $long); 772 } 773 } 774 775 die "Failed to parse options, possibly due to circular dependencies" 776 if @long == $long_last; 777 $long_last = @long; 778 } 779 780 return; 781} 782 783# Sub: _validate_type 784# Validate special option types like sizes and DSNs. 785# 786# Parameters: 787# $opt - Long option name to validate 788sub _validate_type { 789 my ( $self, $opt ) = @_; 790 return unless $opt; 791 792 if ( !$opt->{type} ) { 793 # Magic opts like --help and --version. 794 $opt->{parsed} = 1; 795 return; 796 } 797 798 my $val = $opt->{value}; 799 800 if ( $val && $opt->{type} eq 'm' ) { # type time 801 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value'); 802 my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/; 803 # The suffix defaults to 's' unless otherwise specified. 804 if ( !$suffix ) { 805 my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/; 806 $suffix = $s || 's'; 807 PTDEBUG && _d('No suffix given; using', $suffix, 'for', 808 $opt->{long}, '(value:', $val, ')'); 809 } 810 if ( $suffix =~ m/[smhd]/ ) { 811 $val = $suffix eq 's' ? $num # Seconds 812 : $suffix eq 'm' ? $num * 60 # Minutes 813 : $suffix eq 'h' ? $num * 3600 # Hours 814 : $num * 86400; # Days 815 $opt->{value} = ($prefix || '') . $val; 816 PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val); 817 } 818 else { 819 $self->save_error("Invalid time suffix for --$opt->{long}"); 820 } 821 } 822 elsif ( $val && $opt->{type} eq 'd' ) { # type DSN 823 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN'); 824 # DSN vals for this opt may come from 3 places, in order of precedence: 825 # the opt itself, the defaults to/copies from opt (prev), or 826 # --host, --port, etc. (defaults). 827 my $prev = {}; 828 my $from_key = $self->{defaults_to}->{ $opt->{long} }; 829 if ( $from_key ) { 830 PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN'); 831 if ( $self->{opts}->{$from_key}->{parsed} ) { 832 $prev = $self->{opts}->{$from_key}->{value}; 833 } 834 else { 835 PTDEBUG && _d('Cannot parse', $opt->{long}, 'until', 836 $from_key, 'parsed'); 837 return; 838 } 839 } 840 my $defaults = $self->{DSNParser}->parse_options($self); 841 if (!$opt->{attributes}->{repeatable}) { 842 $opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults); 843 } else { 844 my $values = []; 845 for my $dsn_string (@$val) { 846 push @$values, $self->{DSNParser}->parse($dsn_string, $prev, $defaults); 847 } 848 $opt->{value} = $values; 849 } 850 } 851 elsif ( $val && $opt->{type} eq 'z' ) { # type size 852 PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value'); 853 $self->_parse_size($opt, $val); 854 } 855 elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) { 856 $opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) }; 857 } 858 elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) { 859 $opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ]; 860 } 861 else { 862 PTDEBUG && _d('Nothing to validate for option', 863 $opt->{long}, 'type', $opt->{type}, 'value', $val); 864 } 865 866 $opt->{parsed} = 1; 867 return; 868} 869 870# Sub: get 871# Get an option's value. The option can be either a 872# short or long name (e.g. -A or --charset). 873# 874# Parameters: 875# $opt - Option name, long (--charset) or short (-A) 876# 877# Returns: 878# The option's value 879sub get { 880 my ( $self, $opt ) = @_; 881 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 882 die "Option $opt does not exist" 883 unless $long && exists $self->{opts}->{$long}; 884 return $self->{opts}->{$long}->{value}; 885} 886 887# Sub: got 888# Test if an option was explicitly given on the command line. 889# 890# Parameters: 891# $opt - Option name, long (--charset) or short (-A) 892# 893# Returns: 894# Bool 895sub got { 896 my ( $self, $opt ) = @_; 897 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 898 die "Option $opt does not exist" 899 unless $long && exists $self->{opts}->{$long}; 900 return $self->{opts}->{$long}->{got}; 901} 902 903# Sub: has 904# Test if an option exists (i.e. is specified in the tool's POD). 905# 906# Parameters: 907# $opt - Option name, long (--charset) or short (-A) 908# 909# Returns: 910# Bool 911sub has { 912 my ( $self, $opt ) = @_; 913 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 914 return defined $long ? exists $self->{opts}->{$long} : 0; 915} 916 917# Sub: set 918# Set an option's value. No type checking is done so be careful to 919# not set, for example, an integer option with a DSN. 920# 921# Parameters: 922# $opt - Option name, long (--charset) or short (-A) 923# $val - Option's new value 924sub set { 925 my ( $self, $opt, $val ) = @_; 926 my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt); 927 die "Option $opt does not exist" 928 unless $long && exists $self->{opts}->{$long}; 929 $self->{opts}->{$long}->{value} = $val; 930 return; 931} 932 933# Sub: save_error 934# Save an error message to be reported later by <usage_or_errors()>. 935# 936# Parameters: 937# $error - Error message 938sub save_error { 939 my ( $self, $error ) = @_; 940 push @{$self->{errors}}, $error; 941 return; 942} 943 944# Sub: errors 945# Used for testing. 946sub errors { 947 my ( $self ) = @_; 948 return $self->{errors}; 949} 950 951sub usage { 952 my ( $self ) = @_; 953 warn "No usage string is set" unless $self->{usage}; # XXX 954 return "Usage: " . ($self->{usage} || '') . "\n"; 955} 956 957sub descr { 958 my ( $self ) = @_; 959 warn "No description string is set" unless $self->{description}; # XXX 960 my $descr = ($self->{description} || $self->{program_name} || '') 961 . " For more details, please use the --help option, " 962 . "or try 'perldoc $PROGRAM_NAME' " 963 . "for complete documentation."; 964 # DONT_BREAK_LINES is set in OptionParser.t so the output can 965 # be tested reliably. 966 $descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g) 967 unless $ENV{DONT_BREAK_LINES}; 968 $descr =~ s/ +$//mg; 969 return $descr; 970} 971 972sub usage_or_errors { 973 my ( $self, $file, $return ) = @_; 974 $file ||= $self->{file} || __FILE__; 975 976 # First make sure we have a description and usage, else print_usage() 977 # and print_errors() will die. 978 if ( !$self->{description} || !$self->{usage} ) { 979 PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file); 980 my %synop = $self->_parse_synopsis($file); 981 $self->{description} ||= $synop{description}; 982 $self->{usage} ||= $synop{usage}; 983 PTDEBUG && _d("Description:", $self->{description}, 984 "\nUsage:", $self->{usage}); 985 } 986 987 if ( $self->{opts}->{help}->{got} ) { 988 print $self->print_usage() or die "Cannot print usage: $OS_ERROR"; 989 exit 0 unless $return; 990 } 991 elsif ( scalar @{$self->{errors}} ) { 992 print $self->print_errors() or die "Cannot print errors: $OS_ERROR"; 993 exit 1 unless $return; 994 } 995 996 return; 997} 998 999# Explains what errors were found while processing command-line arguments and 1000# gives a brief overview so you can get more information. 1001sub print_errors { 1002 my ( $self ) = @_; 1003 my $usage = $self->usage() . "\n"; 1004 if ( (my @errors = @{$self->{errors}}) ) { 1005 $usage .= join("\n * ", 'Errors in command-line arguments:', @errors) 1006 . "\n"; 1007 } 1008 return $usage . "\n" . $self->descr(); 1009} 1010 1011# Prints out command-line help. The format is like this: 1012# --foo=s -F Description of --foo 1013# --bars -B Description of --bar 1014# --longopt Description of --longopt 1015# Note that the short options are aligned along the right edge of their longest 1016# long option, but long options that don't have a short option are allowed to 1017# protrude past that. 1018sub print_usage { 1019 my ( $self ) = @_; 1020 die "Run get_opts() before print_usage()" unless $self->{got_opts}; 1021 my @opts = values %{$self->{opts}}; 1022 1023 # Find how wide the widest long option is. 1024 my $maxl = max( 1025 map { 1026 length($_->{long}) # option long name 1027 + ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable 1028 + ($_->{type} ? 2 : 0) # "=x" where x is the opt type 1029 } 1030 @opts); 1031 1032 # Find how wide the widest option with a short option is. 1033 my $maxs = max(0, 1034 map { 1035 length($_) 1036 + ($self->{opts}->{$_}->{is_negatable} ? 4 : 0) 1037 + ($self->{opts}->{$_}->{type} ? 2 : 0) 1038 } 1039 values %{$self->{short_opts}}); 1040 1041 # Find how wide the 'left column' (long + short opts) is, and therefore how 1042 # much space to give options and how much to give descriptions. 1043 my $lcol = max($maxl, ($maxs + 3)); 1044 my $rcol = 80 - $lcol - 6; 1045 my $rpad = ' ' x ( 80 - $rcol ); 1046 1047 # Adjust the width of the options that have long and short both. 1048 $maxs = max($lcol - 3, $maxs); 1049 1050 # Format and return the options. 1051 my $usage = $self->descr() . "\n" . $self->usage(); 1052 1053 # Sort groups alphabetically but make 'default' first. 1054 my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}}; 1055 push @groups, 'default'; 1056 1057 foreach my $group ( reverse @groups ) { 1058 $usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n"; 1059 foreach my $opt ( 1060 sort { $a->{long} cmp $b->{long} } 1061 grep { $_->{group} eq $group } 1062 @opts ) 1063 { 1064 my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long}; 1065 my $short = $opt->{short}; 1066 my $desc = $opt->{desc}; 1067 1068 # Append option type to long option name. 1069 # http://code.google.com/p/maatkit/issues/detail?id=1177 1070 $long .= $opt->{type} ? "=$opt->{type}" : ""; 1071 1072 # Expand suffix help for time options. 1073 if ( $opt->{type} && $opt->{type} eq 'm' ) { 1074 my ($s) = $desc =~ m/\(suffix (.)\)/; 1075 $s ||= 's'; 1076 $desc =~ s/\s+\(suffix .\)//; 1077 $desc .= ". Optional suffix s=seconds, m=minutes, h=hours, " 1078 . "d=days; if no suffix, $s is used."; 1079 } 1080 # Wrap long descriptions 1081 $desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g); 1082 $desc =~ s/ +$//mg; 1083 if ( $short ) { 1084 $usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc); 1085 } 1086 else { 1087 $usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc); 1088 } 1089 } 1090 } 1091 1092 $usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n"; 1093 1094 if ( (my @rules = @{$self->{rules}}) ) { 1095 $usage .= "\nRules:\n\n"; 1096 $usage .= join("\n", map { " $_" } @rules) . "\n"; 1097 } 1098 if ( $self->{DSNParser} ) { 1099 $usage .= "\n" . $self->{DSNParser}->usage(); 1100 } 1101 $usage .= "\nOptions and values after processing arguments:\n\n"; 1102 foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) { 1103 my $val = $opt->{value}; 1104 my $type = $opt->{type} || ''; 1105 my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/; 1106 $val = $bool ? ( $val ? 'TRUE' : 'FALSE' ) 1107 : !defined $val ? '(No value)' 1108 : $type eq 'd' ? $self->{DSNParser}->as_string($val) 1109 : $type =~ m/H|h/ ? join(',', sort keys %$val) 1110 : $type =~ m/A|a/ ? join(',', @$val) 1111 : $val; 1112 $usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val); 1113 } 1114 return $usage; 1115} 1116 1117# Tries to prompt and read the answer without echoing the answer to the 1118# terminal. This isn't really related to this package, but it's too handy not 1119# to put here. OK, it's related, it gets config information from the user. 1120sub prompt_noecho { 1121 shift @_ if ref $_[0] eq __PACKAGE__; 1122 my ( $prompt ) = @_; 1123 local $OUTPUT_AUTOFLUSH = 1; 1124 print STDERR $prompt 1125 or die "Cannot print: $OS_ERROR"; 1126 my $response; 1127 eval { 1128 require Term::ReadKey; 1129 Term::ReadKey::ReadMode('noecho'); 1130 chomp($response = <STDIN>); 1131 Term::ReadKey::ReadMode('normal'); 1132 print "\n" 1133 or die "Cannot print: $OS_ERROR"; 1134 }; 1135 if ( $EVAL_ERROR ) { 1136 die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR"; 1137 } 1138 return $response; 1139} 1140 1141# Reads a configuration file and returns it as a list. Inspired by 1142# Config::Tiny. 1143sub _read_config_file { 1144 my ( $self, $filename ) = @_; 1145 open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n"; 1146 my @args; 1147 my $prefix = '--'; 1148 my $parse = 1; 1149 1150 LINE: 1151 while ( my $line = <$fh> ) { 1152 chomp $line; 1153 # Skip comments and empty lines 1154 next LINE if $line =~ m/^\s*(?:\#|\;|$)/; 1155 # Remove inline comments 1156 $line =~ s/\s+#.*$//g; 1157 # Remove whitespace 1158 $line =~ s/^\s+|\s+$//g; 1159 # Watch for the beginning of the literal values (not to be interpreted as 1160 # options) 1161 if ( $line eq '--' ) { 1162 $prefix = ''; 1163 $parse = 0; 1164 next LINE; 1165 } 1166 1167 # Silently ignore option [no]-version-check if it is unsupported and it comes from a config file 1168 # TODO: Ideally , this should be generalized for all unsupported options that come from global files 1169 if ( $parse 1170 && !$self->has('version-check') 1171 && $line =~ /version-check/ 1172 ) { 1173 next LINE; 1174 } 1175 1176 if ( $parse 1177 && (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/) 1178 ) { 1179 push @args, grep { defined $_ } ("$prefix$opt", $arg); 1180 } 1181 elsif ( $line =~ m/./ ) { 1182 push @args, $line; 1183 } 1184 else { 1185 die "Syntax error in file $filename at line $INPUT_LINE_NUMBER"; 1186 } 1187 } 1188 close $fh; 1189 return @args; 1190} 1191 1192# Sub: read_para_after 1193# Read the POD paragraph after a magical regex. This is used, 1194# for exmaple, to get default CREATE TABLE from the POD. We write something 1195# like: 1196# (start code) 1197# This is the default MAGIC_foo_table: 1198# 1199# CREATE TABLE `foo` (i INT) 1200# 1201# Blah blah... 1202# (end code) 1203# Then to get that CREATE TABLE, you pass "MAGIC_foo_table" as the 1204# magical regex. 1205# 1206# Parameters: 1207# $file - File to read 1208# $regex - Regex to find something magical before the desired POD paragraph 1209# 1210# Returns: 1211# POD paragraph after magical regex 1212sub read_para_after { 1213 my ( $self, $file, $regex ) = @_; 1214 open my $fh, "<", $file or die "Can't open $file: $OS_ERROR"; 1215 local $INPUT_RECORD_SEPARATOR = ''; 1216 my $para; 1217 while ( $para = <$fh> ) { 1218 next unless $para =~ m/^=pod$/m; 1219 last; 1220 } 1221 while ( $para = <$fh> ) { 1222 next unless $para =~ m/$regex/; 1223 last; 1224 } 1225 $para = <$fh>; 1226 chomp($para); 1227 close $fh or die "Can't close $file: $OS_ERROR"; 1228 return $para; 1229} 1230 1231# Returns a lightweight clone of ourself. Currently, only the basic 1232# opts are copied. This is used for stuff like "final opts" in 1233# mk-table-checksum. 1234sub clone { 1235 my ( $self ) = @_; 1236 1237 # Deep-copy contents of hashrefs; do not just copy the refs. 1238 my %clone = map { 1239 my $hashref = $self->{$_}; 1240 my $val_copy = {}; 1241 foreach my $key ( keys %$hashref ) { 1242 my $ref = ref $hashref->{$key}; 1243 $val_copy->{$key} = !$ref ? $hashref->{$key} 1244 : $ref eq 'HASH' ? { %{$hashref->{$key}} } 1245 : $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ] 1246 : $hashref->{$key}; 1247 } 1248 $_ => $val_copy; 1249 } qw(opts short_opts defaults); 1250 1251 # Re-assign scalar values. 1252 foreach my $scalar ( qw(got_opts) ) { 1253 $clone{$scalar} = $self->{$scalar}; 1254 } 1255 1256 return bless \%clone; 1257} 1258 1259sub _parse_size { 1260 my ( $self, $opt, $val ) = @_; 1261 1262 # Special case used by mk-find to do things like --datasize null. 1263 if ( lc($val || '') eq 'null' ) { 1264 PTDEBUG && _d('NULL size for', $opt->{long}); 1265 $opt->{value} = 'null'; 1266 return; 1267 } 1268 1269 my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824); 1270 my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/; 1271 if ( defined $num ) { 1272 if ( $factor ) { 1273 $num *= $factor_for{$factor}; 1274 PTDEBUG && _d('Setting option', $opt->{y}, 1275 'to num', $num, '* factor', $factor); 1276 } 1277 $opt->{value} = ($pre || '') . $num; 1278 } 1279 else { 1280 $self->save_error("Invalid size for --$opt->{long}: $val"); 1281 } 1282 return; 1283} 1284 1285# Parse the option's attributes and return a GetOpt type. 1286# E.g. "foo type:int" == "foo=i"; "[no]bar" == "bar!", etc. 1287sub _parse_attribs { 1288 my ( $self, $option, $attribs ) = @_; 1289 my $types = $self->{types}; 1290 return $option 1291 . ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' ) 1292 . ($attribs->{'negatable'} ? '!' : '' ) 1293 . ($attribs->{'cumulative'} ? '+' : '' ) 1294 . ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' ); 1295} 1296 1297sub _parse_synopsis { 1298 my ( $self, $file ) = @_; 1299 $file ||= $self->{file} || __FILE__; 1300 PTDEBUG && _d("Parsing SYNOPSIS in", $file); 1301 1302 # Slurp the file. 1303 local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs 1304 open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; 1305 my $para; 1306 1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/; 1307 die "$file does not contain a SYNOPSIS section" unless $para; 1308 my @synop; 1309 for ( 1..2 ) { # 1 for the usage, 2 for the description 1310 my $para = <$fh>; 1311 push @synop, $para; 1312 } 1313 close $fh; 1314 PTDEBUG && _d("Raw SYNOPSIS text:", @synop); 1315 my ($usage, $desc) = @synop; 1316 die "The SYNOPSIS section in $file is not formatted properly" 1317 unless $usage && $desc; 1318 1319 # Strip "Usage:" from the usage string. 1320 $usage =~ s/^\s*Usage:\s+(.+)/$1/; 1321 chomp $usage; 1322 1323 # Make the description one long string without newlines. 1324 $desc =~ s/\n/ /g; 1325 $desc =~ s/\s{2,}/ /g; 1326 $desc =~ s/\. ([A-Z][a-z])/. $1/g; 1327 $desc =~ s/\s+$//; 1328 1329 return ( 1330 description => $desc, 1331 usage => $usage, 1332 ); 1333}; 1334 1335sub set_vars { 1336 my ($self, $file) = @_; 1337 $file ||= $self->{file} || __FILE__; 1338 1339 my %user_vars; 1340 my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef; 1341 if ( $user_vars ) { 1342 foreach my $var_val ( @$user_vars ) { 1343 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1344 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1345 $user_vars{$var} = { 1346 val => $val, 1347 default => 0, 1348 }; 1349 } 1350 } 1351 1352 my %default_vars; 1353 my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/); 1354 if ( $default_vars ) { 1355 %default_vars = map { 1356 my $var_val = $_; 1357 my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/; 1358 die "Invalid --set-vars value: $var_val\n" unless $var && defined $val; 1359 $var => { 1360 val => $val, 1361 default => 1, 1362 }; 1363 } split("\n", $default_vars); 1364 } 1365 1366 my %vars = ( 1367 %default_vars, # first the tool's defaults 1368 %user_vars, # then the user's which overwrite the defaults 1369 ); 1370 PTDEBUG && _d('--set-vars:', Dumper(\%vars)); 1371 return \%vars; 1372} 1373 1374sub _d { 1375 my ($package, undef, $line) = caller 0; 1376 @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; } 1377 map { defined $_ ? $_ : 'undef' } 1378 @_; 1379 print STDERR "# $package:$line $PID ", join(' ', @_), "\n"; 1380} 1381 1382# This is debug code I want to run for all tools, and this is a module I 1383# certainly include in all tools, but otherwise there's no real reason to put 1384# it here. 1385if ( PTDEBUG ) { 1386 print STDERR '# ', $^X, ' ', $], "\n"; 1387 if ( my $uname = `uname -a` ) { 1388 $uname =~ s/\s+/ /g; 1389 print STDERR "# $uname\n"; 1390 } 1391 print STDERR '# Arguments: ', 1392 join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n"; 1393} 1394 13951; 1396} 1397# ########################################################################### 1398# End OptionParser package 1399# ########################################################################### 1400