Get rid of the linestr check

It simplifies the code, remove some potential breakage if the linestr
changes inside an indirect expression, and allows for reporting indirect
constructs in quotelike environments.

diff --git a/indirect.xs b/indirect.xs
index 4ce10e59ce0dc8fae193abf93f0f81aa471bc3ba..7f234a09037e04a72ab23c8a5f849713247c0f99 100644 (file)
--- a/indirect.xs
+++ b/indirect.xs
@@ -62,12 +62,6 @@
 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
 
 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)
 #define I_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
 
 #if I_HAS_PERL(5, 10, 0) || defined(PL_parser)

-# ifndef PL_lex_inwhat
-#  define PL_lex_inwhat PL_parser->lex_inwhat
-# endif
-# ifndef PL_linestr
-#  define PL_linestr PL_parser->linestr
-# endif

 # ifndef PL_bufptr
 #  define PL_bufptr PL_parser->bufptr
 # endif
 # ifndef PL_bufptr
 #  define PL_bufptr PL_parser->bufptr
 # endif


@@ -75,12 +69,6 @@
 #  define PL_oldbufptr PL_parser->oldbufptr
 # endif
 #else
 #  define PL_oldbufptr PL_parser->oldbufptr
 # endif
 #else

-# ifndef PL_lex_inwhat
-#  define PL_lex_inwhat PL_Ilex_inwhat
-# endif
-# ifndef PL_linestr
-#  define PL_linestr PL_Ilinestr
-# endif

 # ifndef PL_bufptr
 #  define PL_bufptr PL_Ibufptr
 # endif
 # ifndef PL_bufptr
 #  define PL_bufptr PL_Ibufptr
 # endif


@@ -212,11 +200,10 @@ typedef struct {
 
 typedef struct {
 #if I_THREADSAFE
 
 typedef struct {
 #if I_THREADSAFE

- ptable     *tbl; /* It really is a ptable_hints */
- tTHX        owner;
+ ptable *tbl; /* It really is a ptable_hints */
+ tTHX    owner;

 #endif
 #endif

- ptable     *map;
- const char *linestr;
+ ptable *map;

 } my_cxt_t;
 
 START_MY_CXT
 } my_cxt_t;
 
 START_MY_CXT


@@ -422,18 +409,6 @@ STATIC void indirect_map_store(pTHX_ const OP *o, const char *src, SV *sv, line_
  STRLEN len;
  dMY_CXT;
 
  STRLEN len;
  dMY_CXT;
 

- /* When lex_inwhat is set, we're in a quotelike environment (qq, qr, but not q)
-  * In this case the linestr has temporarly changed, but the old buffer should
-  * still be alive somewhere. */
-
- if (!PL_lex_inwhat) {
-  const char *pl_linestr = SvPVX_const(PL_linestr);
-  if (MY_CXT.linestr != pl_linestr) {
-   ptable_clear(MY_CXT.map);
-   MY_CXT.linestr = pl_linestr;
-  }
- }
-

  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
   Newx(oi, 1, indirect_op_info_t);
   ptable_store(MY_CXT.map, o, oi);
  if (!(oi = ptable_fetch(MY_CXT.map, o))) {
   Newx(oi, 1, indirect_op_info_t);
   ptable_store(MY_CXT.map, o, oi);


@@ -464,9 +439,6 @@ STATIC const indirect_op_info_t *indirect_map_fetch(pTHX_ const OP *o) {
 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
  dMY_CXT;
 
 #define indirect_map_fetch(O) indirect_map_fetch(aTHX_ (O))
  dMY_CXT;
 

- if (MY_CXT.linestr != SvPVX_const(PL_linestr))
-  return NULL;
-

  return ptable_fetch(MY_CXT.map, o);
 }
 
  return ptable_fetch(MY_CXT.map, o);
 }
 


@@ -827,11 +799,10 @@ STATIC void indirect_setup(pTHX) {
  {
   MY_CXT_INIT;
 #if I_THREADSAFE
  {
   MY_CXT_INIT;
 #if I_THREADSAFE

-  MY_CXT.tbl     = ptable_new();
-  MY_CXT.owner   = aTHX;
+  MY_CXT.tbl   = ptable_new();
+  MY_CXT.owner = aTHX;

 #endif
 #endif

-  MY_CXT.map     = ptable_new();
-  MY_CXT.linestr = NULL;
+  MY_CXT.map   = ptable_new();

  }
 
  indirect_old_ck_const    = PL_check[OP_CONST];
  }
 
  indirect_old_ck_const    = PL_check[OP_CONST];


@@ -899,10 +870,9 @@ PPCODE:
  }
  {
   MY_CXT_CLONE;
  }
  {
   MY_CXT_CLONE;

-  MY_CXT.map     = ptable_new();
-  MY_CXT.linestr = NULL;
-  MY_CXT.tbl     = t;
-  MY_CXT.owner   = aTHX;
+  MY_CXT.map   = ptable_new();
+  MY_CXT.tbl   = t;
+  MY_CXT.owner = aTHX;

  }
  reap(3, indirect_thread_cleanup, NULL);
  XSRETURN(0);
  }
  reap(3, indirect_thread_cleanup, NULL);
  XSRETURN(0);

diff --git a/t/20-good.t b/t/20-good.t
index f883537209281af88d55b32ce0e2bde45a3ed6d6..12a4a76bb6b5adcddd4bdceba487f8ced4120cc5 100644 (file)
--- a/t/20-good.t
+++ b/t/20-good.t
@@ -9,7 +9,7 @@ package main;
 use strict;
 use warnings;
 
 use strict;
 use warnings;
 

-use Test::More tests => 80 * 8;
+use Test::More tests => 74 * 8;

 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 


@@ -241,18 +241,6 @@ $obj = "apple ${\($y->$meth)} pear"
 ####
 $obj = "apple @{[$y->$meth]} pear"
 ####
 ####
 $obj = "apple @{[$y->$meth]} pear"
 ####

-$obj = "apple ${\(new Hlagh)} pear"
-####
-$obj = "apple @{[new Hlagh]} pear"
-####
-$obj = "apple ${\(new $x)} pear"
-####
-$obj = "apple @{[new $x]} pear"
-####
-$obj = "apple ${\(new $y)} pear"
-####
-$obj = "apple @{[new $y]} pear"
-####

 exec $x $x, @a;
 ####
 exec { $a[0] } @a;
 exec $x $x, @a;
 ####
 exec { $a[0] } @a;

diff --git a/t/21-bad.t b/t/21-bad.t
index f4231d72ae1517d3a23fd2c7e1f3186c8ff35126..09157e98c66d668630eaab0699b58f3e09fee44f 100644 (file)
--- a/t/21-bad.t
+++ b/t/21-bad.t
@@ -11,8 +11,8 @@ use warnings;
 
 my ($tests, $reports);
 BEGIN {
 
 my ($tests, $reports);
 BEGIN {

- $tests   = 61;
- $reports = 69;
+ $tests   = 70;
+ $reports = 82;

 }
 
 use Test::More tests => 3 * (4 * $tests + $reports) + 4;
 }
 
 use Test::More tests => 3 * (4 * $tests + $reports) + 4;


@@ -98,7 +98,10 @@ SKIP:
     }
    }
 
     }
    }
 

+SKIP:

    {
    {

+    skip 'No space tests on perl 5.11' => 4 + @expected
+                                                  if $] >= 5.011 and $] < 5.012;

     my $code = $code;
     $code =~ s/\$/\$ \n\t /g;
 
     my $code = $code;
     $code =~ s/\$/\$ \n\t /g;
 


@@ -368,6 +371,38 @@ Hlagh->new(meh $x)
 ----
 [ 'meh', '$x' ]
 ####
 ----
 [ 'meh', '$x' ]
 ####

+$obj = "apple ${\(new Hlagh)} pear"
+----
+[ 'new', 'Hlagh' ]
+####
+$obj = "apple @{[new Hlagh]} pear"
+----
+[ 'new', 'Hlagh' ]
+####
+$obj = "apple ${\(new $x)} pear"
+----
+[ 'new', '$x' ]
+####
+$obj = "apple @{[new $x]} pear"
+----
+[ 'new', '$x' ]
+####
+$obj = "apple ${\(new $y)} pear"
+----
+[ 'new', '$y' ]
+####
+$obj = "apple @{[new $y]} pear"
+----
+[ 'new', '$y' ]
+####
+$obj = "apple ${\(new $x qq|${\(stuff $y)}|)} pear"
+----
+[ 'stuff', '$y' ], [ 'new', '$x' ]
+####
+$obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear"
+----
+[ 'stuff', '$y' ], [ 'new', '$x' ]
+####

 meh { };
 ----
 [ 'meh', '{' ]
 meh { };
 ----
 [ 'meh', '{' ]


@@ -404,3 +439,7 @@ meh { feh $y; 1; };
 meh { feh $x; 1; } new Hlagh, feh $y;
 ----
 [ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]
 meh { feh $x; 1; } new Hlagh, feh $y;
 ----
 [ 'feh', '$x' ], [ 'new', 'Hlagh' ], [ 'feh', '$y' ], [ 'meh', '{' ]

+####
+$obj = "apple @{[new { feh $x; meh $y; 1 }]} pear"
+----
+[ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ]