From: Vincent Pit <vince@profvince.com>
Date: Tue, 5 Mar 2013 01:06:04 +0000 (-0300)
Subject: In string-like envs, take the position to the beginning of the string
X-Git-Tag: rt83659
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=10a40810426cc0b9d09492d30e273950b0434a73;p=perl%2Fmodules%2Findirect.git

In string-like envs, take the position to the beginning of the string

This fixes RT #83659.
---

diff --git a/MANIFEST b/MANIFEST
index b86e31a..df8b4e5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -38,6 +38,10 @@ t/lib/indirect/Test0/Fffff/Vvvvvvv.pm
 t/lib/indirect/Test0/Oooooo/Pppppppp.pm
 t/lib/indirect/Test1/il1.pm
 t/lib/indirect/Test1/il2.pm
+t/lib/indirect/Test2.pm
+t/lib/indirect/Test3.pm
+t/lib/indirect/Test4.pm
+t/lib/indirect/Test5.pm
 t/lib/indirect/TestRequired1.pm
 t/lib/indirect/TestRequired2.pm
 t/lib/indirect/TestRequired3X.pm
diff --git a/indirect.xs b/indirect.xs
index d3d1e00..3257b26 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -75,6 +75,9 @@
 # ifndef PL_oldbufptr
 #  define PL_oldbufptr PL_parser->oldbufptr
 # endif
+# ifndef PL_lex_inwhat
+#  define PL_lex_inwhat PL_parser->lex_inwhat
+# endif
 #else
 # ifndef PL_linestr
 #  define PL_linestr PL_Ilinestr
@@ -85,6 +88,9 @@
 # ifndef PL_oldbufptr
 #  define PL_oldbufptr PL_Ioldbufptr
 # endif
+# ifndef PL_lex_inwhat
+#  define PL_lex_inwhat PL_Ilex_inwhat
+# endif
 #endif
 
 #ifndef I_WORKAROUND_REQUIRE_PROPAGATION
@@ -568,14 +574,23 @@ STATIC int indirect_find(pTHX_ SV *name_sv, const char *line_bufptr, STRLEN *nam
 
  t = line;
  u = t;
- while (t <= p) {
-  STRLEN i = indirect_nextline(t, line_len);
-  if (i >= line_len)
-   break;
-  u         = t;
-  t        += i;
-  line_len -= i;
+
+ /* If we're inside a string-like environment, we don't need to be smart for
+  * finding the positions of the tokens : as the line number will always be
+  * the line where the string began (or at least I hope so), and the line
+  * buffer points to the beginning of the string (likewise), we can just take
+  * the offset in this string as the position. */
+ if (!PL_lex_inwhat) {
+  while (t <= p) {
+   STRLEN i = indirect_nextline(t, line_len);
+   if (i >= line_len)
+    break;
+   u         = t;
+   t        += i;
+   line_len -= i;
+  }
  }
+
  *name_pos = p - u;
 
  return 1;
diff --git a/t/30-scope.t b/t/30-scope.t
index 644c3de..a69b979 100644
--- a/t/30-scope.t
+++ b/t/30-scope.t
@@ -6,7 +6,7 @@ use warnings;
 my $tests;
 BEGIN { $tests = 18 }
 
-use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5;
+use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5 + 4;
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
@@ -15,9 +15,11 @@ use lib 't/lib';
 my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18;
 
 sub expect {
- my ($pkg, $file) = @_;
- $file = $file ? quotemeta $file : '\(eval \d+\)';
- qr/^warn:Indirect call of method "new" on object "$pkg" at $file line \d+/;
+ my ($obj, $file, $prefix) = @_;
+ $obj    = quotemeta $obj;
+ $file   = $file           ? quotemeta $file   : '\(eval \d+\)';
+ $prefix = defined $prefix ? quotemeta $prefix : 'warn:';
+ qr/^${prefix}Indirect call of method "new" on object "$obj" at $file line \d+/;
 }
 
 {
@@ -193,6 +195,31 @@ like $err, qr/^Can't locate object method "new" via package "X"/,
  is_deeply \@w, [ ], 'indirect syntax in eval in sub';
 }
 
+{
+ local $@;
+ eval { require indirect::Test2 };
+ is $@, '', 'direct call in string is not fooled by newlines';
+}
+
+{
+ local $@;
+ eval { require indirect::Test3 };
+ like $@, expect('$x', 't/lib/indirect/Test3.pm', ''),
+          'indirect call in string is not fooled by newlines';
+}
+
+{
+ local $@;
+ eval { require indirect::Test4 };
+ is $@, '', 'direct call in string is not fooled by more newlines';
+}
+
+{
+ local $@;
+ eval { require indirect::Test5 };
+ is $@, '', 'direct call in sort in string is not fooled by newlines';
+}
+
 __DATA__
 my $a = new P1;
 
diff --git a/t/lib/indirect/Test2.pm b/t/lib/indirect/Test2.pm
new file mode 100644
index 0000000..296b66a
--- /dev/null
+++ b/t/lib/indirect/Test2.pm
@@ -0,0 +1,8 @@
+no indirect ":fatal";
+my $x;
+if ($x) {
+my $y = qq{abcdef
+ @{[$x->new]}
+ };
+}
+1;
diff --git a/t/lib/indirect/Test3.pm b/t/lib/indirect/Test3.pm
new file mode 100644
index 0000000..5252be3
--- /dev/null
+++ b/t/lib/indirect/Test3.pm
@@ -0,0 +1,8 @@
+no indirect ":fatal";
+my $x;
+if ($x) {
+my $y = qq{abcdef
+ @{[new $x]}
+ };
+}
+1;
diff --git a/t/lib/indirect/Test4.pm b/t/lib/indirect/Test4.pm
new file mode 100644
index 0000000..baa0c1f
--- /dev/null
+++ b/t/lib/indirect/Test4.pm
@@ -0,0 +1,9 @@
+no indirect ":fatal";
+my $x;
+if ($x) {
+my $y = qq{abcdef
+        @{[$x
+ ->new]}
+ };
+}
+1;
diff --git a/t/lib/indirect/Test5.pm b/t/lib/indirect/Test5.pm
new file mode 100644
index 0000000..c869033
--- /dev/null
+++ b/t/lib/indirect/Test5.pm
@@ -0,0 +1,9 @@
+no indirect ":fatal";
+my $x;
+if ($x) {
+my $y = qq{abcdef
+        @{[sort $x
+ ->new]}
+ };
+}
+1;