From: Vincent Pit <vince@profvince.com>
Date: Tue, 26 Feb 2013 00:16:15 +0000 (-0300)
Subject: Properly set and check the line number of method and object tokens
X-Git-Tag: rt83450^0
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=502e3aac65b9da2d9a22dbc91995e0b68221f6bb;p=perl%2Fmodules%2Findirect.git

Properly set and check the line number of method and object tokens

This fixes RT #83450.
---

diff --git a/indirect.xs b/indirect.xs
index f36c179..8ff064b 100644
--- a/indirect.xs
+++ b/indirect.xs
@@ -479,11 +479,27 @@ STATIC void indirect_map_delete(pTHX_ const OP *o) {
 
 /* --- Check functions ----------------------------------------------------- */
 
+STATIC STRLEN indirect_nextline(const char *s, STRLEN len) {
+ STRLEN i;
+
+ for (i = 0; i < len; ++i) {
+  if (s[i] == '\n') {
+   ++i;
+   while (i < len && s[i] == '\r')
+    ++i;
+   break;
+  }
+ }
+
+ return i;
+}
+
 STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) {
 #define indirect_find(N, S, P) indirect_find(aTHX_ (N), (S), (P))
  STRLEN len;
- const char *p, *r = SvPV_const(sv, len);
+ const char *p, *r, *t, *u;
 
+ r = SvPV_const(sv, len);
  if (len >= 1 && *r == '$') {
   ++r;
   --len;
@@ -505,7 +521,17 @@ STATIC int indirect_find(pTHX_ SV *sv, const char *s, STRLEN *pos) {
    ++p;
  }
 
- *pos = p - SvPVX_const(PL_linestr);
+ t = SvPV_const(PL_linestr, len);
+ u = t;
+ while (t <= p) {
+  STRLEN i = indirect_nextline(t, len);
+  if (i >= len)
+   break;
+  u    = t;
+  t   += i;
+  len -= i;
+ }
+ *pos = p - u;
 
  return 1;
 }
@@ -784,7 +810,8 @@ STATIC OP *indirect_ck_entersub(pTHX_ OP *o) {
   /* When positions are identical, the method and the object must have the
    * same name. But it also means that it is an indirect call, as "foo->foo"
    * results in different positions. */
-  if (moi->pos <= ooi->pos) {
+  if (   moi->line < ooi->line
+      || (moi->line == ooi->line && moi->pos <= ooi->pos)) {
    SV *file;
    dSP;
 
diff --git a/t/20-good.t b/t/20-good.t
index e04ee9d..d958a13 100644
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -9,7 +9,7 @@ package main;
 use strict;
 use warnings;
 
-use Test::More tests => 101 * 8;
+use Test::More tests => 109 * 8 + 10;
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
@@ -71,6 +71,98 @@ SKIP:
  }
 }
 
+# These tests must be run outside of eval to be meaningful.
+{
+ sub Zlott::Owww::new { }
+
+ my (@warns, $hook, $desc, $id);
+ BEGIN {
+  $hook = sub { push @warns, indirect::msg(@_) };
+  $desc = "test sort and line endings %d: no indirect construct";
+  $id   = 1;
+ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+          ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+               ->new;
+ };
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                 ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                  ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                   ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                     ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                       ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                          ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                            ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+
+ BEGIN { @warns = () }
+ {
+  no indirect hook => $hook;
+  my @stuff = sort Zlott::Owww
+                             ->new;
+ }
+ BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
+}
+
 __DATA__
 
 $obj = Hlagh->new;
@@ -310,3 +402,27 @@ zap { 1; };
 zap { 1; 1; };
 ####
 zap { zap { }; 1; };
+####
+my @stuff = sort Hlagh
+     ->new;
+####
+my @stuff = sort Hlagh
+              ->new;
+####
+my @stuff = sort Hlagh
+               ->new;
+####
+my @stuff = sort Hlagh
+                ->new;
+####
+my @stuff = sort Hlagh
+                 ->new;
+####
+my @stuff = sort Hlagh
+                   ->new;
+####
+my @stuff = sort Hlagh
+                     ->new;
+####
+my @stuff = sort Hlagh
+                        ->new;