r47826 - in /branches/upstream/libgetopt-long-descriptive-perl/current: Changes META.yml Makefile.PL README lib/Getopt/Long/Descriptive.pm lib/Getopt/Long/Descriptive/Usage.pm t/descriptive.t

jawnsy-guest at users.alioth.debian.org jawnsy-guest at users.alioth.debian.org
Fri Nov 27 03:11:53 UTC 2009


Author: jawnsy-guest
Date: Fri Nov 27 03:11:48 2009
New Revision: 47826

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=47826
Log:
[svn-upgrade] Integrating new upstream version, libgetopt-long-descriptive-perl (0.079)

Modified:
    branches/upstream/libgetopt-long-descriptive-perl/current/Changes
    branches/upstream/libgetopt-long-descriptive-perl/current/META.yml
    branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL
    branches/upstream/libgetopt-long-descriptive-perl/current/README
    branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive.pm
    branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm
    branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/Changes?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/Changes (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/Changes Fri Nov 27 03:11:48 2009
@@ -1,4 +1,10 @@
 Revision history for Getopt-Long-Descriptive
+
+0.079   2009-11-26 Happy Thanksgiving!
+        improve the "opt as object" facility to have all opts as methods
+
+0.078   2009-08-21
+        refactoring to allow subclassing of Getopt::Long::Descriptive
 
 0.077   2009-08-21
         allow 'f' as an option name; had mistakenly required 2 characters

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/META.yml?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/META.yml (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/META.yml Fri Nov 27 03:11:48 2009
@@ -1,6 +1,6 @@
 --- #YAML:1.0
 name:               Getopt-Long-Descriptive
-version:            0.077
+version:            0.079
 abstract:           Getopt::Long with usage text
 author:
     - Hans Dieter Pearcey <hdp at cpan.org>
@@ -11,7 +11,6 @@
 build_requires:
     ExtUtils::MakeMaker:  0
 requires:
-    IO::Scalar:        0
     List::Util:        0
     Params::Validate:  0.74
     Sub::Exporter:     0

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL Fri Nov 27 03:11:48 2009
@@ -3,18 +3,17 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-   NAME                => 'Getopt::Long::Descriptive',
-    AUTHOR              => 'Hans Dieter Pearcey <hdp at cpan.org>',
-    VERSION_FROM        => 'lib/Getopt/Long/Descriptive.pm',
-    ABSTRACT_FROM       => 'lib/Getopt/Long/Descriptive.pm',
-    PL_FILES            => {},
-    PREREQ_PM => {
-        'Test::More' => 0,
-        'Params::Validate' => '0.74',
-        'List::Util' => 0,
-        'IO::Scalar' => 0,
-        'Sub::Exporter' => 0,
-    },
-    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
-    clean               => { FILES => 'Getopt-Long-Descriptive-*' },
+  NAME                => 'Getopt::Long::Descriptive',
+  AUTHOR              => 'Hans Dieter Pearcey <hdp at cpan.org>',
+  VERSION_FROM        => 'lib/Getopt/Long/Descriptive.pm',
+  ABSTRACT_FROM       => 'lib/Getopt/Long/Descriptive.pm',
+  PL_FILES            => {},
+  PREREQ_PM => {
+    'List::Util'       => 0,
+    'Params::Validate' => '0.74',
+    'Sub::Exporter'    => 0,
+    'Test::More'       => 0,
+  },
+  dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+  clean               => { FILES => 'Getopt-Long-Descriptive-*' },
 );

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/README?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/README (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/README Fri Nov 27 03:11:48 2009
@@ -2,7 +2,7 @@
 
 VERSION
 
-0.077
+0.079
 
 INSTALLATION
 

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive.pm?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive.pm (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive.pm Fri Nov 27 03:11:48 2009
@@ -15,11 +15,11 @@
 
 =head1 VERSION
 
-Version 0.077
+Version 0.079
 
 =cut
 
-our $VERSION = '0.077';
+our $VERSION = '0.079';
 
 =head1 DESCRIPTION
 
@@ -135,11 +135,10 @@
 
 =head3 Params::Validate
 
-In addition, any constraint understood by Params::Validate
-may be used.
-
-(Internally, all constraints are translated into
-Params::Validate options or callbacks.)
+In addition, any constraint understood by Params::Validate may be used.
+
+(Internally, all constraints are translated into Params::Validate options or
+callbacks.)
 
 =head1 EXTRA ARGUMENTS
 
@@ -152,10 +151,12 @@
 
 =head2 C<describe_options>
 
-See SYNOPSIS; returns a hashref of option values and an
-object that represents the usage statement.
-
-The usage statement has several methods:
+See SYNOPSIS; returns a hashref of option values and an object that represents
+the usage statement.  You should always import this routine, and not call it
+directly.  The ability to call C<Getopt::Long::Descriptive::describe_options>
+may go away in the future.
+
+The usage object has several methods:
 
 =over 4
 
@@ -167,18 +168,19 @@
 
 =back
 
-=head2 C<< prog_name >>
-
-A helper function that returns the basename of C<< $0 >>,
-grabbed at compile-time.
-
-=head2 C<:types>
-
-Any of the Params::Validate type constants (C<SCALAR>, etc.)
-can be imported as well.  You can get all of them at once by
-importing C<:types>.
-
-=head2 C<:all>
+For more information on the usage object, look at
+L<Getopt::Long::Descriptive::Usage|Getopt::Long::Descriptive::Usage>.
+
+=head2 prog_name
+
+This routine returns the basename of C<< $0 >>, grabbed at compile-time.
+
+=head2 -types
+
+Any of the Params::Validate type constants (C<SCALAR>, etc.) can be imported as
+well.  You can get all of them at once by importing C<-types>.
+
+=head2 C<-all>
 
 This gets you everything.
 
@@ -214,9 +216,11 @@
   prog_name(File::Basename::basename($0));
 }
 
+use Sub::Exporter::Util ();
 use Sub::Exporter -setup => {
   exports => [
-    qw(describe_options prog_name),
+    describe_options => \'_build_describe_options',
+    q(prog_name),
     @{ $Params::Validate::EXPORT_TAGS{types} }
   ],
   groups  => [
@@ -259,110 +263,126 @@
   return $copy;
 }
 
+# This is here only to deal with people who were calling this fully-qualified
+# without importing.  Sucks to them!  -- rjbs, 2009-08-21
 sub describe_options {
-  my $format = shift;
-  my $arg    = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};
-  my @opts;
-
-  # special casing
-  # wish we had real loop objects
-  for my $opt (_expand(@_)) {
-    if (ref($opt->{desc}) eq 'ARRAY') {
-      $opt->{constraint}->{one_of} = delete $opt->{desc};
-      $opt->{desc} = 'hidden';
-    }
-    if ($HIDDEN{$opt->{desc}}) {
-      $opt->{constraint}->{hidden}++;
-    }
-    if ($opt->{constraint}->{one_of}) {
-      for my $one_opt (_expand(
-        @{delete $opt->{constraint}->{one_of}}
-      )) {
-        $one_opt->{constraint}->{implies}
-          ->{$opt->{name}} = $one_opt->{name};
-        for my $wipe (qw(required default)) {
-          if ($one_opt->{constraint}->{$wipe}) {
-            carp "'$wipe' constraint does not make sense in sub-option";
-            delete $one_opt->{constraint}->{$wipe};
+  my $sub = __PACKAGE__->_build_describe_options(describe_options => {} => {});
+  $sub->();
+}
+
+sub usage_class { 'Getopt::Long::Descriptive::Usage' }
+
+sub _build_describe_options {
+  my ($class) = @_;
+
+  sub {
+    my $format = shift;
+    my $arg    = (ref $_[-1] and ref $_[-1] eq 'HASH') ? pop @_ : {};
+    my @opts;
+
+    # special casing
+    # wish we had real loop objects
+    my %method_map;
+    for my $opt (_expand(@_)) {
+      $method_map{ $opt->{name} } = undef unless $opt->{desc} eq 'spacer';
+ 
+      if (ref($opt->{desc}) eq 'ARRAY') {
+        $opt->{constraint}->{one_of} = delete $opt->{desc};
+        $opt->{desc} = 'hidden';
+      }
+      if ($HIDDEN{$opt->{desc}}) {
+        $opt->{constraint}->{hidden}++;
+      }
+      if ($opt->{constraint}->{one_of}) {
+        for my $one_opt (_expand(
+          @{delete $opt->{constraint}->{one_of}}
+        )) {
+          $one_opt->{constraint}->{implies}
+            ->{$opt->{name}} = $one_opt->{name};
+          for my $wipe (qw(required default)) {
+            if ($one_opt->{constraint}->{$wipe}) {
+              carp "'$wipe' constraint does not make sense in sub-option";
+              delete $one_opt->{constraint}->{$wipe};
+            }
           }
+          $one_opt->{constraint}->{one_of} = $opt->{name};
+          push @opts, $one_opt;
         }
-        $one_opt->{constraint}->{one_of} = $opt->{name};
-        push @opts, $one_opt;
       }
-    }
-    push @opts, $opt;
+      push @opts, $opt;
+    }
+    
+    my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
+    if ($arg->{getopt}) {
+      warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
+    }
+
+    push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
+
+    # not entirely sure that all of this (until the Usage->new) shouldn't be
+    # moved into Usage -- rjbs, 2009-08-19
+    my @specs =
+      map  { $_->{spec} }
+      grep { $_->{desc} ne 'spacer' }
+      _nohidden(@opts);
+
+    my $short = join q{},
+      sort  { lc $a cmp lc $b or $a cmp $b }
+      grep  { /^.$/ }
+      map   { split /\|/ }
+      map   { __PACKAGE__->_strip_assignment($_) }
+      @specs;
+    
+    my $long = grep /\b[^|]{2,}/, @specs;
+
+    my %replace = (
+      "%" => "%",
+      "c" => prog_name,
+      "o" => join(q{ },
+        ($short ? "[-$short]" : ()),
+        ($long  ? "[long options...]" : ())
+      ),
+    );
+
+    (my $str = $format) =~ s/%(.)/$replace{$1}/ge;
+    $str =~ s/\s{2,}/ /g;
+
+    my $usage = $class->usage_class->new({
+      options     => [ _nohidden(@opts) ],
+      leader_text => $str,
+    });
+
+    Getopt::Long::Configure(@go_conf);
+
+    my %return;
+    $usage->die unless GetOptions(\%return, grep { length } @specs);
+
+    for my $opt (keys %return) {
+      my $newopt = _munge($opt);
+      next if $newopt eq $opt;
+      $return{$newopt} = delete $return{$opt};
+    }
+
+    for my $copt (grep { $_->{constraint} } @opts) {
+      delete $copt->{constraint}->{hidden};
+      my $name = $copt->{name};
+      my $new  = _validate_with(
+        name   => $name,
+        params => \%return,
+        spec   => $copt->{constraint},
+        opts   => \@opts,
+        usage  => $usage,
+      );
+      next unless (defined($new) || exists($return{$name}));
+      $return{$name} = $new;
+    }
+
+    my $opt_obj = $class->_new_opt_obj({
+      values => { %method_map, %return },
+    });
+
+    return($opt_obj, $usage);
   }
-  
-  my @go_conf = @{ $arg->{getopt_conf} || $arg->{getopt} || [] };
-  if ($arg->{getopt}) {
-    warn "describe_options: 'getopt' is deprecated, please use 'getopt_conf' instead\n";
-  }
-
-  push @go_conf, "bundling" unless grep { /bundling/i } @go_conf;
-
-  # not entirely sure that all of this (until the Usage->new) shouldn't be
-  # moved into Usage -- rjbs, 2009-08-19
-  my @specs = map { $_->{spec} } grep {
-    $_->{desc} ne 'spacer'
-  } _nohidden(@opts);
-
-  my $short = join "", sort {
-    lc $a cmp lc $b 
-    or $a cmp $b
-  } map {
-    my $s = __PACKAGE__->_strip_assignment($_);
-    grep /^.$/, split /\|/, $s
-  } @specs;
-  
-  my $long = grep /\b[^|]{2,}/, @specs;
-
-  my %replace = (
-    "%" => "%",
-    "o" => (join(" ",
-                 ($short ? "[-$short]" : ()),
-                 ($long  ? "[long options...]" : ())
-               )),
-    "c" => prog_name,
-  );
-
-  (my $str = $format) =~ s/%(.)/$replace{$1}/ge;
-  $str =~ s/\s{2,}/ /g;
-
-  my $usage = Getopt::Long::Descriptive::Usage->new({
-    options     => [ _nohidden(@opts) ],
-    leader_text => $str,
-  });
-
-  Getopt::Long::Configure(@go_conf);
-
-  my %return;
-  $usage->die unless GetOptions(\%return, grep { length } @specs);
-
-  for my $opt (keys %return) {
-    my $newopt = _munge($opt);
-    next if $newopt eq $opt;
-    $return{$newopt} = delete $return{$opt};
-  }
-
-  for my $copt (grep { $_->{constraint} } @opts) {
-    delete $copt->{constraint}->{hidden};
-    my $name = $copt->{name};
-    my $new  = _validate_with(
-      name   => $name,
-      params => \%return,
-      spec   => $copt->{constraint},
-      opts   => \@opts,
-      usage  => $usage,
-    );
-    next unless (defined($new) || exists($return{$name}));
-    $return{$name} = $new;
-  }
-
-  my $opt_obj = Getopt::Long::Descriptive::OptObjFactory->new_opt_obj({
-    values => \%return,
-  });
-
-  return($opt_obj, $usage);
 }
 
 sub _munge {
@@ -489,38 +509,50 @@
   die "unimplemented";
 }
 
-{
-  # Clever line break to avoid indexing! -- rjbs, 2009-08-20
-  package
-    Getopt::Long::Descriptive::OptObjFactory;
-
-  my $VERSION = '0.077';
-
-  use Carp ();
-
-  my $i = 1;
-
-  sub new_opt_obj {
-    my ($inv_class, $arg) = @_;
-    
-    my %given = %{ $arg->{values} };
-
-    my @bad = grep { $_ !~ /^[a-z_]\w*/ } keys %given;
-    Carp::confess "perverse option names given: @bad" if @bad;
-
-    my $class = "$inv_class\::_::" . $i++;
-
-    {
-      no strict 'refs';
-      ${"$class\::VERSION"} = $inv_class->VERSION;
-      for my $opt (keys %given) {
-        *{"$class\::$opt"} = sub { $_[0]->{ $opt } };
-      }
-    }
-
-    bless \%given => $class;
+my $OPT_CLASS_COUNTER = 1;
+
+sub _class_for_opt {
+  my ($gld_class, $arg) = @_;
+
+  my $values = $arg->{values};
+  my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values;
+  Carp::confess "perverse option names given: @bad" if @bad;
+
+  my $class = "$gld_class\::__OPT__::" . $OPT_CLASS_COUNTER++;
+
+  {
+    no strict 'refs';
+    ${"$class\::VERSION"} = $gld_class->VERSION;
+    for my $opt (keys %$values) {
+      *{"$class\::$opt"} = sub { $_[0]->{ $opt } };
+    }
   }
-}
+
+  return $class;
+}
+
+sub _new_opt_obj {
+  my ($gld_class, $arg) = @_;
+  
+  my $class = $gld_class->_class_for_opt($arg);
+  bless { %{ $arg->{values} } } => $class;
+}
+
+=head1 CUSTOMIZING
+
+Getopt::Long::Descriptive uses L<Sub::Exporter|Sub::Exporter> to build and
+export the C<describe_options> routine.  By writing a new class that extends
+Getopt::Long::Descriptive, the behavior of the constructed C<describe_options>
+routine can be changed.
+
+The following methods can be overridden:
+
+=head2 usage_class
+
+  my $class = Getopt::Long::Descriptive->usage_class;
+
+This returns the class to be used for constructing a Usage object, and defaults
+to Getopt::Long::Descriptive::Usage.
 
 =head1 AUTHOR
 

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm Fri Nov 27 03:11:48 2009
@@ -1,6 +1,8 @@
 package Getopt::Long::Descriptive::Usage;
 use strict;
 use warnings;
+
+our $VERSION = '0.079';
 
 use List::Util qw(max);
 
@@ -116,6 +118,16 @@
 
 This throws the usage message as an exception.
 
+  $usage_obj->die(\%arg);
+
+Some arguments can be provided 
+
+  pre_text  - text to be prepended to the usage message
+  post_text - text to be appended to the usage message
+
+The C<pre_text> and C<post_text> arguments are concatenated with the usage
+message with no line breaks, so supply this if you need them.
+
 =cut
 
 sub die  { 
@@ -123,10 +135,7 @@
   my $arg  = shift || {};
 
   die(
-    join(
-      "", 
-      grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text},
-    )
+    join q{}, grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text}
   );
 }
 
@@ -137,6 +146,7 @@
   # this way.  Later we can toss a warning in here. -- rjbs, 2009-08-19
   '&{}' => sub {
     my ($self) = @_;
+    Carp::cluck("use of __PACKAGE__ objects as a code ref is deprecated");
     return sub { return $_[0] ? $self->text : $self->warn; };
   }
 );
@@ -147,11 +157,10 @@
 
 =head1 BUGS
 
-Please report any bugs or feature requests to
-C<bug-getopt-long-descriptive at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Long-Descriptive>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I make changes.
+Please report any bugs or feature requests through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Long-Descriptive>.  I
+will be notified, and then you'll automatically be notified of progress on your
+bug as I make changes.
 
 =head1 COPYRIGHT & LICENSE
 

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t?rev=47826&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t Fri Nov 27 03:11:48 2009
@@ -173,6 +173,7 @@
     "spacer and non-option description found",
   );
 
+  local $SIG{__WARN__} = sub {}; # we know that this will warn; don't care
   like(
     $usage->(1),
     qr/foo option\n\s+\n\tbar options:\n\s+--bar/,
@@ -205,9 +206,13 @@
   my ($opt, $usage) = describe_options(
     "%c %o",
     [ "foo", '' ],
+    [ "bar", '' ],
   );
   is( $opt->{foo}, 1, "empty-but-present description is ok" );
   is( $opt->foo,   1, "empty-but-present description is ok" );
+
+  is( $opt->{bar}, undef, "entry not given is undef (exists? no guarantee)" );
+  is( $opt->bar,   undef, "entry not given is undef (as method)");
 }
 
 {




More information about the Pkg-perl-cvs-commits mailing list