From rootbeer@redcat.com

This is a bug report for perl from rootbeer@​redcat.com,
generated with the help of perlbug 1.28 running under perl v5.6.0.

The substitution near the end of this chunk of code should change $_ from
'fred' to 'Fred', but a previous value from $1 leaks in as well. This
seems to happen only when $1 has been used in a tr///-for-counting
operation.

  $_ = "fred";
  /([a-z]{2})/;
  $1 =~ tr/A-Z//;
  print; # prints "fred"
  s/^(\s*)f/$1F/;
  print; # prints "frFred"

It's entertaining to run this to completion in the debugger (not stepping
through it, but just letting it run) then to read the "Debugged program
terminated" message. Okay, so it doesn't take much to amuse me. :-D

Flags​:
  category=core
  severity=medium

Site configuration information for perl v5.6.0​:

Configured by rootbeer at Sun Apr 23 14​:09​:13 PDT 2000.

Summary of my perl5 (revision 5.0 version 6 subversion 0) configuration​:
  Platform​:
  osname=linux, osvers=2.0.35, archname=i586-linux
  uname='linux localhost.localdomain 2.0.35 #1 tue jul 14 23​:56​:39 edt 1998 i586 unknown '
  config_args=''
  hint=recommended, useposix=true, d_sigaction=define
  usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
  useperlio=undef d_sfio=undef uselargefiles=define
  use64bitint=undef use64bitall=undef uselongdouble=undef usesocks=undef
  Compiler​:
  cc='cc', optimize='-g -DDEBUGGING -O2', gccversion=2.7.2.3
  cppflags=''
  ccflags =' -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
  stdchar='char', d_stdstdio=define, usevfork=false
  intsize=4, longsize=4, ptrsize=4, doublesize=8
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
  ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=4
  alignbytes=4, usemymalloc=n, prototype=define
  Linker and Libraries​:
  ld='cc', ldflags =' -L/usr/local/lib'
  libpth=/usr/local/lib /lib /usr/lib
  libs=-lnsl -lndbm -lgdbm -ldb -ldl -lm -lc -lposix -lcrypt
  libc=/lib/libc-2.0.7.so, so=so, useshrplib=false, libperl=libperl.a
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
  cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches​:
 

@​INC for perl v5.6.0​:
  /usr/lib/perl5/5.6.0/i586-linux
  /usr/lib/perl5/5.6.0
  /usr/lib/perl5/site_perl/5.6.0/i586-linux
  /usr/lib/perl5/site_perl/5.6.0
  /usr/lib/perl5/site_perl
  .

Environment for perl v5.6.0​:
  HOME=/home/rootbeer
  LANG (unset)
  LANGUAGE (unset)
  LD_LIBRARY_PATH (unset)
  LOGDIR (unset)
  PATH=/usr/local/bin​:/bin​:/usr/bin​:/usr/X11R6/bin​:/usr/games​:/home/rootbeer/bin
  PERL_BADLANG (unset)
  SHELL=/usr/local/bin/bash

From @vanstyn

In <Pine.GSO.4.10.10005111759110.16364-100000@​user2.teleport.com>, Tom Phoenix
writes​:
:This is a bug report for perl from rootbeer@​redcat.com,
:generated with the help of perlbug 1.28 running under perl v5.6.0.
:
:-----------------------------------------------------------------
:
:The substitution near the end of this chunk of code should change $_ from
:'fred' to 'Fred', but a previous value from $1 leaks in as well. This
:seems to happen only when $1 has been used in a tr///-for-counting
:operation.
:
: $_ = "fred";
: /([a-z]{2})/;
: $1 =~ tr/A-Z//;
: print; # prints "fred"
: s/^(\s*)f/$1F/;
: print; # prints "frFred"

This appears to occur because the tr/// sets POK on $1, which bypasses
the magic get that should happen in the substitution. The culprit is
this line from doop.c​:595 in Perl_do_trans()​:
  (void)SvPOK_only(sv);

I'm not sure quite why this line exists, since removing it does not
trigger any test failures, but I suspect that it should occur only if
the SV does not have a magic get (as in the attached patch).
If someone can confirm or correct this belief, I'll aim to add
appropriate test cases.

Hugo

--- doop.c.old	Sun Mar 12 03:36:32 2000
+++ doop.c	Fri May 12 10:41:04 2000
@@ -592,7 +592,8 @@
 	return 0;
     if (!SvPOKp(sv))
 	(void)SvPV_force(sv, len);
-    (void)SvPOK_only(sv);
+    if (!SvGMAGICAL(sv))
+	(void)SvPOK_only(sv);
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 

From [Unknown Contact. See original ticket]

Hugo <hv@​crypt.compulink.co.uk> wrote

This appears to occur because the tr/// sets POK on $1, which bypasses
the magic get that should happen in the substitution. The culprit is
this line from doop.c​:595 in Perl_do_trans()​:
(void)SvPOK_only(sv);

I'm not sure quite why this line exists, since removing it does not
trigger any test failures, but I suspect that it should occur only if
the SV does not have a magic get (as in the attached patch).

It exists to ensure that the attached tests pass. :-)

And I think the "correct" fix is to avoid the SvPOK_only in the
non-updating case. Compare with the read-only test just above.

Patch for 5.6.0 and new tests attached.

And I've added comments to the new tests - perhaps that'll start
a trend. :-)

Mike Guy

--- ./t/op/tr.t.orig	Fri May 12 17:28:34 2000
+++ ./t/op/tr.t	Fri May 12 17:34:18 2000
@@ -5,7 +5,7 @@
     unshift @INC, "../lib";
 }
 
-print "1..4\n";
+print "1..6\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -37,3 +37,19 @@
     print "ok 4\n";
 }
 #
+
+# make sure that tr cancels IOK and NOK
+($x = 12) =~ tr/1/3/;
+(my $y = 12) =~ tr/1/3/;
+($f = 1.5) =~ tr/1/3/;
+(my $g = 1.5) =~ tr/1/3/;
+print "not " unless $x + $y + $f + $g == 71;
+print "ok 5\n";
+
+# make sure tr is harmless if not updating  -  see [ID 20000511.005]
+$_ = 'fred';
+/([a-z]{2})/;
+$1 =~ tr/A-Z//;
+s/^(\s*)f/$1F/;
+print "not " if $_ ne 'Fred';
+print "ok 6\n";
--- ./doop.c.orig	Fri May 12 15:41:40 2000
+++ ./doop.c	Fri May 12 17:40:21 2000
@@ -592,7 +592,8 @@
 	return 0;
     if (!SvPOKp(sv))
 	(void)SvPV_force(sv, len);
-    (void)SvPOK_only(sv);
+    if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
+	(void)SvPOK_only(sv);
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 

End of patch

From [Unknown Contact. See original ticket]

I wrote

And I think the "correct" fix is to avoid the SvPOK_only in the
non-updating case.

For some values of "correct" only. This second try ensures that
the UTF8 flag doesn't get lost. (But tr/// on UTF8 values is broken
in other ways. And the new tests are somewhat curiously written to
circumvent UTF8 bugs in eq and other operators. But that's all the
subject of another thread.)

I note that Robin Barker, in his recent patch to vec(), uses SvNIOK_off
rather than SvPOK_only or SvPOK_only_UTF8. I'm unclear which is
more correct. I can't find any case which fails with my test [*]; in
partticular tied values are treated correctly although I don't
understand why the magic isn't getting lost.

[*] Though I did find some strange examples of "correct" behaviour.
  Can you predict what

  ($! = 28) =~ tr/2/3/

  will do?

Mike Guy

--- ./t/op/tr.t.orig	Fri May 12 19:06:02 2000
+++ ./t/op/tr.t	Sat May 13 09:48:39 2000
@@ -5,7 +5,7 @@
     unshift @INC, "../lib";
 }
 
-print "1..4\n";
+print "1..8\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -37,3 +37,27 @@
     print "ok 4\n";
 }
 #
+
+# make sure that tr cancels IOK and NOK
+($x = 12) =~ tr/1/3/;
+(my $y = 12) =~ tr/1/3/;
+($f = 1.5) =~ tr/1/3/;
+(my $g = 1.5) =~ tr/1/3/;
+print "not " unless $x + $y + $f + $g == 71;
+print "ok 5\n";
+
+# make sure tr is harmless if not updating  -  see [ID 20000511.005]
+$_ = 'fred';
+/([a-z]{2})/;
+$1 =~ tr/A-Z//;
+s/^(\s*)f/$1F/;
+print "not " if $_ ne 'Fred';
+print "ok 6\n";
+
+# check tr handles UTF8 correctly
+($x = 256.65.258) =~ tr/a/b/;
+print "not " if $x ne 256.65.258 or length $x != 3;
+print "ok 7\n";
+$x =~ tr/A/B/;
+print "not " if $x ne 256.66.258 or length $x != 3;
+print "ok 8\n";
--- ./doop.c.orig	Fri May 12 19:06:03 2000
+++ ./doop.c	Sat May 13 09:54:44 2000
@@ -592,7 +592,8 @@
 	return 0;
     if (!SvPOKp(sv))
 	(void)SvPV_force(sv, len);
-    (void)SvPOK_only(sv);
+    if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
+	(void)SvPOK_only_UTF8(sv);
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 

End of patch

From [Unknown Contact. See original ticket]

M.J.T. Guy writes​:

 Can you predict what
        \($\! = 28\) =~ tr/2/3/
 will do?

Lemme try to predict what it *should* do. $! is assignable as a
number only, but accessible any way. So tr/// is performed on the
message of errno==28. But then the converted message is either
assigned back, or (as an optimization) the assignment is skipped
(since most probably there is no '2' in the message).

In the first case numerical value of the message (thus 0) is put in
$!. In the second case tr/// is a NOP.

Checking... I get

  Argument "Disk full" isn't numeric in trans at -e line 1.

So there is no skip-assignment optimization...

Ilya

From @smpeters

[RT_System - Thu May 11 20​:40​:52 2000]​:

In <Pine.GSO.4.10.10005111759110.16364-100000@​user2.teleport.com>, Tom
Phoenix
writes​:
:This is a bug report for perl from rootbeer@​redcat.com,
:generated with the help of perlbug 1.28 running under perl v5.6.0.
:
:-----------------------------------------------------------------
:
:The substitution near the end of this chunk of code should change $_
from
:'fred' to 'Fred', but a previous value from $1 leaks in as well. This
:seems to happen only when $1 has been used in a tr///-for-counting
:operation.
:
: $_ = "fred";
: /([a-z]{2})/;
: $1 =~ tr/A-Z//;
: print; # prints "fred"
: s/^(\s*)f/$1F/;
: print; # prints "frFred"

This appears to occur because the tr/// sets POK on $1, which bypasses
the magic get that should happen in the substitution. The culprit is
this line from doop.c​:595 in Perl_do_trans()​:
(void)SvPOK_only(sv);

I'm not sure quite why this line exists, since removing it does not
trigger any test failures, but I suspect that it should occur only if
the SV does not have a magic get (as in the attached patch).
If someone can confirm or correct this belief, I'll aim to add
appropriate test cases.

Hugo
--- doop.c.old Sun Mar 12 03​:36​:32 2000
+++ doop.c Fri May 12 10​:41​:04 2000
@​@​ -592,7 +592,8 @​@​
return 0;
if (!SvPOKp(sv))
(void)SvPV_force(sv, len);
- (void)SvPOK_only(sv);
+ if (!SvGMAGICAL(sv))
+ (void)SvPOK_only(sv);

 DEBUG\_t\( Perl\_deb\(aTHX\_ "2\.TBL\\n"\)\);

It looks like this patch or the other patch in this ticket thread were
never applied. Instead, the following change seemed to take care of things.

Change 17984 by rgs@​rgs-home on 2002/10/09 19​:17​:08

  Fix bug #17823 : non-modifying tr/// stringifies references

Affected files ...

... //depot/perl/doop.c#129 edit
... //depot/perl/t/op/tr.t#33 edit

Differences ...

==== //depot/perl/doop.c#129 (text) ====

@​@​ -608,10 +608,11 @​@​
  (void)SvPV(sv, len);
  if (!len)
  return 0;
- if (!SvPOKp(sv))
- (void)SvPV_force(sv, len);
- if (!(PL_op->op_private & OPpTRANS_IDENTICAL))
+ if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
+ if (!SvPOKp(sv))
+ (void)SvPV_force(sv, len);
  (void)SvPOK_only_UTF8(sv);
+ }

  DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));

==== //depot/perl/t/op/tr.t#33 (xtext) ====

@​@​ -6,7 +6,7 @​@​
  require './test.pl';
}

-plan tests => 97;
+plan tests => 99;

my $Is_EBCDIC = (ord('i') == 0x89 & ord('J') == 0xd1);

@​@​ -379,3 +379,7 @​@​
eval '$foo{bar} =~ tr/N/N/';
is( $@​, '', 'implicit count outside hash bounds' );
is( scalar keys %foo, 0, " doesn't extend the hash");
+
+$x = \"foo";
+is( $x =~ tr/A/A/, 2, 'non-modifying tr/// on a scalar ref' );
+is( ref $x, 'SCALAR', " doesn't stringify its argument" );

@smpeters - Status changed from 'open' to 'resolved'