Get rid of the linestr check
authorVincent Pit <vince@profvince.com>
Mon, 16 Aug 2010 14:38:45 +0000 (16:38 +0200)
committerVincent Pit <vince@profvince.com>
Mon, 16 Aug 2010 14:38:45 +0000 (16:38 +0200)
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.

indirect.xs
t/20-good.t
t/21-bad.t

index 4ce10e5..7f234a0 100644 (file)
 #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
 #  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
@@ -212,11 +200,10 @@ typedef struct {
 
 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
- ptable     *map;
- const char *linestr;
+ ptable *map;
 } 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;
 
- /* 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);
@@ -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;
 
- if (MY_CXT.linestr != SvPVX_const(PL_linestr))
-  return NULL;
-
  return ptable_fetch(MY_CXT.map, o);
 }
 
@@ -827,11 +799,10 @@ STATIC void indirect_setup(pTHX) {
  {
   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
-  MY_CXT.map     = ptable_new();
-  MY_CXT.linestr = NULL;
+  MY_CXT.map   = ptable_new();
  }
 
  indirect_old_ck_const    = PL_check[OP_CONST];
@@ -899,10 +870,9 @@ PPCODE:
  }
  {
   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);
index f883537..12a4a76 100644 (file)
@@ -9,7 +9,7 @@ package main;
 use strict;
 use warnings;
 
-use Test::More tests => 80 * 8;
+use Test::More tests => 74 * 8;
 
 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
 
@@ -241,18 +241,6 @@ $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;
index f4231d7..09157e9 100644 (file)
@@ -11,8 +11,8 @@ use warnings;
 
 my ($tests, $reports);
 BEGIN {
- $tests   = 61;
- $reports = 69;
+ $tests   = 70;
+ $reports = 82;
 }
 
 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;
 
@@ -368,6 +371,38 @@ Hlagh->new(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', '{' ]
@@ -404,3 +439,7 @@ meh { feh $y; 1; };
 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', '{' ]