r42269 - in /trunk/libgetopt-long-descriptive-perl: Changes MANIFEST META.yml Makefile.PL README debian/changelog lib/Getopt/Long/Descriptive.pm lib/Getopt/Long/Descriptive/ t/descriptive.t
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Fri Aug 21 10:55:39 UTC 2009
Author: gregoa
Date: Fri Aug 21 10:55:33 2009
New Revision: 42269
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=42269
Log:
New upstream release.
Added:
trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/
- copied from r42268, branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/
Modified:
trunk/libgetopt-long-descriptive-perl/Changes
trunk/libgetopt-long-descriptive-perl/MANIFEST
trunk/libgetopt-long-descriptive-perl/META.yml
trunk/libgetopt-long-descriptive-perl/Makefile.PL
trunk/libgetopt-long-descriptive-perl/README
trunk/libgetopt-long-descriptive-perl/debian/changelog
trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm
trunk/libgetopt-long-descriptive-perl/t/descriptive.t
Modified: trunk/libgetopt-long-descriptive-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/Changes?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/Changes (original)
+++ trunk/libgetopt-long-descriptive-perl/Changes Fri Aug 21 10:55:33 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: trunk/libgetopt-long-descriptive-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/MANIFEST?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/MANIFEST (original)
+++ trunk/libgetopt-long-descriptive-perl/MANIFEST Fri Aug 21 10:55:33 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: trunk/libgetopt-long-descriptive-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/META.yml?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/META.yml (original)
+++ trunk/libgetopt-long-descriptive-perl/META.yml Fri Aug 21 10:55:33 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: trunk/libgetopt-long-descriptive-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/Makefile.PL?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/Makefile.PL (original)
+++ trunk/libgetopt-long-descriptive-perl/Makefile.PL Fri Aug 21 10:55:33 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: trunk/libgetopt-long-descriptive-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/README?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/README (original)
+++ trunk/libgetopt-long-descriptive-perl/README Fri Aug 21 10:55:33 2009
@@ -2,7 +2,7 @@
VERSION
-0.074
+0.076
INSTALLATION
Modified: trunk/libgetopt-long-descriptive-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/debian/changelog?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/debian/changelog (original)
+++ trunk/libgetopt-long-descriptive-perl/debian/changelog Fri Aug 21 10:55:33 2009
@@ -1,4 +1,4 @@
-libgetopt-long-descriptive-perl (0.074-2) UNRELEASED; urgency=low
+libgetopt-long-descriptive-perl (0.076-1) UNRELEASED; urgency=low
[ gregor herrmann ]
* Improve long description, thanks to Gerfried Fuchs for the suggestion
@@ -9,7 +9,10 @@
[ Nathan Handler ]
* debian/watch: Update to ignore development releases.
- -- gregor herrmann <gregoa at debian.org> Thu, 24 Jul 2008 22:58:40 +0200
+ [ gregor herrmann ]
+ * New upstream release.
+
+ -- gregor herrmann <gregoa at debian.org> Fri, 21 Aug 2009 12:54:40 +0200
libgetopt-long-descriptive-perl (0.074-1) unstable; urgency=low
Modified: trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm (original)
+++ trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm Fri Aug 21 10:55:33 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
Modified: trunk/libgetopt-long-descriptive-perl/t/descriptive.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/t/descriptive.t?rev=42269&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/t/descriptive.t (original)
+++ trunk/libgetopt-long-descriptive-perl/t/descriptive.t Fri Aug 21 10:55:33 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