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