r48693 - in /branches/upstream/libgetopt-long-descriptive-perl/current: Changes MANIFEST META.yml README lib/Getopt/Long/Descriptive.pm lib/Getopt/Long/Descriptive/Opts.pm lib/Getopt/Long/Descriptive/Usage.pm t/descriptive.t
carnil-guest at users.alioth.debian.org
carnil-guest at users.alioth.debian.org
Sun Dec 13 14:16:44 UTC 2009
Author: carnil-guest
Date: Sun Dec 13 14:16:37 2009
New Revision: 48693
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=48693
Log:
[svn-upgrade] Integrating new upstream version, libgetopt-long-descriptive-perl (0.083)
Added:
branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Opts.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/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=48693&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/Changes (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/Changes Sun Dec 13 14:16:37 2009
@@ -1,4 +1,8 @@
Revision history for Getopt-Long-Descriptive
+
+0.083 2009-12-12
+ create an Opts module to store the opts object code
+ add _specified_opts method and _specified method for Opts
0.082 2009-12-03
require Getopt::Long 2.33 for proper --no-foo handling
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=48693&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/MANIFEST Sun Dec 13 14:16:37 2009
@@ -1,11 +1,12 @@
Changes
+lib/Getopt/Long/Descriptive.pm
+lib/Getopt/Long/Descriptive/Opts.pm
+lib/Getopt/Long/Descriptive/Usage.pm
+Makefile.PL
MANIFEST
-Makefile.PL
README
-lib/Getopt/Long/Descriptive.pm
-lib/Getopt/Long/Descriptive/Usage.pm
t/00-load.t
+t/descriptive.t
t/pod-coverage.t
t/pod.t
-t/descriptive.t
META.yml Module meta-data (added by MakeMaker)
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=48693&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/META.yml (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/META.yml Sun Dec 13 14:16:37 2009
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Getopt-Long-Descriptive
-version: 0.082
+version: 0.083
abstract: Getopt::Long with usage text
author:
- Hans Dieter Pearcey <hdp at cpan.org>
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=48693&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/README (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/README Sun Dec 13 14:16:37 2009
@@ -2,7 +2,7 @@
VERSION
-0.082
+0.083
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=48693&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 Sun Dec 13 14:16:37 2009
@@ -6,7 +6,9 @@
use Carp qw(carp croak);
use Params::Validate qw(:all);
use File::Basename ();
-
+use Scalar::Util ();
+
+use Getopt::Long::Descriptive::Opts;
use Getopt::Long::Descriptive::Usage;
=head1 NAME
@@ -15,11 +17,11 @@
=head1 VERSION
-Version 0.082
+Version 0.083
=cut
-our $VERSION = '0.082';
+our $VERSION = '0.083';
=head1 DESCRIPTION
@@ -356,6 +358,7 @@
my %return;
$usage->die unless GetOptions(\%return, grep { length } @specs);
+ my @given_keys = keys %return;
for my $opt (keys %return) {
my $newopt = _munge($opt);
@@ -377,8 +380,9 @@
$return{$name} = $new;
}
- my $opt_obj = $class->_new_opt_obj({
+ my $opt_obj = Getopt::Long::Descriptive::Opts->___new_opt_obj({
values => { %method_map, %return },
+ given => { map {; $_ => 1 } @given_keys },
});
return($opt_obj, $usage);
@@ -509,46 +513,6 @@
die "unimplemented";
}
-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);
-
- # This is stupid, but the traditional behavior was that if --foo was not
- # given, there is no $opt->{foo}; it started to show up when we "needed" all
- # the keys to generate a class, but was undef; this wasn't a problem, but
- # broke tests of things that were relying on not-exists like tests of %$opt
- # contents or MooseX::Getopt which wanted to use things as args for new --
- # undef would not pass an Int TC. Easier to just do this. -- rjbs,
- # 2009-11-27
- my $obj = bless { %{ $arg->{values} } } => $class;
- delete $obj->{$_} for grep { ! defined $obj->{$_} } keys %$obj;
-
- return $obj;
-}
-
=head1 CUSTOMIZING
Getopt::Long::Descriptive uses L<Sub::Exporter|Sub::Exporter> to build and
Added: branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Opts.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Opts.pm?rev=48693&op=file
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Opts.pm (added)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/lib/Getopt/Long/Descriptive/Opts.pm Sun Dec 13 14:16:37 2009
@@ -1,0 +1,166 @@
+use strict;
+use warnings;
+package Getopt::Long::Descriptive::Opts;
+
+use Scalar::Util qw(blessed weaken);
+
+=head1 NAME
+
+Getopt::Long::Descriptive::Opts - object representing command line switches
+
+=head1 VERSION
+
+Version 0.083
+
+=cut
+
+our $VERSION = '0.083';
+
+=head1 DESCRIPTION
+
+This class is the base class of all C<$opt> objects returned by
+L<Getopt::Long::Descriptive>. In general, you do not want to think about this
+class, look at it, or alter it. Seriously, it's pretty dumb.
+
+Every call to C<describe_options> will return a object of a new subclass of
+this class. It will have a method for the canonical name of each option
+possible given the option specifications.
+
+Method names beginning with an single underscore are public, and are named that
+way to avoid conflict with automatically generated methods. Methods with
+multiple underscores (in case you're reading the source) are private.
+
+=head1 METHODS
+
+B<Achtung!> All methods beginning with an underscore are experimental as of
+today, 2009-12-12. They are likely to be formally made permanent soon.
+
+=head2 _specified
+
+This method returns true if the given name was specified on the command line.
+
+For example, if C<@ARGS> was "C<< --foo --bar 10 >>" and C<baz> is defined by a
+default, C<_specified> will return true for foo and bar, and false for baz.
+
+=cut
+
+my %_CREATED_OPTS;
+my $SERIAL_NUMBER = 1;
+
+sub _specified {
+ my ($self, $name) = @_;
+ my $meta = $_CREATED_OPTS{ blessed $self }{meta};
+ return $meta->{given}{ $name };
+}
+
+=head2 _specified_opts
+
+This method returns an opt object in which only explicitly specified values are
+defined. Values which were set by defaults will appear undef.
+
+=cut
+
+sub _specified_opts {
+ my ($self) = @_;
+
+ my $class = blessed $self;
+ my $meta = $_CREATED_OPTS{ $class }{meta};
+
+ return $meta->{specified_opts} if $meta->{specified_opts};
+
+ my @keys = grep { $meta->{given}{ $_ } } (keys %{ $meta->{given} });
+
+ my %opts;
+ @opts{ @keys } = @$self{ @keys };
+
+ $meta->{specified_opts} = \%opts;
+
+ bless $meta->{specified_opts} => $class;
+ weaken $meta->{specified_opts};
+
+ $meta->{specified_opts};
+}
+
+=head2 _complete_opts
+
+This method returns the opts object with all values, including those set by
+defaults. It is probably not going to be very often-used.
+
+=cut
+
+sub _complete_opts {
+ my ($self) = @_;
+
+ my $class = blessed $self;
+ my $meta = $_CREATED_OPTS{ $class }{meta};
+ return $meta->{complete_opts};
+}
+
+sub ___class_for_opt {
+ my ($class, $arg) = @_;
+
+ my $values = $arg->{values};
+ my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values;
+ Carp::confess("perverse option names given: @bad") if @bad;
+
+ my $new_class = "$class\::__OPT__::" . $SERIAL_NUMBER++;
+ $_CREATED_OPTS{ $new_class } = { meta => $arg };
+
+ {
+ no strict 'refs';
+ ${"$new_class\::VERSION"} = $class->VERSION;
+ *{"$new_class\::ISA"} = [ 'Getopt::Long::Descriptive::Opts' ];
+ for my $opt (keys %$values) {
+ *{"$new_class\::$opt"} = sub { $_[0]->{ $opt } };
+ }
+ }
+
+ return $new_class;
+}
+
+sub ___new_opt_obj {
+ my ($class, $arg) = @_;
+
+ my $copy = { %{ $arg->{values} } };
+
+ my $new_class = $class->___class_for_opt($arg);
+
+ # This is stupid, but the traditional behavior was that if --foo was not
+ # given, there is no $opt->{foo}; it started to show up when we "needed" all
+ # the keys to generate a class, but was undef; this wasn't a problem, but
+ # broke tests of things that were relying on not-exists like tests of %$opt
+ # contents or MooseX::Getopt which wanted to use things as args for new --
+ # undef would not pass an Int TC. Easier to just do this. -- rjbs,
+ # 2009-11-27
+ delete $copy->{$_} for grep { ! defined $copy->{$_} } keys %$copy;
+
+ my $self = bless $copy => $new_class;
+
+ $_CREATED_OPTS{ $new_class }{meta}{complete_opts} = $self;
+ # weaken $_CREATED_OPTS{ $new_class }{meta}{complete_opts};
+
+ return $self;
+}
+
+=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/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=48693&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 Sun Dec 13 14:16:37 2009
@@ -2,7 +2,7 @@
use strict;
use warnings;
-our $VERSION = '0.082';
+our $VERSION = '0.083';
use List::Util qw(max);
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=48693&op=diff
==============================================================================
--- branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t (original)
+++ branches/upstream/libgetopt-long-descriptive-perl/current/t/descriptive.t Sun Dec 13 14:16:37 2009
@@ -1,9 +1,8 @@
#!perl
-
use strict;
use warnings;
-use Test::More 'no_plan';
+use Test::More tests => 37;
use_ok("Getopt::Long::Descriptive");
@@ -202,6 +201,31 @@
}
{
+ local @ARGV = qw(--foo FOO --baz BAZ);
+ my ($c_opt, $usage) = describe_options(
+ "%c %o",
+ [ "foo=s", '' ],
+ [ "bar=s", '', { default => 'BAR' } ],
+ [ "baz=s", '', { default => 'BAZ' } ],
+ );
+
+ my $s_opt = $c_opt->_specified_opts;
+ my $C_opt = $s_opt->_complete_opts;
+
+ is($c_opt->foo, 'FOO', 'c_opt->foo is FOO');
+ is($C_opt->foo, 'FOO', 'C_opt->foo is FOO');
+ is($s_opt->foo, 'FOO', 's_opt->foo is FOO');
+
+ is($c_opt->bar, 'BAR', 'c_opt->foo is BAR');
+ is($C_opt->bar, 'BAR', 'C_opt->foo is BAR');
+ is($s_opt->bar, undef, 's_opt->foo is undef');
+
+ is($c_opt->baz, 'BAZ', 'c_opt->foo is BAZ');
+ is($C_opt->baz, 'BAZ', 'C_opt->foo is BAZ');
+ is($s_opt->baz, 'BAZ', 's_opt->foo is BAZ');
+}
+
+{
local @ARGV = qw(--foo);
my ($opt, $usage) = describe_options(
"%c %o",
More information about the Pkg-perl-cvs-commits
mailing list