[perl #93652] PerlIO::via does not create a new dynamic scope for $1

# New Ticket Created by  perlbug@spamwagon.com 
# Please include the string:  [perl #93652]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=93652 >


This is a bug report for perl from perlbug@spamwagon.com,
generated with the help of perlbug 1.39 running under perl 5.12.3.


-----------------------------------------------------------------
When PerlIO::via runs the WRITE stack (or possibly any stack),
it does not appear to create a new dynamic scope for each layer
method called.  Modifying the global regular expression match
variables like $1 in a lower IO layer can cause $1 to have an
unexpected value in the IO layer above.

Consider the following example.  Both PerlIO::via::RegexBug and
PerlIO::via::RegexBugWorkaround perform the same function.  They
iterate through the supplied $buffer character by character and
print a space before each one.  PerlIO::via::RegexBugWorkaround
preserved the value of $1 in a lexical variable while calling into
the lower layer to print the space, while PerlIO::via::RegexBug
relies on $1's value to remain the same over the call to
    print $fh ' ';

PerlIO::via::RegexBugWorkaround can be layered as expected, and
produces output prepended with one or two spaces, depending on
how many times it's been pushed onto the stack.

PerlIO::via::RegexBug works fine when pushed once.  When pushed
twice, the value of $1 changes over the "print $fh ' ';" call,
as the lower instance of PerlIO::via::RegexBug matched a space
against the ' ' string.


package PerlIO::via::RegexBug;
use strict;

sub PUSHED {
  my ($class, $mode, $fh) = @_;

  return bless {}, $class;
}

sub WRITE {
  my ($this, $buffer, $fh) = @_;
  my $len = length $buffer;
  while ($buffer =~ m/\G(.)/gs) {
    my $c = $1;
    print $fh ' ';
    if ($c ne $1) {
      die "Invalid output char expected:'$c' got:'$1'\n";
    }
    print $fh $1;
  }
  $len;
}

1;

package PerlIO::via::RegexBugWorkaround;
use strict;

sub PUSHED {
  my ($class, $mode, $fh) = @_;

  return bless {}, $class;
}

sub WRITE {
  my ($this, $buffer, $fh) = @_;
  my $len = length $buffer;
  while ($buffer =~ m/\G(.)/gs) {
    my $c = $1;
    print $fh ' ';
    print $fh $c;
  }
  $len;
}

1;


package main;

my @lines = <DATA>;
my $out = \*STDOUT;

Header('NORMAL');
TestOutput($out);

Header('WITH 1xRegexBugWorkaround');
binmode $out, ":via(RegexBugWorkaround)";
TestOutput($out);

Header('WITH 2xRegexBugWorkaround');
binmode $out, ":via(RegexBugWorkaround)";
TestOutput($out);

binmode $out, ":pop";
binmode $out, ":pop";


Header('NORMAL');
TestOutput($out);

Header('WITH 1xRegexBug');
binmode $out, ":via(RegexBug)";
TestOutput($out);

Header('WITH 2xRegexBug');
binmode $out, ":via(RegexBug)";
TestOutput($out);

sub Header {
  print STDERR "="x40,"\n";
  print STDERR "="x4," ",@_,"\n";
  print STDERR "="x40,"\n";
}

sub TestOutput {
  my $out = shift;
  foreach (@lines) {
    print $out $_;
  }
}

__DATA__
This is some text
which may match
isnt that fun

[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=low
---
Site configuration information for perl 5.12.3:

Configured by 1 at Sun May 15 16:53:01 2011.

Summary of my perl5 (revision 5 version 12 subversion 3) configuration:
  
  Platform:
    osname=MSWin32, osvers=5.1, archname=MSWin32-x86-multi-thread
    uname='Win32 strawberryperl 5.12.3.0 #1 Sun May 15 09:44:53 2011 i386'
    config_args='undef'
    hint=recommended, useposix=true, d_sigaction=undef
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=undef, use64bitall=undef, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='gcc', ccflags =' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT 
-DUSE_SITECUSTOMIZE -DPERL_IMPLICIT_CONTEXT -DPERL_IMPLICIT_SYS
-fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX',
    optimize='-s -O2',
    cppflags='-DWIN32'
    ccversion='', gccversion='4.4.3', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=undef, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='long
long', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='g++', ldflags ='-s -L"C:\strawberry\perl\lib\CORE"
-L"C:\strawberry\c\lib"'
    libpth=C:\strawberry\c\lib C:\strawberry\c\i686-w64-mingw32\lib
    libs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32
-ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr
-lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    perllibs=-lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool
-lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid
-lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32 -lcomctl32
    libc=, so=dll, useshrplib=true, libperl=libperl512.a
    gnulibc_version=''
  Dynamic Linking:
    dlsrc=dl_win32.xs, dlext=dll, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags='-mdll -s -L"C:\strawberry\perl\lib\CORE"
-L"C:\strawberry\c\lib"'

Locally applied patches:
   

---
@INC for perl 5.12.3:
    C:/strawberry/perl/site/lib
    C:/strawberry/perl/vendor/lib
    C:/strawberry/perl/lib
    .

---
Environment for perl 5.12.3:
    HOME=C:\users\Jerbraun
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=C:\strawberry\perl\bin
    PERLDOC=-n "groff.exe -E -mtty-char -Tascii -P-c"
    PERL_BADLANG (unset)
    PERL_JSON_BACKEND=JSON::XS
    PERL_YAML_BACKEND=YAML
    SHELL (unset)

• [perl #93652] PerlIO::via does not create a new dynamic scope for $1 by perlbug @ spamwagon . com