From: Vincent Pit <vince@profvince.com>
Date: Sun, 3 Jan 2010 13:11:33 +0000 (+0100)
Subject: Handle existing prototyped subs
X-Git-Tag: v0.02~15
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=5ae3324ff295015e051249ded13b2353ee8af258;p=perl%2Fmodules%2FSub-Op.git

Handle existing prototyped subs
---

diff --git a/Makefile.PL b/Makefile.PL
index 6069830..a7e84db 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -14,6 +14,7 @@ $file = "lib/$file.pm";
 my %PREREQ_PM = (
  'B::Hooks::EndOfScope' => 0,
  'DynaLoader'           => 0,
+ 'Scalar::Util'         => 0,
  'Variable::Magic'      => '0.39',
 );
 
diff --git a/lib/Sub/Op.pm b/lib/Sub/Op.pm
index 76d22da..8c8f6c8 100644
--- a/lib/Sub/Op.pm
+++ b/lib/Sub/Op.pm
@@ -118,6 +118,8 @@ When L<B> and L<B::Deparse> are loaded, they get automatically monkeypatched so
 
 =cut
 
+use Scalar::Util;
+
 use B::Hooks::EndOfScope;
 use Variable::Magic 0.08;
 
@@ -147,6 +149,16 @@ my $sw = Variable::Magic::wizard(
  },
 );
 
+sub _tag {
+ my ($pkg, $name) = @_;
+
+ my $fqn = join '::', $pkg, $name;
+
+ return {
+  proto => prototype($fqn),
+ };
+}
+
 sub _map {
  my ($pkg) = @_;
 
@@ -161,8 +173,14 @@ sub _map {
 sub _cast {
  my ($pkg, $name) = @_;
 
- no strict 'refs';
- Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, { $name => 1 });
+ my $map = { $name => _tag(@_) };
+
+ {
+  no strict 'refs';
+  Variable::Magic::cast(%{"${pkg}::"}, $sw, $pkg, $map);
+ }
+
+ return $map;
 }
 
 sub _dispell {
@@ -245,9 +263,15 @@ sub enable {
  my $map = _map($pkg);
 
  if (defined $map) {
-  $map->{$name} = 1;
+  $map->{$name} = _tag($pkg, $name);
  } else {
-  _cast($pkg, $name);
+  $map = _cast($pkg, $name);
+ }
+
+ my $proto = $map->{$name}->{proto};
+ if (defined $proto) {
+  no strict 'refs';
+  Scalar::Util::set_prototype(\&{"${pkg}::$name"}, undef);
  }
 
  $^H |= 0x00020000;
@@ -273,6 +297,12 @@ sub disable {
  my $map = _map($pkg);
 
  if (defined $map) {
+  my $proto = $map->{$name}->{proto};
+  if (defined $proto) {
+   no strict 'refs';
+   Scalar::Util::set_prototype(\&{"${pkg}::$name"}, $proto);
+  }
+
   delete $map->{$name};
   unless (keys %$map) {
    _dispell($pkg);
diff --git a/t/11-existing.t b/t/11-existing.t
index 58e23a0..0339bc8 100644
--- a/t/11-existing.t
+++ b/t/11-existing.t
@@ -5,11 +5,14 @@ use warnings;
 
 use blib 't/Sub-Op-LexicalSub';
 
-use Test::More tests => (4 + 2 * 4) + (2 * 5);
+use Test::More tests => 2 *((4 + 2 * 4) + (2 * 5) + 1);
 
 our $call_foo;
 sub foo { ok $call_foo, 'the preexistent foo was called' }
 
+our $call_bar;
+sub bar () { ok $call_bar, 'the preexistent bar was called' }
+
 our $called;
 
 {
@@ -66,6 +69,9 @@ our $called;
  }
 }
 
+is prototype('main::foo'), undef, "foo's prototype was preserved";
+is prototype('main::bar'), '',    "bar's prototype was preserved";
+
 __DATA__
 foo();
 ----
@@ -109,3 +115,46 @@ my $foo = \&foo;
 &$foo;
 ----
 foo # () #
+####
+bar();
+----
+bar # () # [ ]
+####
+bar;
+----
+bar # () # [ ]
+####
+bar(1);
+----
+bar # () # [ 1 ]
+####
+bar 2;
+----
+bar # () # [ 2 ]
+####
+local $call_bar = 1;
+&bar();
+----
+bar # () #
+####
+local $call_bar = 1;
+&bar;
+----
+bar # () #
+####
+local $call_bar = 1;
+&bar(3);
+----
+bar # () #
+####
+local $call_bar = 1;
+my $bar = \&bar;
+$bar->();
+----
+bar # () #
+####
+local $call_bar = 1;
+my $bar = \&bar;
+&$bar;
+----
+bar # () #