Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

s//$obj/ does not propagated taintedness of overloaded object #12495

Closed
p5pRT opened this issue Oct 14, 2012 · 6 comments
Closed

s//$obj/ does not propagated taintedness of overloaded object #12495

p5pRT opened this issue Oct 14, 2012 · 6 comments

Comments

@p5pRT
Copy link

p5pRT commented Oct 14, 2012

Migrated from rt.perl.org#115266 (status was 'resolved')

Searchable as RT115266$

@p5pRT
Copy link
Author

p5pRT commented Oct 14, 2012

From @cpansprout

This little bit of code in pp_ctl.c​:pp_substcont seemed suspicious​:

  SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc​: #67962 */

  /* See "how taint works" above pp_subst() */
  if (SvTAINTED(TOPs))
  cx->sb_rxtainted |= SUBST_TAINT_REPL;
  sv_catsv_nomg(dstr, POPs);

So I tried testing it, and, indeed, taintedness is not propagated​:

package o { use overload '""' => sub { $^X } }

bless $o=[],o;
$x = "hello";
$x =~ s/h/($o)[0]/e;
use Devel​::Peek; Dump $x;
"$o";
Dump $o;

I thought this would fix it, but it does not​:

Inline Patch
diff --git a/pp_ctl.c b/pp_ctl.c
index 23847c4..5bb4901 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -203,12 +203,10 @@ PP(pp_substcont)
 	if (cx->sb_iters > cx->sb_maxiters)
 	    DIE(aTHX_ "Substitution loop");
 
-	SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
-
+	sv_catsv(dstr, POPs);
     	/* See "how taint works" above pp_subst() */
-	if (SvTAINTED(TOPs))
+	if (SvTAINTED(TOPp1s))
 	    cx->sb_rxtainted |= SUBST_TAINT_REPL;
-	sv_catsv_nomg(dstr, POPs);
 	/* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 	s -= RX_GOFS(rx);
 
diff --git a/t/op/taint.t b/t/op/taint.t
index d621de6..69c0832 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ BEGIN {
 use strict;
 use Config;
 
-plan tests => 797;
+plan tests => 805;
 
 $| = 1;
 
@@ -579,6 +579,17 @@ my $TEST = 'TEST';
     is($res, 'xyz',    "$desc: res value");
     is($one, 'abcd',   "$desc: \$1 value");
 
+    $desc = 's//complex expr returning overload obj that taints on ""/e';
+
+    package o { use overload '""' => sub { $TAINT } }
+    bless my $o = [], o::;
+    $s = 'hello';
+    $res = $s =~ s/h/($o)[0]/e;
+    is_tainted($s,     "$desc: s tainted");
+    isnt_tainted($res, "$desc: res not tainted");
+    is($s,   'ello',   "$desc: s value");
+    is($res, '1',      "$desc: res value");
+
     {
 	# now do them all again with "use re 'taint"
 
@@ -935,6 +946,17 @@ my $TEST = 'TEST';
 	is($s,   'abcd',   "$desc: s value");
 	is($res, 'xyz',    "$desc: res value");
 	is($one, 'abcd',   "$desc: \$1 value");
+
+	$desc = 'use re "taint": s//complex expr returning overload obj '
+	       .'that taints on ""/e';
+
+	bless my $o = [], o::;
+	$s = 'hello';
+	$res = $s =~ s/h/($o)[0]/e;
+	is_tainted($s,     "$desc: s tainted");
+	isnt_tainted($res, "$desc: res not tainted");
+	is($s,   'ello',   "$desc: s value");
+	is($res, '1',      "$desc: res value");
     }
 
     $foo = $1 if 'bar' =~ /(.+)$TAINT/;

---
Flags:   category=core   severity=low

Site configuration information for perl 5.17.5​:

Configured by sprout at Sat Sep 22 18​:51​:23 PDT 2012.

Summary of my perl5 (revision 5 version 17 subversion 5) configuration​:
  Snapshot of​: 451f421
  Platform​:
  osname=darwin, osvers=10.5.0, archname=darwin-2level
  uname='darwin pint.local 10.5.0 darwin kernel version 10.5.0​: fri nov 5 23​:20​:39 pdt 2010; root​:xnu-1504.9.17~1release_i386 i386 '
  config_args='-de -Dusedevel -DDEBUGGING'
  hint=recommended, useposix=true, d_sigaction=define
  useithreads=undef, usemultiplicity=undef
  useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
  use64bitint=undef, use64bitall=undef, uselongdouble=undef
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='cc', ccflags ='-fno-common -DPERL_DARWIN -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include',
  optimize='-O3 -g',
  cppflags='-fno-common -DPERL_DARWIN -DDEBUGGING -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
  ccversion='', gccversion='4.2.1 (Apple Inc. build 5664)', gccosandvers=''
  intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
  ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
  alignbytes=8, prototype=define
  Linker and Libraries​:
  ld='env MACOSX_DEPLOYMENT_TARGET=10.3 cc', ldflags =' -fstack-protector -L/usr/local/lib'
  libpth=/usr/local/lib /usr/lib
  libs=-ldbm -ldl -lm -lutil -lc
  perllibs=-ldl -lm -lutil -lc
  libc=, so=dylib, useshrplib=false, libperl=libperl.a
  gnulibc_version=''
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=bundle, d_dlsymun=undef, ccdlflags=' '
  cccdlflags=' ', lddlflags=' -bundle -undefined dynamic_lookup -L/usr/local/lib -fstack-protector'

Locally applied patches​:
 


@​INC for perl 5.17.5​:
  /usr/local/lib/perl5/site_perl/5.17.5/darwin-2level
  /usr/local/lib/perl5/site_perl/5.17.5
  /usr/local/lib/perl5/5.17.5/darwin-2level
  /usr/local/lib/perl5/5.17.5
  /usr/local/lib/perl5/site_perl
  .


Environment for perl 5.17.5​:
  DYLD_LIBRARY_PATH (unset)
  HOME=/Users/sprout
  LANG=en_US.UTF-8
  LANGUAGE (unset)
  LD_LIBRARY_PATH (unset)
  LOGDIR (unset)
  PATH=/usr/bin​:/bin​:/usr/sbin​:/sbin​:/usr/local/bin​:/usr/X11/bin​:/usr/local/bin
  PERL_BADLANG (unset)
  SHELL=/bin/bash

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2017

From zefram@fysh.org

Fixed in commit c4f4b22.

-zefram

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2017

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2017

@xsawyerx - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

p5pRT commented Jun 23, 2018

From @khwilliamson

Thank you for filing this report. You have helped make Perl better.

With the release yesterday of Perl 5.28.0, this and 185 other issues have been
resolved.

Perl 5.28.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.28.0

If you find that the problem persists, feel free to reopen this ticket.

@p5pRT
Copy link
Author

p5pRT commented Jun 23, 2018

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant