r4289 - in
/packages/libgetopt-euclid-perl/branches/upstream/current:
Changes META.yml README lib/Getopt/Euclid.pm t/vars_export.t
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Sun Nov 19 19:54:40 CET 2006
Author: gregoa-guest
Date: Sun Nov 19 19:54:40 2006
New Revision: 4289
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=4289
Log:
Load /tmp/tmp.jsgHO22761/libgetopt-euclid-perl-0.1.0 into
packages/libgetopt-euclid-perl/branches/upstream/current.
Modified:
packages/libgetopt-euclid-perl/branches/upstream/current/Changes
packages/libgetopt-euclid-perl/branches/upstream/current/META.yml
packages/libgetopt-euclid-perl/branches/upstream/current/README
packages/libgetopt-euclid-perl/branches/upstream/current/lib/Getopt/Euclid.pm
packages/libgetopt-euclid-perl/branches/upstream/current/t/vars_export.t
Modified: packages/libgetopt-euclid-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libgetopt-euclid-perl/branches/upstream/current/Changes?rev=4289&op=diff
==============================================================================
--- packages/libgetopt-euclid-perl/branches/upstream/current/Changes (original)
+++ packages/libgetopt-euclid-perl/branches/upstream/current/Changes Sun Nov 19 19:54:40 2006
@@ -66,3 +66,20 @@
- Fixed readable/writable test for '-' (thanks Thomas)
- Added regexes as valid placeholder type constraints
+
+
+0.0.9 Thu Oct 26 21:18:46 2006
+
+ - Patched :vars<opt_> mode to export all args (thanks Tim!)
+
+
+0.1.0 Thu Nov 2 19:47:05 2006
+
+ - Fixed failure to recognize +integer and 0+integer type specification
+ (thanks Ron)
+
+ - Added quotemeta'ing of regexically special characters
+ (thanks Ron)
+
+ - Repatched :vars<opt_> mode to really export all args
+ (thanks again Tim!)
Modified: packages/libgetopt-euclid-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libgetopt-euclid-perl/branches/upstream/current/META.yml?rev=4289&op=diff
==============================================================================
--- packages/libgetopt-euclid-perl/branches/upstream/current/META.yml (original)
+++ packages/libgetopt-euclid-perl/branches/upstream/current/META.yml Sun Nov 19 19:54:40 2006
@@ -1,7 +1,7 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Getopt-Euclid
-version: v0.0.8
+version: v0.1.0
version_from: lib/Getopt/Euclid.pm
installdirs: site
requires:
Modified: packages/libgetopt-euclid-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libgetopt-euclid-perl/branches/upstream/current/README?rev=4289&op=diff
==============================================================================
--- packages/libgetopt-euclid-perl/branches/upstream/current/README (original)
+++ packages/libgetopt-euclid-perl/branches/upstream/current/README Sun Nov 19 19:54:40 2006
@@ -1,4 +1,4 @@
-Getopt::Euclid version 0.0.8
+Getopt::Euclid version 0.1.0
Getopt::Euclid uses your program's own documentation to create a com-
mand-line argument parser. This ensures that your program's documented
Modified: packages/libgetopt-euclid-perl/branches/upstream/current/lib/Getopt/Euclid.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libgetopt-euclid-perl/branches/upstream/current/lib/Getopt/Euclid.pm?rev=4289&op=diff
==============================================================================
--- packages/libgetopt-euclid-perl/branches/upstream/current/lib/Getopt/Euclid.pm (original)
+++ packages/libgetopt-euclid-perl/branches/upstream/current/lib/Getopt/Euclid.pm Sun Nov 19 19:54:40 2006
@@ -1,6 +1,6 @@
package Getopt::Euclid;
-use version; $VERSION = qv('0.0.8');
+use version; $VERSION = qv('0.1.0');
use warnings;
use strict;
@@ -154,6 +154,7 @@
# Convert each arg entry to a hash...
my (%requireds, %options);
+ my %long_names;
my $seq_num = 0;
my %seen;
while (@requireds) {
@@ -172,6 +173,7 @@
if $seen{$minimal};
$seen{$minimal} = $name;
}
+ $long_names{ _longestname(@variants) } = $name;
}
while (@options) {
my ($name, $spec) = splice @options, 0, 2;
@@ -189,7 +191,9 @@
if $seen{$minimal};
$seen{$minimal} = $name;
}
- }
+ $long_names{ _longestname(@variants) } = $name;
+ }
+ _minimize_entries_of( \%long_names );
my %STD_CONSTRAINT_FOR;
BEGIN {
@@ -390,7 +394,6 @@
_verify_args($all_args_ref);
-
# Clean up %ARGV...
for my $arg_name (keys %ARGV) {
@@ -430,15 +433,23 @@
if ($vars_prefix) {
_minimize_entries_of( \%vars_opt_vals );
- my $maximal = (sort { length $a <=> length $b || $a cmp $b } keys %vars_opt_vals)[-1];
- my $export_as = $vars_prefix . $maximal;
- $export_as =~ s{\W}{_}gxms; # for '-'
- my $callpkg = caller($Exporter::ExportLevel || 0);
- no strict 'refs';
- *{"$callpkg\::$export_as"}
- = (ref $vars_opt_vals{$maximal}) ? $vars_opt_vals{$maximal}
- : \$vars_opt_vals{$maximal};
+ my $maximal = _longestname(keys %vars_opt_vals);
+ _export_var($vars_prefix, $maximal, $vars_opt_vals{$maximal});
+ delete $long_names{$maximal};
}
+ }
+ }
+
+ if ($vars_prefix) {
+ # export any unspecified options to keep use strict happy
+ for my $opt_name (keys %long_names) {
+ my $arg_name = $long_names{$opt_name};
+ my $arg_info = $all_args_ref->{$arg_name};
+ my $val;
+ $val = [ ] if $arg_info->{is_repeatable}
+ or $arg_name =~ />\.\.\./;
+ $val = { } if keys %{ $arg_info->{var} } > 1;
+ _export_var($vars_prefix, $opt_name, $val);
}
}
@@ -644,8 +655,8 @@
);
_make_equivalent(\%STD_MATCHER_FOR,
- integer => [qw( int i +int +i 0+int 0+i )],
- number => [qw( num n +num +n 0+num 0+n )],
+ integer => [qw( int i +int +i 0+int 0+i +integer 0+integer )],
+ number => [qw( num n +num +n 0+num 0+n +number 0+number )],
input => [qw( readable in )],
output => [qw( writable writeable out )],
string => [qw( str s )],
@@ -658,7 +669,13 @@
for my $arg_name ( keys %{$args_ref} ) {
my $arg = $args_ref->{$arg_name};
my $regex = $arg_name;
+
+ # Quotemeta specials...
+ $regex =~ s{([@#$^*()+{}?|])}{\\$1}gxms;
+
+ # Convert optionals...
1 while $regex =~ s/ \[ ([^]]*) \] /(?:$1)?/gxms;
+
$regex =~ s/ (\s+) /$1.'[\\s\\0\\1]*'/egxms;
my $generic = $regex;
$regex =~ s{ < (.*?) >(\.\.\.|) }
@@ -761,6 +778,20 @@
}
+sub _longestname {
+ return (sort { length $a <=> length $b || $a cmp $b } @_)[-1];
+}
+
+
+sub _export_var {
+ my ($prefix, $key, $value) = @_;
+ my $export_as = $prefix . $key;
+ $export_as =~ s{\W}{_}gxms; # mainly for '-'
+ my $callpkg = caller( 1 + ($Exporter::ExportLevel || 0) );
+ no strict 'refs';
+ *{"$callpkg\::$export_as"} = (ref $value) ? $value : \$value;
+}
+
1; # Magic true value required at end of module
__END__
@@ -772,7 +803,7 @@
=head1 VERSION
-This document describes Getopt::Euclid version 0.0.8
+This document describes Getopt::Euclid version 0.1.0
=head1 SYNOPSIS
@@ -1490,6 +1521,7 @@
<infile>
<outfile>
--auto-fudge <factor> (repeatable)
+ --also <a>...
--size <w>x<h>
Then these variables will be exported
@@ -1498,7 +1530,8 @@
$ARGV_mode
$ARGV_infile
$ARGV_outfile
- @ARGV_auto_fudge # With elements being the factors
+ @ARGV_auto_fudge
+ @ARGV_also
%ARGV_size # With entries $ARGV_size{w} and $ARGV_size{h}
For options that have multiple variants, only the longest variant is exported.
Modified: packages/libgetopt-euclid-perl/branches/upstream/current/t/vars_export.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libgetopt-euclid-perl/branches/upstream/current/t/vars_export.t?rev=4289&op=diff
==============================================================================
--- packages/libgetopt-euclid-perl/branches/upstream/current/t/vars_export.t (original)
+++ packages/libgetopt-euclid-perl/branches/upstream/current/t/vars_export.t Sun Nov 19 19:54:40 2006
@@ -1,3 +1,4 @@
+our ( $INFILE, $OUTFILE, $LEN, $H, $W, $TIMEOUT );
BEGIN {
$INFILE = $0;
$OUTFILE = $0;
@@ -7,6 +8,12 @@
$TIMEOUT = 7;
@ARGV = (
+ # doesn't include the --missing-* options in order to test that the
+ # corresponding variable is still exported even if not present in @ARGV.
+ # "--missing-bool",
+ # "--missing-repopt foo", "--missing-repopt bar",
+ # "--missing-repval foo bar",
+ # "--missing-hash ping,pong",
"-i $INFILE",
"-out=", $OUTFILE,
"-lgth $LEN",
@@ -24,15 +31,19 @@
use Getopt::Euclid qw( :vars<opt_> );
use Test::More 'no_plan';
+use strict;
+
sub got_arg {
my ($key, $val) = @_;
my $var_name = "opt_$key";
+ no strict 'refs';
is ${$var_name}, $val, "Got expected value for $var_name";
}
sub not_arg {
my ($key, $val) = @_;
my $var_name = "opt_$key";
+ no strict 'refs';
is ${$var_name}, undef, "$var_name should be undefined";
}
@@ -57,17 +68,24 @@
not_arg 'skip_some' => 1,
got_arg 'skip_something' => 1,
-is_deeply \@opt_also, [ 42, 43 ] => 'Got repeated options as array';
-
is $opt_timeout{min}, $TIMEOUT => 'Got expected value for timeout <min>';
is $opt_timeout{max}, -1 => 'Got default value for timeout <max>';
is $opt_size{h}, $H => 'Got expected value for size <h>';
is $opt_size{w}, $W => 'Got expected value for size <w>';
+is_deeply \@opt_also, [ 42, 43 ] => 'Got repeated options as array';
+
is_deeply \@opt_w, ['s p a c e s'] => 'Handled spaces correctly';
is $opt_step, 7 => 'Handled step size correctly';
+
+# test options that aren't given in @ARGV are still exported
+is $opt_missing_bool, undef, 'Got $opt_missing_bool as undef and use strict was happy';
+is_deeply \%opt_missing_hash, { }, 'Got %opt_missing_hash with 0 keys and use strict was happy';
+is_deeply \@opt_missing_repval, [ ], 'Got @opt_missing_repval with 0 elements and use strict was happy';
+is_deeply \@opt_missing_repopt, [ ], 'Got @opt_missing_repopt with 0 elements and use strict was happy';
+
__END__
@@ -160,6 +178,25 @@
=item <step>
Step size
+
+=item --missing-bool
+
+A missing option (boolean)
+
+=item --missing-hash <a>,<b>
+
+A missing option (hash)
+
+=item --missing-repval <a>...
+
+A missing option (repeatable value)
+
+=item --missing-repopt <a>
+
+A missing option (repeatable option)
+
+=for Euclid:
+ repeatable
=item --version
More information about the Pkg-perl-cvs-commits
mailing list