[perl #36473] s/PATTERN/func()/em leaks /m into func().

0 views
Skip to first unread message

Abigail @ Abigail . Nl

unread,
Jul 6, 2005, 6:34:33 PM7/6/05
to bugs-bi...@rt.perl.org
# New Ticket Created by abi...@abigail.nl
# Please include the string: [perl #36473]
# in the subject line of all future correspondence about this issue.
# <URL: https://rt.perl.org/rt3/Ticket/Display.html?id=36473 >

This is a bug report for perl from abi...@abigail.nl,
generated with the help of perlbug 1.35 running under perl v5.8.7.


-----------------------------------------------------------------
[Please enter your report here]

The following subroutine returns its argument with any leading newlines
removed:

sub xxx {
my $s = shift;
$s =~ s/^\n+//;
$s;
}

However, if this function is called from the replacement part of
a s///em, the /m semantics is carried over, and internal newlines
will be deleted.

I've confirmed the bug to be present in 5.000, 5.004_0[45], 5.005_0x,
5.6.x and 5.8.x, including 5.8.7. However, the bug isn't present in
any of the 5.9.x versions of perl.

Full test:

#!/usr/bin/perl

use strict;
use warnings;
no warnings qw /syntax/;

use Test::More tests => 1;

#
# Delete any leading newlines.
#
sub xxx {
my $s = shift;
$s =~ s/^\n+//;
$s;
}

my $a = "A\n\nB"; $a =~ s/([\s\w]+)/xxx $1/e;
my $b = "A\n\nB"; $b =~ s/([\s\w]+)/xxx $1/em;

is ($b, $a);

__END__

1..1
not ok 1
# Failed test (eep at line 21)
# got: 'A
# B'
# expected: 'A
#
# B'
# Looks like you failed 1 test of 1.


[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
category=core
severity=medium
---
Site configuration information for perl v5.8.7:

Configured by abigail at Wed Jun 1 21:50:09 CEST 2005.

Summary of my perl5 (revision 5 version 8 subversion 7) configuration:
Platform:
osname=linux, osvers=2.4.18-bf2.4, archname=i686-linux-64int-ld
uname='linux alexandra 2.4.18-bf2.4 #1 son apr 14 09:53:28 cest 2002 i686 unknown '
config_args='-des -Dusemorebits -Uversiononly -Dmydomain=.abigail.nl -Dcf_email=abi...@abigail.nl -Dperladmin=abi...@abigail.nl -Doptimize=-g -Dcc=gcc -Dprefix=/opt/perl'
hint=recommended, useposix=true, d_sigaction=define
usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
use64bitint=define use64bitall=undef uselongdouble=define
usemymalloc=n, bincompat5005=undef
Compiler:
cc='gcc', ccflags ='-DDEBUGGING -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-g',
cppflags='-DDEBUGGING -fno-strict-aliasing -pipe -I/usr/local/include'
ccversion='', gccversion='3.0.4', gccosandvers=''
intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=12345678
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
ivtype='long long', ivsize=8, nvtype='long double', nvsize=12, Off_t='off_t', lseeksize=8
alignbytes=4, prototype=define
Linker and Libraries:
ld='gcc', ldflags =' -L/usr/local/lib'
libpth=/usr/local/lib /lib /usr/lib
libs=-lnsl -ldl -lm -lcrypt -lutil -lc
perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
libc=/lib/libc-2.2.5.so, so=so, useshrplib=false, libperl=libperl.a
gnulibc_version='2.2.5'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
no-syntax-warnings
defined-or

---
@INC for perl v5.8.7:
/home/abigail/Perl
/opt/perl/lib/5.8.7/i686-linux-64int-ld
/opt/perl/lib/5.8.7
/opt/perl/lib/site_perl/5.8.7/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.7
/opt/perl/lib/site_perl/5.8.6/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.6
/opt/perl/lib/site_perl/5.8.5/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.5
/opt/perl/lib/site_perl/5.8.4/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.4
/opt/perl/lib/site_perl/5.8.3/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.3
/opt/perl/lib/site_perl/5.8.2/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.2
/opt/perl/lib/site_perl/5.8.1/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.1
/opt/perl/lib/site_perl/5.8.0/i686-linux-64int-ld
/opt/perl/lib/site_perl/5.8.0
/opt/perl/lib/site_perl
.

---
Environment for perl v5.8.7:
HOME=/home/abigail
LANG=C
LANGUAGE (unset)
LD_LIBRARY_PATH=/home/abigail/Lib:/usr/local/lib:/usr/lib:/lib:/usr/X11R6/lib
LOGDIR (unset)
PATH=/home/abigail/Bin:/opt/perl/bin:/usr/local/bin:/usr/local/X11/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin:/usr/X11R6/bin:/usr/games:/usr/share/texmf/bin:/opt/Acrobat/bin:/opt/java/blackdown/j2sdk1.3.1/bin:/usr/local/games/bin
PERL5LIB=/home/abigail/Perl
PERLDIR=/opt/perl
PERL_BADLANG (unset)
SHELL=/bin/bash

Yitzchak Scott-Thoennes

unread,
Jul 7, 2005, 6:24:43 PM7/7/05
to perl5-...@perl.org
On Wed, Jul 06, 2005 at 10:34:33PM -0000, abigail @ abigail. nl wrote:
> I've confirmed the bug to be present in 5.000, 5.004_0[45], 5.005_0x,
> 5.6.x and 5.8.x, including 5.8.7. However, the bug isn't present in
> any of the 5.9.x versions of perl.

I think this was fixed by the removal of the long-deprecated $*.

Rick Delaney

unread,
Jul 7, 2005, 11:34:43 PM7/7/05
to perl5-...@perl.org

Not exactly. Change 23471 for bug 3038 fixed this by eliminating some
unnecessary internal reliance on $* in pp_match and pp_subst. It also
eliminated $* as a bonus. The following patch against 5.8.7 lacks the
bonus so should be appropriate for maint. At least, $* still appears to
affect matches but this bug (and 3038) are fixed.

--
Rick Delaney
ri...@bort.ca


diff -ruN perl-5.8.7/pp.c perl-5.8.7.new/pp.c
--- perl-5.8.7/pp.c 2005-05-16 11:30:13.000000000 -0400
+++ perl-5.8.7.new/pp.c 2005-07-07 22:28:44.847094626 -0400
@@ -4544,6 +4544,7 @@
I32 gimme = GIMME_V;
I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
+ bool multiline = 0;
MAGIC *mg = (MAGIC *) NULL;

#ifdef DEBUGGING
@@ -4609,9 +4610,8 @@
s++;
}
}
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
+ if (pm->op_pmflags & PMf_MULTILINE) {
+ multiline = 1;
}

if (!limit)
@@ -4690,7 +4690,7 @@
#ifndef lint
while (s < strend && --limit &&
(m = fbm_instr((unsigned char*)s, (unsigned char*)strend,
- csv, PL_multiline ? FBMrf_MULTILINE : 0)) )
+ csv, multiline ? FBMrf_MULTILINE : 0)) )
#endif
{
dstr = newSVpvn(s, m-s);
diff -ruN perl-5.8.7/pp_hot.c perl-5.8.7.new/pp_hot.c
--- perl-5.8.7/pp_hot.c 2005-04-22 10:12:27.000000000 -0400
+++ perl-5.8.7.new/pp_hot.c 2005-07-07 22:25:15.124509234 -0400
@@ -1309,11 +1309,6 @@
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;

- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
-
play_it_again:
if (global && rx->startp[0] != -1) {
t = s = rx->endp[0] + truebase;
@@ -2062,10 +2057,6 @@
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
PL_bostr = orig;
diff -ruN perl-5.8.7/regexec.c perl-5.8.7.new/regexec.c
--- perl-5.8.7/regexec.c 2005-04-22 07:10:05.000000000 -0400
+++ perl-5.8.7.new/regexec.c 2005-07-07 21:30:30.322133410 -0400
@@ -408,6 +408,7 @@
I32 ml_anch;
register char *other_last = Nullch; /* other substr checked before this */
char *check_at = Nullch; /* check substr found at this pos */
+ const I32 multiline = PL_multiline | (prog->reganch & PMf_MULTILINE);
#ifdef DEBUGGING
char *i_strpos = strpos;
SV *dsv = PERL_DEBUG_PAD_ZERO(0);
@@ -469,7 +470,7 @@
if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
|| ( (prog->reganch & ROPT_ANCH_BOL)
- && !PL_multiline ) ); /* Check after \n? */
+ && !multiline ) ); /* Check after \n? */

if (!ml_anch) {
if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
@@ -563,11 +564,11 @@
else if (prog->reganch & ROPT_CANY_SEEN)
s = fbm_instr((U8*)(s + start_shift),
(U8*)(strend - end_shift),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);
else
s = fbm_instr(HOP3(s, start_shift, strend),
HOP3(strend, -end_shift, strbeg),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);

/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
@@ -636,7 +637,7 @@
HOP3(HOP3(last1, prog->anchored_offset, strend)
+ SvCUR(must), -(SvTAIL(must)!=0), strbeg),
must,
- PL_multiline ? FBMrf_MULTILINE : 0
+ multiline ? FBMrf_MULTILINE : 0
);
DEBUG_r(PerlIO_printf(Perl_debug_log,
"%s anchored substr `%s%.*s%s'%s",
@@ -697,7 +698,7 @@
s = fbm_instr((unsigned char*)s,
(unsigned char*)last + SvCUR(must)
- (SvTAIL(must)!=0),
- must, PL_multiline ? FBMrf_MULTILINE : 0);
+ must, multiline ? FBMrf_MULTILINE : 0);
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
(s ? "Found" : "Contradicts"),
PL_colors[0],
@@ -1633,6 +1634,7 @@
char *scream_olds;
SV* oreplsv = GvSV(PL_replgv);
bool do_utf8 = DO_UTF8(sv);
+ const I32 multiline = PL_multiline | (prog->reganch & PMf_MULTILINE);
#ifdef DEBUGGING
SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
@@ -1749,7 +1751,7 @@
if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
if (s == startpos && regtry(prog, startpos))
goto got_it;
- else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+ else if (multiline || (prog->reganch & ROPT_IMPLICIT)
|| (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
{
char *end;
@@ -1883,7 +1885,7 @@
end_shift, &scream_pos, 0))
: (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
(unsigned char*)strend, must,
- PL_multiline ? FBMrf_MULTILINE : 0))) ) {
+ multiline ? FBMrf_MULTILINE : 0))) ) {
/* we may be pointing at the wrong string */
if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX(sv));
@@ -1984,7 +1986,7 @@
if (SvTAIL(float_real)) {
if (memEQ(strend - len + 1, little, len - 1))
last = strend - len + 1;
- else if (!PL_multiline)
+ else if (!multiline)
last = memEQ(strend - len, little, len)
? strend - len : Nullch;
else
diff -ruN perl-5.8.7/t/op/regexp.t perl-5.8.7.new/t/op/regexp.t
--- perl-5.8.7/t/op/regexp.t 2001-10-27 14:09:24.000000000 -0400
+++ perl-5.8.7.new/t/op/regexp.t 2005-07-07 22:54:14.199458020 -0400
@@ -49,6 +49,7 @@
$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
$ffff = chr(0xff) x 2;
$nulnul = "\0" x 2;
+$OP = $qr ? 'qr' : 'm';

$| = 1;
print "1..$numtests\n# $iters iterations\n";
@@ -73,7 +74,7 @@
$result =~ s/B//i unless $skip;
for $study ('', 'study \$subject') {
$c = $iters;
- eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
+ eval "$study; \$match = (\$subject =~ $OP$pat) while \$c--; \$got = \"$repl\";";
chomp( $err = $@ );
if ($result eq 'c') {
if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
diff -ruN perl-5.8.7/t/op/regexp_qr.t perl-5.8.7.new/t/op/regexp_qr.t
--- perl-5.8.7/t/op/regexp_qr.t 1969-12-31 19:00:00.000000000 -0500
+++ perl-5.8.7.new/t/op/regexp_qr.t 2005-07-07 21:32:23.810852184 -0400
@@ -0,0 +1,10 @@
+#!./perl
+
+$qr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";

Reply all
Reply to author
Forward
0 new messages