From: Vincent Pit <vince@profvince.com>
Date: Thu, 28 Aug 2008 11:29:23 +0000 (+0200)
Subject: Add the in parameter
X-Git-Tag: v0.02~6
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a458a01af6d6d0e328ffc36afdcbd96628ae2e71;p=perl%2Fmodules%2Fsubs-auto.git

Add the in parameter
---

diff --git a/MANIFEST b/MANIFEST
index 8ecef54..98795b0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4,7 +4,9 @@ Makefile.PL
 README
 lib/subs/auto.pm
 t/00-load.t
+t/05-args.t
 t/10-base.t
+t/11-pkg.t
 t/90-boilerplate.t
 t/91-pod.t
 t/92-pod-coverage.t
diff --git a/lib/subs/auto.pm b/lib/subs/auto.pm
index 08f38e2..6c4bf27 100644
--- a/lib/subs/auto.pm
+++ b/lib/subs/auto.pm
@@ -5,6 +5,7 @@ use 5.010;
 use strict;
 use warnings;
 
+use Carp qw/croak/;
 use Symbol qw/gensym/;
 
 use Variable::Magic qw/wizard cast dispell getdata/;
@@ -47,10 +48,7 @@ This pragma lexically enables the parsing of any bareword as a subroutine name,
 =cut
 
 BEGIN {
- if (!Variable::Magic::VMG_UVAR) {
-  require Carp;
-  Carp::croak('uvar magic not available');
- }
+ croak 'uvar magic not available' unless Variable::Magic::VMG_UVAR;
 }
 
 my @core = qw/abs accept alarm atan2 bind binmode bless break caller chdir
@@ -149,7 +147,20 @@ my $wiz = wizard data  => sub { +{ pkg => $_[1] } },
 my %pkgs;
 
 sub import {
- my $pkg = caller 1;
+ shift;
+ croak 'Optional arguments must be passed as keys/values pairs' if @_ % 2;
+ my %args = @_;
+ my $cur = (caller 1)[0];
+ my $pkg;
+ if ($pkg = $args{in}) {
+  croak 'Invalid package name' if ref $pkg
+                               or $pkg =~ /(?:-|[^\w:])/
+                               or $pkg =~ /(?:\A\d|\b:(?::\d|(?:::+)?\b))/;
+  $pkg =~ s/::$//;
+  $pkg = $cur . $pkg if $pkg eq '' or $pkg =~ /^::/;
+ } else {
+  $pkg = $cur;
+ }
  $^H{bareword} = 1;
  ++$pkgs{$pkg};
  no strict 'refs';
diff --git a/t/05-args.t b/t/05-args.t
new file mode 100644
index 0000000..fa0e191
--- /dev/null
+++ b/t/05-args.t
@@ -0,0 +1,29 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+my $invalid = qr/Invalid\s+package\s+name/;
+
+eval "use subs::auto in => \\( q{foo::bar} )";
+like($@, $invalid, 'no ref as package name');
+
+eval "use subs::auto in => qq{foo\\nbar}";
+like($@, $invalid, 'no newline in package name');
+
+eval "use subs::auto in => q{foo-bar}";
+like($@, $invalid, 'no dash in package name');
+
+eval "use subs::auto in => q{foo:bar}";
+like($@, $invalid, 'no single colon in package name');
+
+eval "use subs::auto in => q{foo:::bar}";
+like($@, $invalid, 'no three colons in package name');
+
+eval "use subs::auto in => q{1foo::bar}";
+like($@, $invalid, 'no package name starting by a digit');
+
+eval "use subs::auto in => q{foo::2bar}";
+like($@, $invalid, 'no package name with a digit inside');
diff --git a/t/11-pkg.t b/t/11-pkg.t
new file mode 100644
index 0000000..bd4ebb3
--- /dev/null
+++ b/t/11-pkg.t
@@ -0,0 +1,66 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+our $foo;
+
+{
+ use subs::auto in => 'subs::auto::Test::Pkg';
+
+ eval { subs::auto::Test::Pkg::foo 5 };
+ is($@, '', 'compiled to subs::auto::Test::Pkg::foo(5)');
+ is($foo, 10, 'subs::auto::Test::Pkg::foo was really called');
+
+ {
+  use subs::auto;
+
+  eval { foo 3 };
+  is($@, '', 'compiled to foo(3)');
+  is($foo, 3, 'main::foo was really called');
+
+  {
+   package subs::auto::Test::Pkg;
+
+   eval { foo 7 };
+   Test::More::is($@, '', 'compiled to foo(7)');
+   Test::More::is($foo, 14, 'subs::auto::Test::Pkg::foo was really called');
+
+   eval { main::foo 9 };
+   Test::More::is($@, '', 'compiled to main::foo(9)');
+   Test::More::is($foo, 9, 'main::foo was really called');
+  }
+ }
+}
+
+{
+ use subs::auto in => '::';
+
+ eval { foo 11 };
+ is($@, '', 'compiled to foo(11)');
+ is($foo, 11, 'main::foo was really called');
+}
+
+{
+ package subs::auto::Test;
+
+ use subs::auto in => '::Pkg';
+
+ {
+  package subs::auto::Test::Pkg;
+
+  eval { foo 13 };
+  Test::More::is($@, '', 'compiled to foo(13)');
+  Test::More::is($foo, 26, 'subs::auto::Test::Pkg::foo was really called');
+ }
+}
+
+sub foo {
+ $main::foo = $_[0];
+}
+
+sub subs::auto::Test::Pkg::foo {
+ $main::foo = 2 * $_[0];
+}