r47828 - in /trunk/libgetopt-long-descriptive-perl: Changes META.yml Makefile.PL README debian/changelog debian/control 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:15:55 UTC 2009
Author: jawnsy-guest
Date: Fri Nov 27 03:15:49 2009
New Revision: 47828
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=47828
Log:
New upstream release
Modified:
trunk/libgetopt-long-descriptive-perl/Changes
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/debian/control
trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm
trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/Usage.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=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/Changes (original)
+++ trunk/libgetopt-long-descriptive-perl/Changes Fri Nov 27 03:15:49 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: trunk/libgetopt-long-descriptive-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/META.yml?rev=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/META.yml (original)
+++ trunk/libgetopt-long-descriptive-perl/META.yml Fri Nov 27 03:15:49 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: trunk/libgetopt-long-descriptive-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/Makefile.PL?rev=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/Makefile.PL (original)
+++ trunk/libgetopt-long-descriptive-perl/Makefile.PL Fri Nov 27 03:15:49 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: trunk/libgetopt-long-descriptive-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/README?rev=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/README (original)
+++ trunk/libgetopt-long-descriptive-perl/README Fri Nov 27 03:15:49 2009
@@ -2,7 +2,7 @@
VERSION
-0.077
+0.079
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=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/debian/changelog (original)
+++ trunk/libgetopt-long-descriptive-perl/debian/changelog Fri Nov 27 03:15:49 2009
@@ -1,8 +1,12 @@
-libgetopt-long-descriptive-perl (0.077-2) UNRELEASED; urgency=low
+libgetopt-long-descriptive-perl (0.079-1) UNRELEASED; urgency=low
+ [ Jonathan Yu ]
+ * New upstream release
+
+ [ Ryan Niebur ]
* Update jawnsy's email address
- -- Ryan Niebur <ryanryan52 at gmail.com> Tue, 01 Sep 2009 21:18:56 -0700
+ -- Jonathan Yu <jawnsy at cpan.org> Thu, 26 Nov 2009 18:55:37 -0500
libgetopt-long-descriptive-perl (0.077-1) unstable; urgency=low
Modified: trunk/libgetopt-long-descriptive-perl/debian/control
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/debian/control?rev=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/debian/control (original)
+++ trunk/libgetopt-long-descriptive-perl/debian/control Fri Nov 27 03:15:49 2009
@@ -16,7 +16,7 @@
Architecture: all
Depends: ${misc:Depends}, ${perl:Depends}, libparams-validate-perl,
libio-stringy-perl, libsub-exporter-perl
-Description: Perl Getopt module that handles usage text
+Description: module that handles command-line arguments with usage text
Getopt::Long::Descriptive is a convenience wrapper for Getopt::Long, which
allows one to easily define options in the same familiar way, while also
supporting custom descriptions for program usage output.
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=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm (original)
+++ trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive.pm Fri Nov 27 03:15:49 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: trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/Usage.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/Usage.pm?rev=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/Usage.pm (original)
+++ trunk/libgetopt-long-descriptive-perl/lib/Getopt/Long/Descriptive/Usage.pm Fri Nov 27 03:15:49 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: 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=47828&op=diff
==============================================================================
--- trunk/libgetopt-long-descriptive-perl/t/descriptive.t (original)
+++ trunk/libgetopt-long-descriptive-perl/t/descriptive.t Fri Nov 27 03:15:49 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