]> git.vpit.fr Git - perl/modules/indirect.git/commitdiff
Also pass the file and the line number to the hook
authorVincent Pit <vince@profvince.com>
Thu, 7 May 2009 23:17:56 +0000 (01:17 +0200)
committerVincent Pit <vince@profvince.com>
Thu, 7 May 2009 23:17:56 +0000 (01:17 +0200)
So that we can warn or die with the correct error message. This is required because caller() can't be trusted at compile time.

indirect.xs
lib/indirect.pm
t/10-args.t
t/21-bad.t
t/22-bad-mixed.t
t/30-scope.t
t/40-threads.t

index f3aa14b4ce3c11f009c3d7b79d6d7b3fa2b4bb5e..b9314ae60a2e92298ff50c63a2c8029373f93a5c 100644 (file)
 # 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);
index 1b7b0e059a98436c4fac086c94a4899b2614293e..bad02f4e72dcc6962741141a05baca5d100f7162 100644 (file)
@@ -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;
index 4db490cd408f9dbfdd8e820fd8491de5ee0ea271..bb44e978fb1e346c02e01bd9db1f01f7c171e884 100644 (file)
@@ -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';
 }
index c480d6c0a4720dca3a614caab688f33a6ba5da55..3b9985f21729d0c0cf766d70a3b91f68cdb26020 100644 (file)
@@ -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
 }
 
 {
index 8cc0931aa9c28fd53f25a01ad702d05d49de7e5c..4462bf661462a53a5219d7e63661b46b932a7c30 100644 (file)
@@ -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: $_");
   }
  }
 }
index 1e1dcf3d8fe7c2123521fc89cb70e6c3e3467da4..f769de66fe59e2d721e0a82671d76aea7c01c69e 100644 (file)
@@ -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+/;
 }
 
 {
index 14fb8b25e878b13cfbc87856cac240e524882dd4..ce8ff03d9b4ce454a2186688ea8f273080a9058d 100644 (file)
@@ -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+/;
 }
 
 {