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 f3aa14b4ce3c11f009c3d7b79d6d7b3fa2b4bb5e..b9314ae60a2e92298ff50c63a2c8029373f93a5c 100644 (file)
--- a/indirect.xs
+++ b/indirect.xs
@@ -35,6 +35,10 @@
 # define sv_catpvn_nomg sv_catpvn
 #endif
 
 # 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
 #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 *code = indirect_detag(hint);
 
    if (hint) {

+    SV     *file;
+    line_t  line;

     dSP;
     dSP;

+

     onamesv = sv_mortalcopy(onamesv);
     mnamesv = sv_mortalcopy(mnamesv);
 
     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);
     ENTER;
     SAVETMPS;
 
     PUSHMARK(SP);

-    EXTEND(SP, 2);
+    EXTEND(SP, 4);

     PUSHs(onamesv);
     PUSHs(mnamesv);
     PUSHs(onamesv);
     PUSHs(mnamesv);

+    PUSHs(file);
+    mPUSHu(line);

     PUTBACK;
 
     call_sv(code, G_VOID);
     PUTBACK;
 
     call_sv(code, G_VOID);

diff --git a/lib/indirect.pm b/lib/indirect.pm
index 1b7b0e059a98436c4fac086c94a4899b2614293e..bad02f4e72dcc6962741141a05baca5d100f7162 100644 (file)
--- 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 *
 
 
 =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 *
 
 
 =item *
 


@@ -86,7 +86,9 @@ Otherwise, a warning will be emitted for each indirect construct.
 
 =cut
 
 
 =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;
 
 sub unimport {
  shift;

diff --git a/t/10-args.t b/t/10-args.t
index 4db490cd408f9dbfdd8e820fd8491de5ee0ea271..bb44e978fb1e346c02e01bd9db1f01f7c171e884 100644 (file)
--- 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) = @_;
 
 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
   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 c480d6c0a4720dca3a614caab688f33a6ba5da55..3b9985f21729d0c0cf766d70a3b91f68cdb26020 100644 (file)
--- a/t/21-bad.t
+++ b/t/21-bad.t
@@ -16,7 +16,12 @@ our ($y, $bloop);
 
 sub expect {
  my ($pkg) = @_;
 
 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 8cc0931aa9c28fd53f25a01ad702d05d49de7e5c..4462bf661462a53a5219d7e63661b46b932a7c30 100644 (file)
--- 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; $_";
    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 1e1dcf3d8fe7c2123521fc89cb70e6c3e3467da4..f769de66fe59e2d721e0a82671d76aea7c01c69e 100644 (file)
--- 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) = @_;
 
 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 14fb8b25e878b13cfbc87856cac240e524882dd4..ce8ff03d9b4ce454a2186688ea8f273080a9058d 100644 (file)
--- a/t/40-threads.t
+++ b/t/40-threads.t
@@ -29,7 +29,7 @@ BEGIN {
 
 sub expect {
  my ($pkg) = @_;
 
 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+/;

 }
 
 {
 }
 
 {