local-lib5/lib/perl5/Getopt/Long/Descriptive.pm

   1 package Getopt::Long::Descriptive;
   2
   3 use strict;
   4 use Getopt::Long 2.33;
   5 use List::Util qw(first);
   6 use Carp qw(carp croak);
   7 use Params::Validate qw(:all);
   8 use File::Basename ();
   9
  10 use Getopt::Long::Descriptive::Usage;
  11
  12 =head1 NAME
  13
  14 Getopt::Long::Descriptive - Getopt::Long with usage text
  15
  16 =head1 VERSION
  17
  18 Version 0.082
  19
  20 =cut
  21
  22 our $VERSION = '0.082';
  23
  24 =head1 DESCRIPTION
  25
  26 Convenient wrapper for Getopt::Long and program usage output
  27
  28 =head1 SYNOPSIS
  29
  30   use Getopt::Long::Descriptive;
  31   my ($opts, $usage) = describe_options($format, @opts, \%arg);
  32
  33 =head1 FORMAT
  34
  35   $format = "usage: myprog %o myarg...";
  36
  37 C<%o> will be replaced with a list of the short options, as well as the text
  38 "[long options...]" if any have been defined.
  39
  40 C<%c> will be replaced with what Getopt::Long::Descriptive
  41 thinks is the program name (see L</prog_name>).  You can
  42 override this guess by calling C<< prog_name($string) >>
  43 yourself.
  44
  45 Because of this, any literal C<%> symbols will need to be written as C<%%>.
  46
  47 =head1 OPTIONS
  48
  49 Option specifications are the same as in Getopt::Long.  You should pass in an
  50 array of arrayrefs whose first elements are option specs and whose second
  51 elements are descriptions.
  52
  53   my @opts = (
  54     [ "verbose|V" => "be noisy"       ],
  55     [ "logfile=s" => "file to log to" ],
  56   );
  57
  58 Option specifications may have a third hashref argument.  If
  59 present, this configures extra restrictions on the value or
  60 presence of that option.
  61
  62 You may cause a blank line to be printed by passing an empty
  63 arrayref.  Likewise, a plain descriptive line will be
  64 printed if you pass an arrayref with a single element:
  65
  66   @opts = (
  67     $option,
  68     [],
  69     [ 'other options:' ],
  70     $other_option,
  71   );
  72
  73 =head2 Option Constraints
  74
  75 =head3 implies
  76
  77   implies => 'bar'
  78
  79   implies => [qw(foo bar)]
  80
  81   implies => { foo => 1, bar => 2 }
  82
  83 =head3 required
  84
  85   required => 1
  86
  87 =head3 hidden
  88
  89   hidden => 1
  90
  91 This option will not show up in the usage text.
  92
  93 You can achieve this same behavior by using the string C<<
  94 hidden >> for the option's description.
  95
  96 =head3 one_of
  97
  98   one_of => \@option_specs
  99
 100 Useful for a group of options that are related.  Each option
 101 spec is added to the list for normal parsing and validation.
 102
 103 Your option name will end up with a value of the name of the
 104 option that was chosen.  For example, given the following spec:
 105
 106   [ "mode" => hidden => { one_of => [
 107     [ "get|g"  => "get the value" ],
 108     [ "set|s"  => "set the value" ],
 109     [ "delete" => "delete it" ],
 110   ] } ],
 111
 112 No usage text for 'mode' will be displayed, though
 113 get/set/delete will all have descriptions.
 114
 115 If more than one of get/set/delete (or their short versions)
 116 are given, an error will be thrown.
 117
 118 If C<@ARGV> is C<--get>, a dump of the resultant option
 119 hashref would look like this:
 120
 121   { get  => 1,
 122     mode => 'get' }
 123
 124 NOTE: C<< get >> would not be set if C<< mode >> defaulted
 125 to 'get' and no arguments were passed in.
 126
 127 WARNING: Even though the option sub-specs for C<< one_of >>
 128 are meant to be 'first class' specs, some options don't make
 129 sense with them, e.g. C<< required >>.
 130
 131 As a further shorthand, you may specify C<< one_of >>
 132 options using this form:
 133
 134   [ mode => \@option_specs, \%constraints ]
 135
 136 =head3 Params::Validate
 137
 138 In addition, any constraint understood by Params::Validate may be used.
 139
 140 (Internally, all constraints are translated into Params::Validate options or
 141 callbacks.)
 142
 143 =head1 EXTRA ARGUMENTS
 144
 145 If the last parameter is a hashref, it contains extra arguments to modify the
 146 way C<describe_options> works.  Valid arguments are:
 147
 148   getopt_conf - an arrayref of strings, passed to Getopt::Long::Configure
 149
 150 =head1 EXPORTED FUNCTIONS
 151
 152 =head2 C<describe_options>
 153
 154 See SYNOPSIS; returns a hashref of option values and an object that represents
 155 the usage statement.  You should always import this routine, and not call it
 156 directly.  The ability to call C<Getopt::Long::Descriptive::describe_options>
 157 may go away in the future.
 158
 159 The usage object has several methods:
 160
 161 =over 4
 162
 163 =item * C<< $usage->text >> returns the usage string
 164
 165 =item * C<< $usage->warn >> prints usage to STDERR
 166
 167 =item * C<< $usage->die >> dies with the usage string
 168
 169 =back
 170
 171 For more information on the usage object, look at
 172 L<Getopt::Long::Descriptive::Usage|Getopt::Long::Descriptive::Usage>.
 173
 174 =head2 prog_name
 175
 176 This routine returns the basename of C<< $0 >>, grabbed at compile-time.
 177
 178 =head2 -types
 179
 180 Any of the Params::Validate type constants (C<SCALAR>, etc.) can be imported as
 181 well.  You can get all of them at once by importing C<-types>.
 182
 183 =head2 C<-all>
 184
 185 This gets you everything.
 186
 187 =head1 CONFIGURATION
 188
 189 =head2 C<$MungeOptions>
 190
 191 When C<$Getopt::Long::Descriptive::MungeOptions> is true, some munging is done
 192 to make option names more hash-key friendly:
 193
 194 =over 4
 195
 196 =item * All keys are lowercased
 197
 198 =item * C<-> is changed to C<_>
 199
 200 =back
 201
 202 The default is a true value.
 203
 204 =head1 SEE ALSO
 205
 206 L<Getopt::Long>
 207 L<Params::Validate>
 208
 209 =cut
 210
 211 my $prog_name;
 212 sub prog_name { @_ ? ($prog_name = shift) : $prog_name }
 213
 214 BEGIN {
 215   # grab this before someone decides to change it
 216   prog_name(File::Basename::basename($0));
 217 }
 218
 219 use Sub::Exporter::Util ();
 220 use Sub::Exporter -setup => {
 221   exports => [
 222     describe_options => \'_build_describe_options',
 223     q(prog_name),
 224     @{ $Params::Validate::EXPORT_TAGS{types} }
 225   ],
 226   groups  => [
 227     default => [ qw(describe_options) ],
 228     types   => $Params::Validate::EXPORT_TAGS{types},
 229   ],
 230 };
 231
 232 my %CONSTRAINT = (
 233   implies  => \&_mk_implies,
 234   required => { optional => 0 },
 235   only_one => \&_mk_only_one,
 236 );
 237
 238 our $MungeOptions = 1;
 239
 240 sub _nohidden {
 241   return grep { ! $_->{constraint}->{hidden} } @_;
 242 }
 243
 244 sub _expand {
 245   return map { {(
 246     spec       => $_->[0] || '',
 247     desc       => @$_ > 1 ? $_->[1] : 'spacer',
 248     constraint => $_->[2] || {},
 249     name       => _munge((split /[:=|!+]/, $_->[0] || '')[0]),
 250   )} } @_;
 251 }
 252
 253 my %HIDDEN = (
 254   hidden => 1,
 255 );
 256
 257 my $SPEC_RE = qr{(?:[:=][\d\w\+]+[%@]?({\d*,\d*})?|[!+])$};
 258 sub _strip_assignment {
 259   my ($self, $str) = @_;
 260
 261   (my $copy = $str) =~ s{$SPEC_RE}{};
 262
 263   return $copy;
 264 }
 265
 266 # This is here only to deal with people who were calling this fully-qualified
 267 # without importing.  Sucks to them!  -- rjbs, 2009-08-21
 268 sub describe_options {
 269   my $sub = __PACKAGE__->_build_describe_options(describe_options => {} => {});
 270   $sub->(@_);
 271 }
 272
 273 sub usage_class { 'Getopt::Long::Descriptive::Usage' }
 274
 275 sub _build_describe_options {
 276   my ($class) = @_;
 277
 278   sub {
 279     my $format = shift;
 280     my $arg    = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};
 281     my @opts;
 282
 283     # special casing
 284     # wish we had real loop objects
 285     my %method_map;
 286     for my $opt (_expand(@_)) {
 287       $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer';
 288
 289       if (ref($opt->{desc}) eq 'ARRAY') {
 290         $opt->{constraint}->{one_of} = delete $opt->{desc};
 291         $opt->{desc} = 'hidden';
 292       }
 293       if ($HIDDEN{$opt->{desc}}) {
 294         $opt->{constraint}->{hidden}++;
 295       }
 296       if ($opt->{constraint}->{one_of}) {
 297         for my $one_opt (_expand(
 298           @{delete $opt->{constraint}->{one_of}}
 299         )) {
 300           $one_opt->{constraint}->{implies}
 301             ->{$opt->{name}} = $one_opt->{name};
 302           for my $wipe (qw(required default)) {
 303             if ($one_opt->{constraint}->{$wipe}) {
 304               carp "'$wipe' constraint does not make sense in sub-option";
 305               delete $one_opt->{constraint}->{$wipe};
 306             }
 307           }
 308           $one_opt->{constraint}->{one_of} = $opt->{name};
 309           push @opts, $one_opt;
 310         }
 311       }
 312       push @opts, $opt;
 313     }
 314
 315     my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
 316     if ($arg->{getopt}) {
 317       warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
 318     }
 319
 320     push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
 321
 322     # not entirely sure that all of this (until the Usage->new) shouldn't be
 323     # moved into Usage -- rjbs, 2009-08-19
 324     my @specs =
 325       map  { $_->{spec} }
 326       grep { $_->{desc} ne 'spacer' }
 327       _nohidden(@opts);
 328
 329     my $short = join q{},
 330       sort  { lc $a cmp lc $b or $a cmp $b }
 331       grep  { /^.$/ }
 332       map   { split /\|/ }
 333       map   { __PACKAGE__->_strip_assignment($_) }
 334       @specs;
 335
 336     my $long = grep /\b[^|]{2,}/, @specs;
 337
 338     my %replace = (
 339       "%" => "%",
 340       "c" => prog_name,
 341       "o" => join(q{ },
 342         ($short ? "[-$short]" : ()),
 343         ($long  ? "[long options...]" : ())
 344       ),
 345     );
 346
 347     (my $str = $format) =~ s/%(.)/$replace{$1}/ge;
 348     $str =~ s/\s{2,}/ /g;
 349
 350     my $usage = $class->usage_class->new({
 351       options     => [ _nohidden(@opts) ],
 352       leader_text => $str,
 353     });
 354
 355     Getopt::Long::Configure(@go_conf);
 356
 357     my %return;
 358     $usage->die unless GetOptions(\%return, grep { length } @specs);
 359
 360     for my $opt (keys %return) {
 361       my $newopt = _munge($opt);
 362       next if $newopt eq $opt;
 363       $return{$newopt} = delete $return{$opt};
 364     }
 365
 366     for my $copt (grep { $_->{constraint} } @opts) {
 367       delete $copt->{constraint}->{hidden};
 368       my $name = $copt->{name};
 369       my $new  = _validate_with(
 370         name   => $name,
 371         params => \%return,
 372         spec   => $copt->{constraint},
 373         opts   => \@opts,
 374         usage  => $usage,
 375       );
 376       next unless (defined($new) || exists($return{$name}));
 377       $return{$name} = $new;
 378     }
 379
 380     my $opt_obj = $class->_new_opt_obj({
 381       values => { %method_map, %return },
 382     });
 383
 384     return($opt_obj, $usage);
 385   }
 386 }
 387
 388 sub _munge {
 389   my ($opt) = @_;
 390   return $opt unless $MungeOptions;
 391   $opt = lc($opt);
 392   $opt =~ tr/-/_/;
 393   return $opt;
 394 }
 395
 396 sub _validate_with {
 397   my (%arg) = validate(@_, {
 398     name   => 1,
 399     params => 1,
 400     spec   => 1,
 401     opts   => 1,
 402     usage  => 1,
 403   });
 404   my $spec = $arg{spec};
 405   my %pvspec;
 406   for my $ct (keys %{$spec}) {
 407     if ($CONSTRAINT{$ct} and ref $CONSTRAINT{$ct} eq 'CODE') {
 408       $pvspec{callbacks} ||= {};
 409       $pvspec{callbacks} = {
 410         %{$pvspec{callbacks}},
 411         $CONSTRAINT{$ct}->(
 412           $arg{name},
 413           $spec->{$ct},
 414           $arg{params},
 415           $arg{opts},
 416         ),
 417       };
 418     } else {
 419       %pvspec = (
 420         %pvspec,
 421         $CONSTRAINT{$ct} ? %{$CONSTRAINT{$ct}} : ($ct => $spec->{$ct}),
 422       );
 423     }
 424   }
 425
 426   $pvspec{optional} = 1 unless exists $pvspec{optional};
 427
 428   # we need to implement 'default' by ourselves sometimes
 429   # because otherwise the implies won't be checked/executed
 430   # XXX this should be more generic -- we'll probably want
 431   # other callbacks to always run, too
 432   if (!defined($arg{params}{$arg{name}})
 433         && $pvspec{default}
 434           && $spec->{implies}) {
 435
 436     $arg{params}{$arg{name}} = delete $pvspec{default};
 437   }
 438
 439   my %p = eval {
 440     validate_with(
 441       params => [ %{$arg{params}} ],
 442       spec   => { $arg{name} => \%pvspec },
 443       allow_extra => 1,
 444     );
 445   };
 446
 447   if ($@) {
 448     if ($@ =~ /^Mandatory parameter '([^']+)' missing/) {
 449       my $missing = $1;
 450       $arg{usage}->die({
 451         pre_text => "Required option missing: $1\n",
 452       });
 453     }
 454
 455     die $@;
 456   }
 457
 458   return $p{$arg{name}};
 459 }
 460
 461 # scalar:   single option = true
 462 # arrayref: multiple options = true
 463 # hashref:  single/multiple options = given values
 464 sub _norm_imply {
 465   my ($what) = @_;
 466
 467   return { $what => 1 } unless my $ref = ref $what;
 468
 469   return $what                      if $ref eq 'HASH';
 470   return { map { $_ => 1 } @$what } if $ref eq 'ARRAY';
 471
 472   die "can't imply: $what";
 473 }
 474
 475 sub _mk_implies {
 476   my $name = shift;
 477   my $what = _norm_imply(shift);
 478   my $param = shift;
 479   my $opts  = shift;
 480
 481   for my $implied (keys %$what) {
 482     die("option specification for $name implies nonexistent option $implied\n")
 483       unless first { $_->{name} eq $implied } @$opts
 484   }
 485
 486   my $whatstr = join(q{, }, map { "$_=$what->{$_}" } keys %$what);
 487
 488   return "$name implies $whatstr" => sub {
 489     my ($pv_val) = shift;
 490
 491     # negatable options will be 0 here, which is ok.
 492     return 1 unless defined $pv_val;
 493
 494     while (my ($key, $val) = each %$what) {
 495       if (exists $param->{$key} and $param->{$key} ne $val) {
 496         die(
 497           "option specification for $name implies that $key should be "
 498           . "set to '$val', but it is '$param->{$key}' already\n"
 499         );
 500       }
 501       $param->{$key} = $val;
 502     }
 503
 504     return 1;
 505   };
 506 }
 507
 508 sub _mk_only_one {
 509   die "unimplemented";
 510 }
 511
 512 my $OPT_CLASS_COUNTER = 1;
 513
 514 sub _class_for_opt {
 515   my ($gld_class, $arg) = @_;
 516
 517   my $values = $arg->{values};
 518   my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values;
 519   Carp::confess "perverse option names given: @bad" if @bad;
 520
 521   my $class = "$gld_class\::__OPT__::" . $OPT_CLASS_COUNTER++;
 522
 523   {
 524     no strict 'refs';
 525     ${"$class\::VERSION"} = $gld_class->VERSION;
 526     for my $opt (keys %$values) {
 527       *{"$class\::$opt"} = sub { $_[0]->{ $opt } };
 528     }
 529   }
 530
 531   return $class;
 532 }
 533
 534 sub _new_opt_obj {
 535   my ($gld_class, $arg) = @_;
 536
 537   my $class = $gld_class->_class_for_opt($arg);
 538
 539   # This is stupid, but the traditional behavior was that if --foo was not
 540   # given, there is no $opt->{foo}; it started to show up when we "needed" all
 541   # the keys to generate a class, but was undef; this wasn't a problem, but
 542   # broke tests of things that were relying on not-exists like tests of %$opt
 543   # contents or MooseX::Getopt which wanted to use things as args for new --
 544   # undef would not pass an Int TC.  Easier to just do this. -- rjbs,
 545   # 2009-11-27
 546   my $obj = bless { %{ $arg->{values} } } => $class;
 547   delete $obj->{$_} for grep { ! defined $obj->{$_} } keys %$obj;
 548
 549   return $obj;
 550 }
 551
 552 =head1 CUSTOMIZING
 553
 554 Getopt::Long::Descriptive uses L<Sub::Exporter|Sub::Exporter> to build and
 555 export the C<describe_options> routine.  By writing a new class that extends
 556 Getopt::Long::Descriptive, the behavior of the constructed C<describe_options>
 557 routine can be changed.
 558
 559 The following methods can be overridden:
 560
 561 =head2 usage_class
 562
 563   my $class = Getopt::Long::Descriptive->usage_class;
 564
 565 This returns the class to be used for constructing a Usage object, and defaults
 566 to Getopt::Long::Descriptive::Usage.
 567
 568 =head1 AUTHOR
 569
 570 Hans Dieter Pearcey, C<< <hdp@cpan.org> >>
 571
 572 =head1 BUGS
 573
 574 Please report any bugs or feature requests to
 575 C<bug-getopt-long-descriptive@rt.cpan.org>, or through the web interface at
 576 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Long-Descriptive>.
 577 I will be notified, and then you'll automatically be notified of progress on
 578 your bug as I make changes.
 579
 580 =head1 COPYRIGHT & LICENSE
 581
 582 Copyright 2005 Hans Dieter Pearcey, all rights reserved.
 583
 584 This program is free software; you can redistribute it and/or modify it
 585 under the same terms as Perl itself.
 586
 587 =cut
 588
 589 1; # End of Getopt::Long::Descriptive