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

gregoa at users.alioth.debian.org gregoa at users.alioth.debian.org
Fri Aug 21 10:54:21 UTC 2009


Author: gregoa
Date: Fri Aug 21 10:54:15 2009
New Revision: 42267

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

Added:
    branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/
    branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm
Modified:
    branches/upstream/libgetopt-long-descriptive-perl/current/Changes
    branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST
    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/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=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/Changes (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/Changes Fri Aug 21 10:54:15 2009
@@ -1,4 +1,12 @@
 Revision history for Getopt-Long-Descriptive
+
+0.076   2009-08-20
+        bundle the accidentally omitted Usage.pm file
+        the $opt returned by described_options is now an object with accessors
+
+0.075   2009-08-19
+        significant refactoring, especially to GLD::Usage, which is now a more
+        traditional (non-hash-based) object (RJBS)
 
 0.074   2008-05-11
 

Modified: branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST?rev=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST Fri Aug 21 10:54:15 2009
@@ -3,6 +3,7 @@
 Makefile.PL
 README
 lib/Getopt/Long/Descriptive.pm
+lib/Getopt/Long/Descriptive/Usage.pm
 t/00-load.t
 t/pod-coverage.t
 t/pod.t

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=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/META.yml (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/META.yml Fri Aug 21 10:54:15 2009
@@ -1,17 +1,26 @@
 --- #YAML:1.0
-name:                Getopt-Long-Descriptive
-version:             0.074
-abstract:            Getopt::Long with usage text
-license:             ~
-author:              
+name:               Getopt-Long-Descriptive
+version:            0.076
+abstract:           Getopt::Long with usage text
+author:
     - Hans Dieter Pearcey <hdp at cpan.org>
-generated_by:        ExtUtils::MakeMaker version 6.44
-distribution_type:   module
-requires:     
-    IO::Scalar:                    0
-    List::Util:                    0
-    Params::Validate:              0.74
-    Test::More:                    0
+license:            unknown
+distribution_type:  module
+configure_requires:
+    ExtUtils::MakeMaker:  0
+build_requires:
+    ExtUtils::MakeMaker:  0
+requires:
+    IO::Scalar:        0
+    List::Util:        0
+    Params::Validate:  0.74
+    Sub::Exporter:     0
+    Test::More:        0
+no_index:
+    directory:
+        - t
+        - inc
+generated_by:       ExtUtils::MakeMaker version 6.55_02
 meta-spec:
-    url:     http://module-build.sourceforge.net/META-spec-v1.3.html
-    version: 1.3
+    url:      http://module-build.sourceforge.net/META-spec-v1.4.html
+    version:  1.4

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=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/Makefile.PL Fri Aug 21 10:54:15 2009
@@ -3,7 +3,7 @@
 use ExtUtils::MakeMaker;
 
 WriteMakefile(
-    NAME                => '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',
@@ -12,7 +12,8 @@
         'Test::More' => 0,
         'Params::Validate' => '0.74',
         'List::Util' => 0,
-	'IO::Scalar' => 0,
+        'IO::Scalar' => 0,
+        'Sub::Exporter' => 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=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/README (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/README Fri Aug 21 10:54:15 2009
@@ -2,7 +2,7 @@
 
 VERSION
 
-0.074
+0.076
 
 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=42267&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 Aug 21 10:54:15 2009
@@ -2,22 +2,24 @@
 
 use strict;
 use Getopt::Long;
-use List::Util qw(max first);
+use List::Util qw(first);
 use Carp qw(carp croak);
 use Params::Validate qw(:all);
 use File::Basename ();
 
+use Getopt::Long::Descriptive::Usage;
+
 =head1 NAME
 
 Getopt::Long::Descriptive - Getopt::Long with usage text
 
 =head1 VERSION
 
-Version 0.074
+Version 0.076
 
 =cut
 
-our $VERSION = '0.074';
+our $VERSION = '0.076';
 
 =head1 DESCRIPTION
 
@@ -208,22 +210,20 @@
 sub prog_name { @_ ? ($prog_name = shift) : $prog_name }
 
 BEGIN {
-  require Exporter;
-  our @ISA = qw(Exporter);
-  our @EXPORT = qw(describe_options);
-  our %EXPORT_TAGS = (
-    types => $Params::Validate::EXPORT_TAGS{types},
-  );
-  our @EXPORT_OK = (
-    @{$EXPORT_TAGS{types}},
-    @EXPORT,
-    'prog_name',
-  );
-  $EXPORT_TAGS{all} = \@EXPORT_OK;
-
   # grab this before someone decides to change it
   prog_name(File::Basename::basename($0));
 }
+
+use Sub::Exporter -setup => {
+  exports => [
+    qw(describe_options prog_name),
+    @{ $Params::Validate::EXPORT_TAGS{types} }
+  ],
+  groups  => [
+    default => [ qw(describe_options) ],
+    types   => $Params::Validate::EXPORT_TAGS{types},
+  ],
+};
 
 my %CONSTRAINT = (
   implies  => \&_mk_implies,
@@ -249,6 +249,15 @@
 my %HIDDEN = (
   hidden => 1,
 );
+
+my $SPEC_RE = qr{(?:[:=][\d\w\+]+[%@]?({\d*,\d*})?|[!+])$};
+sub _strip_assignment {
+  my ($self, $str) = @_;
+
+  (my $copy = $str) =~ s{$SPEC_RE}{};
+
+  return $copy;
+}
 
 sub describe_options {
   my $format = shift;
@@ -290,19 +299,18 @@
   }
 
   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 $spec_assignment = '(?:[:=][\d\w\+]+[%@]?({\d*,\d*})?|[!+])$';
 
   my $short = join "", sort {
     lc $a cmp lc $b 
     or $a cmp $b
   } map {
-    (my $s = $_) =~ s/$spec_assignment//;
+    my $s = __PACKAGE__->_strip_assignment($_);
     grep /^.$/, split /\|/, $s
   } @specs;
   
@@ -320,41 +328,10 @@
   (my $str = $format) =~ s/%(.)/$replace{$1}/ge;
   $str =~ s/\s{2,}/ /g;
 
-  # a spec can grow up to 4 characters in usage output:
-  # '-' on short option, ' ' between short and long, '--' on long
-  my $length = (max(map length(), @specs) || 0) + 4;
-  my $spec_fmt = "\t%-${length}s";
-
-  my @showopts = _nohidden(@opts);
-  my $usage = bless sub {
-    my ($as_string) = @_;
-    my ($out_fh, $buffer);
-    my @tmpopts = @showopts;
-    if ($as_string) {
-      require IO::Scalar;
-      $out_fh = IO::Scalar->new( \$buffer );
-    } else {
-      $out_fh = \*STDERR;
-    }
-
-    print {$out_fh} "$str\n";
-
-    while (@tmpopts) {
-      my $opt  = shift @tmpopts;
-      my $spec = $opt->{spec};
-      my $desc = $opt->{desc};
-      if ($desc eq 'spacer') {
-        printf {$out_fh} "$spec_fmt\n", $opt->{spec};
-        next;
-      }
-      $spec =~ s/$spec_assignment//;
-      $spec = join " ", reverse map { length > 1 ? "--$_" : "-$_" }
-                                split /\|/, $spec;
-      printf {$out_fh} "$spec_fmt  %s\n", $spec, $desc;
-    }
-
-    return $buffer if $as_string;
-  } => "Getopt::Long::Descriptive::Usage";
+  my $usage = Getopt::Long::Descriptive::Usage->new({
+    options     => [ _nohidden(@opts) ],
+    leader_text => $str,
+  });
 
   Getopt::Long::Configure(@go_conf);
 
@@ -381,7 +358,11 @@
     $return{$name} = $new;
   }
 
-  return \%return, $usage;
+  my $opt_obj = Getopt::Long::Descriptive::OptObjFactory->new_opt_obj({
+    values => \%return,
+  });
+
+  return($opt_obj, $usage);
 }
 
 sub _munge {
@@ -417,16 +398,12 @@
     } else {
       %pvspec = (
         %pvspec,
-        $CONSTRAINT{$ct}
-          ? %{$CONSTRAINT{$ct}}
-            : ($ct => $spec->{$ct}),
+        $CONSTRAINT{$ct} ? %{$CONSTRAINT{$ct}} : ($ct => $spec->{$ct}),
       );
     }
   }
 
-  unless (exists $pvspec{optional}) {
-    $pvspec{optional} = 1;
-  }
+  $pvspec{optional} = 1 unless exists $pvspec{optional};
 
   # we need to implement 'default' by ourselves sometimes
   # because otherwise the implies won't be checked/executed
@@ -439,10 +416,6 @@
     $arg{params}{$arg{name}} = delete $pvspec{default};
   }
 
-  #use Data::Dumper;
-  #local $Data::Dumper::Terse = 1;
-  #local $Data::Dumper::Indent = 0;
-  #warn "pvspec = " . Dumper(\%pvspec);
   my %p = eval { 
     validate_with(
       params => [ %{$arg{params}} ],
@@ -470,14 +443,11 @@
 # hashref:  single/multiple options = given values
 sub _norm_imply {
   my ($what) = @_;
-  return $what
-    if ref $what eq 'HASH';
-
-  return { map { $_ => 1 } @$what } 
-    if ref $what eq 'ARRAY';
-
-  return { $what => 1 }
-    if not ref $what;
+
+  return { $what => 1 } unless my $ref = ref $what;
+
+  return $what                      if $ref eq 'HASH';
+  return { map { $_ => 1 } @$what } if $ref eq 'ARRAY';
 
   die "can't imply: $what";
 }
@@ -487,25 +457,30 @@
   my $what = _norm_imply(shift);
   my $param = shift;
   my $opts  = shift;
+
   for my $implied (keys %$what) {
-    first { $_->{name} eq $implied } @$opts
-      or die("option specification for $name implies nonexistent option $implied\n");
-  }
-  my $whatstr = join(
-    ", ", 
-    map { "$_=$what->{$_}" }
-      keys %$what);
+    die("option specification for $name implies nonexistent option $implied\n")
+      unless first { $_->{name} eq $implied } @$opts
+  }
+
+  my $whatstr = join(q{, }, map { "$_=$what->{$_}" } keys %$what);
+
   return "$name implies $whatstr" => sub {
     my ($pv_val) = shift;
+
     # negatable options will be 0 here, which is ok.
     return 1 unless defined $pv_val;
+
     while (my ($key, $val) = each %$what) {
       if (exists $param->{$key} and $param->{$key} ne $val) {
-        die("option specification for $name implies that $key should be set to '$val', "
-              . "but it is '$param->{$key}' already\n");
+        die(
+          "option specification for $name implies that $key should be "
+          . "set to '$val', but it is '$param->{$key}' already\n"
+        );
       }
       $param->{$key} = $val;
     }
+
     return 1;
   };
 }
@@ -514,29 +489,38 @@
   die "unimplemented";
 }
 
-package Getopt::Long::Descriptive::Usage;
-
-use strict;
-
-sub text { shift->(1) }
-
-sub warn { shift->() }
-
-sub die  { 
-  my $self = shift;
-  my $arg  = shift || {};
-
-  die(
-    join(
-      "", 
-      grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text},
-    )
-  );
-}
-
-use overload (
-  q{""} => "text",
-);
+{
+  # Clever line break to avoid indexing! -- rjbs, 2009-08-20
+  package
+    Getopt::Long::Descriptive::OptObjFactory;
+
+  my $VERSION = '0.076';
+
+  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;
+  }
+}
 
 =head1 AUTHOR
 

Added: 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=42267&op=file
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm (added)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Usage.pm Fri Aug 21 10:54:15 2009
@@ -1,0 +1,165 @@
+package Getopt::Long::Descriptive::Usage;
+use strict;
+use warnings;
+
+use List::Util qw(max);
+
+=head1 NAME
+
+Getopt::Long::Descriptive::Usage - the usage description for GLD
+
+=head1 SYNOPSIS
+
+  use Getopt::Long::Descriptive;
+  my ($opt, $usage) = describe_options( ... );
+
+  $usage->text; # complete usage message
+
+  $usage->die;  # die with usage message
+
+=head1 DESCRIPTION
+
+This document only describes the methods of the Usage object.  For information
+on how to use L<Getopt::Long::Descriptive>, consult its documentation.
+
+=head1 METHODS
+
+=head2 new
+
+  my $usage = Getopt::Long::Descriptive::Usage->new(\%arg);
+
+You B<really> don't need to call this.  GLD will do it for you.
+
+Valid arguments are:
+
+  options     - an arrayref of options
+  leader_text - the text that leads the usage; this may go away!
+
+=cut
+
+sub new {
+  my ($class, $arg) = @_;
+
+  my @to_copy = qw(options leader_text);
+
+  my %copy;
+  @copy{ @to_copy } = @$arg{ @to_copy };
+
+  bless \%copy => $class;
+}
+
+=head2 text
+
+This returns the full text of the usage message.
+
+=cut
+
+sub text {
+  my ($self) = @_;
+
+  return join qq{\n}, $self->leader_text, $self->option_text;
+}
+
+=head2 leader_text
+
+This returns the text that comes at the beginning of the usage message.
+
+=cut
+
+sub leader_text { $_[0]->{leader_text} }
+
+=head2 option_text
+
+This returns the text describing the available options.
+
+=cut
+
+sub option_text {
+  my ($self) = @_;
+
+  my @options  = @{ $self->{options} || [] };
+  my $string   = q{};
+
+  # a spec can grow up to 4 characters in usage output:
+  # '-' on short option, ' ' between short and long, '--' on long
+  my @specs = map { $_->{spec} } grep { $_->{desc} ne 'spacer' } @options;
+  my $length   = (max(map { length } @specs) || 0) + 4;
+  my $spec_fmt = "\t%-${length}s";
+
+  while (@options) {
+    my $opt  = shift @options;
+    my $spec = $opt->{spec};
+    my $desc = $opt->{desc};
+    if ($desc eq 'spacer') {
+      $string .= sprintf "$spec_fmt\n", $opt->{spec};
+      next;
+    }
+
+    $spec = Getopt::Long::Descriptive->_strip_assignment($spec);
+    $spec = join " ", reverse map { length > 1 ? "--$_" : "-$_" }
+                              split /\|/, $spec;
+    $string .= sprintf "$spec_fmt  %s\n", $spec, $desc;
+  }
+
+  return $string;
+}
+
+=head2 warn
+
+This warns with the usage message.
+
+=cut
+
+sub warn { warn shift->text }
+
+=head2 die
+
+This throws the usage message as an exception.
+
+=cut
+
+sub die  { 
+  my $self = shift;
+  my $arg  = shift || {};
+
+  die(
+    join(
+      "", 
+      grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text},
+    )
+  );
+}
+
+use overload (
+  q{""} => "text",
+
+  # This is only needed because Usage used to be a blessed coderef that worked
+  # this way.  Later we can toss a warning in here. -- rjbs, 2009-08-19
+  '&{}' => sub {
+    my ($self) = @_;
+    return sub { return $_[0] ? $self->text : $self->warn; };
+  }
+);
+
+=head1 AUTHOR
+
+Hans Dieter Pearcey, C<< <hdp at cpan.org> >>
+
+=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.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2005 Hans Dieter Pearcey, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;

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=42267&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t Fri Aug 21 10:54:15 2009
@@ -27,6 +27,10 @@
       $expect,
       $desc,
     );
+
+    for my $key (keys %$expect) {
+      is($opt->$key, $expect->{$key}, "...->$key");
+    }
   }; 
   if ($@) {
     chomp($@);
@@ -162,10 +166,17 @@
     ['bar options:'],
     [ bar => "a bar option" ],
   );
+
   like(
     $usage->text,
     qr/foo option\n\s+\n\tbar options:\n\s+--bar/,
     "spacer and non-option description found",
+  );
+
+  like(
+    $usage->(1),
+    qr/foo option\n\s+\n\tbar options:\n\s+--bar/,
+    "CODEISH: spacer and non-option description found",
   );
 }
 
@@ -196,6 +207,7 @@
     [ "foo", '' ],
   );
   is( $opt->{foo}, 1, "empty-but-present description is ok" );
+  is( $opt->foo,   1, "empty-but-present description is ok" );
 }
 
 {
@@ -207,4 +219,7 @@
   );
   is_deeply($opt, { foo => 1, foo_bar => 1 },
     "ok to imply option with optional argument");
-}
+
+  is($opt->foo_bar, 1, 'given value (checked with method)');
+  is($opt->foo,     1, 'implied value (checked with method)');
+}




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