From: Vincent Pit <vince@profvince.com>
Date: Thu, 7 May 2009 23:17:56 +0000 (+0200)
Subject: Also pass the file and the line number to the hook
X-Git-Tag: v0.13~10
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=commitdiff_plain;h=cfbd22399e253cbac1aad5436d2b191082befe14

Also pass the file and the line number to the hook

So that we can warn or die with the correct error message. This is required because caller() can't be trusted at compile time.
---

diff --git a/indirect.xs b/indirect.xs
index f3aa14b..b9314ae 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -35,6 +35,10 @@
 # define sv_catpvn_nomg sv_catpvn
 #endif
 
+#ifndef mPUSHu
+# define mPUSHu(U) PUSHs(sv_2mortal(newSVuv(U)))
+#endif
+
 #ifndef HvNAME_get
 # define HvNAME_get(H) HvNAME(H)
 #endif
@@ -513,17 +517,29 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
    SV *code = indirect_detag(hint);
 
    if (hint) {
+    SV     *file;
+    line_t  line;
     dSP;
+
     onamesv = sv_mortalcopy(onamesv);
     mnamesv = sv_mortalcopy(mnamesv);
 
+#ifdef USE_ITHREADS
+    file = newSVpv(CopFILE(&PL_compiling), 0);
+#else
+    file = sv_mortalcopy(CopFILESV(&PL_compiling));
+#endif
+    line = CopLINE(&PL_compiling);
+
     ENTER;
     SAVETMPS;
 
     PUSHMARK(SP);
-    EXTEND(SP, 2);
+    EXTEND(SP, 4);
     PUSHs(onamesv);
     PUSHs(mnamesv);
+    PUSHs(file);
+    mPUSHu(line);
     PUTBACK;
 
     call_sv(code, G_VOID);
diff --git a/lib/indirect.pm b/lib/indirect.pm
index 1b7b0e0..bad02f4 100644
--- a/lib/indirect.pm
+++ b/lib/indirect.pm
@@ -76,7 +76,7 @@ If it's the string C<':fatal'>, the compilation will croak on the first indirect
 
 =item *
 
-If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with the object name as C<$_[0]> and the method name as C<$_[1]>.
+If the key/value pair C<< hook => $hook >> comes first, C<$hook> will be called for each error with the object name as C<$_[0]>, the method name as C<$_[1]>, the current file as C<$_[2]> and the line number as C<$_[3]>.
 
 =item *
 
@@ -86,7 +86,9 @@ Otherwise, a warning will be emitted for each indirect construct.
 
 =cut
 
-my $msg = sub { "Indirect call of method \"$_[1]\" on object \"$_[0]\"" };
+my $msg = sub {
+ "Indirect call of method \"$_[1]\" on object \"$_[0]\" at $_[2] line $_[3].\n"
+};
 
 sub unimport {
  shift;
diff --git a/t/10-args.t b/t/10-args.t
index 4db490c..bb44e97 100644
--- a/t/10-args.t
+++ b/t/10-args.t
@@ -7,7 +7,7 @@ use Test::More tests => 4 + 1 + 1;
 
 sub expect {
  my ($pkg) = @_;
- return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"/;
+ return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+\d+/;
 }
 
 {
@@ -46,5 +46,5 @@ HERE
   my $x = new Hooked;
   $x = new AlsoNotReached;
 HERE
- is $@, "hook:Hooked:new\n", 'calls the specified hook';
+ like $@, qr/^hook:Hooked:new:\(eval\s+\d+\):\d+$/, 'calls the specified hook';
 }
diff --git a/t/21-bad.t b/t/21-bad.t
index c480d6c..3b9985f 100644
--- a/t/21-bad.t
+++ b/t/21-bad.t
@@ -16,7 +16,12 @@ our ($y, $bloop);
 
 sub expect {
  my ($pkg) = @_;
- return qr/^warn:Indirect call of method "(?:new|meh|$pkg$pkg)" on object "(?:$pkg|newnew|\$(?:[xyz_\$]|(?:sploosh::)?sploosh|(?:main::)?bloop))"/
+ qr/^warn:Indirect\s+call\s+of\s+method\s+
+     "(?:new|meh|$pkg$pkg)"
+     \s+on\s+object\s+
+     "(?:$pkg|newnew|\$(?:[xyz_\$]|(?:sploosh::)?sploosh|(?:main::)?bloop))"
+     \s+at\s+\(eval\s+\d+\)\s+line\s+\d+
+   /x
 }
 
 {
diff --git a/t/22-bad-mixed.t b/t/22-bad-mixed.t
index 8cc0931..4462bf6 100644
--- a/t/22-bad-mixed.t
+++ b/t/22-bad-mixed.t
@@ -42,7 +42,7 @@ SKIP:
    is($@, "ok\n", "use indirect, defined: $_");
 
    eval "die qq{the code compiled but it shouldn't have\n}; $prefix; no indirect; $_";
-   like($@, qr/^warn:Indirect\s+call\s+of\s+method\s+"meh"\s+on\s+object\s+"Dongs"/, "no indirect, defined: $_");
+   like($@, qr/^warn:Indirect\s+call\s+of\s+method\s+"meh"\s+on\s+object\s+"Dongs"\s+at\s+\(eval\s+\d+\)\s+line\s+\d+/, "no indirect, defined: $_");
   }
  }
 }
diff --git a/t/30-scope.t b/t/30-scope.t
index 1e1dcf3..f769de6 100644
--- a/t/30-scope.t
+++ b/t/30-scope.t
@@ -12,7 +12,7 @@ my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18;
 
 sub expect {
  my ($pkg) = @_;
- return qr/^warn:Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"/;
+ return qr/^warn:Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+\d+/;
 }
 
 {
diff --git a/t/40-threads.t b/t/40-threads.t
index 14fb8b2..ce8ff03 100644
--- a/t/40-threads.t
+++ b/t/40-threads.t
@@ -29,7 +29,7 @@ BEGIN {
 
 sub expect {
  my ($pkg) = @_;
- return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"/;
+ return qr/^Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+\(eval\s+\d+\)\s+line\s+\d+/;
 }
 
 {