Change 23302 by nicholas@no-spam on 2004/09/09 21:45:33
Integrate:
[ 23023]
[perl #30258] utf8 POPSTACK crash on split execution
split() does a SWITCHSTACK to directly split to an array, but
if it subsequently dies (eg the regex triggers a 'use utf8' which
is then denied by Safe), then the switch doesn't get undone. Add
a new save type to allow for this.
[ 23150]
Subject: Re: "Too late for -T" could be more descriptive
From: Jim Cromie <jcromie@no-spam>
Date: Wed, 21 Jul 2004 11:21:50 -0600
Message-ID: <40FEA62E.2010809@no-spam>
(with tweaks)
[ 23158]
[perl #30733] memory leak in array delete
av_delete() wasn't mortalizing the returned value
[ 23209]
eval_sv() failing a taint test could corrupt the stack
[ 23210]
Fix a typo and remove some debugging crud from change #23209
[ 23271]
only mortalize deleted array elements for AvREAL
(update to change #23158)
[ 23279]
Add MY_CXT_CLONE to the core. (Taken from Time::HiRes.) See also:
http://groups.google.com/groups?selm=r5l1vv00ca033k7a06d40fgei1ion91rnp%404ax.com
Affected files ...
... //depot/maint-5.8/perl/av.c#16 integrate
... //depot/maint-5.8/perl/ext/XS/APItest/t/call.t#2 integrate
... //depot/maint-5.8/perl/perl.c#82 integrate
... //depot/maint-5.8/perl/perl.h#66 integrate
... //depot/maint-5.8/perl/pod/perldebug.pod#6 integrate
... //depot/maint-5.8/perl/pod/perldiag.pod#61 integrate
... //depot/maint-5.8/perl/pod/perlrun.pod#39 integrate
... //depot/maint-5.8/perl/pp.c#42 integrate
... //depot/maint-5.8/perl/scope.c#19 integrate
... //depot/maint-5.8/perl/scope.h#14 integrate
... //depot/maint-5.8/perl/t/op/delete.t#3 integrate
Differences ...
==== //depot/maint-5.8/perl/av.c#16 (text) ====
Index: perl/av.c
--- perl/av.c#15~22982~ Wed Jun 23 06:22:41 2004
+++ perl/av.c Thu Sep 9 14:45:33 2004
@@no-spam -864,6 +864,8 @@no-spam
SvREFCNT_dec(sv);
sv = Nullsv;
}
+ else if (AvREAL(av))
+ sv = sv_2mortal(sv);
return sv;
}
==== //depot/maint-5.8/perl/ext/XS/APItest/t/call.t#2 (text) ====
Index: perl/ext/XS/APItest/t/call.t
--- perl/ext/XS/APItest/t/call.t#1~23270~ Sun Sep 5 14:34:19 2004
+++ perl/ext/XS/APItest/t/call.t Thu Sep 9 14:45:33 2004
@@no-spam -19,9 +19,14 @@no-spam
use warnings;
use strict;
-use Test::More tests => 239;
+# Test::More doesn't have fresh_perl_is() yet
+# use Test::More tests => 240;
-BEGIN { use_ok('XS::APItest') };
+BEGIN {
+ require './test.pl';
+ plan(240);
+ use_ok('XS::APItest')
+};
#########################
@@no-spam -134,7 +139,7 @@no-spam
ok(eq_array( [ eval { eval_sv('d', $flags), $@no-spam }, $@no-spam ],
[ ($flags & (G_ARRAY|G_DISCARD)) ? (0) : (undef, 1),
- "its_dead_jim\n", undef ]),
+ "its_dead_jim\n", '' ]),
"$description eval { eval_sv('d') }");
ok(eq_array( [ eval { call_method('d', $flags, $obj, @no-spam }, $@no-spam ],
@@no-spam -148,3 +153,22 @@no-spam
is($@no-spam "its_dead_jim\n", "eval_pv('d()', 0) - \$@no-spam");
is(eval { eval_pv('d()', 1) } , undef, "eval { eval_pv('d()', 1) }");
is($@no-spam "its_dead_jim\n", "eval { eval_pv('d()', 1) } - \$@no-spam");
+
+# DAPM 9-Aug-04. A taint test in eval_sv() could die after setting up
+# a new jump level but before pushing an eval context, leading to
+# stack corruption
+
+fresh_perl_is(<<'EOF', "x=2", { switches => ['-T'] }, 'eval_sv() taint');
+use XS::APItest;
+
+my $x = 0;
+sub f {
+ eval { my @no-spam = ($^X . "x" , eval_sv(q(die "inner\n"), 0)) ; };
+ $x++;
+ $a <=> $b;
+}
+
+eval { my @no-spam = sort f 2, 1; $x++};
+print "x=$x\n";
+EOF
+
==== //depot/maint-5.8/perl/perl.c#82 (text) ====
Index: perl/perl.c
--- perl/perl.c#81~23264~ Sun Sep 5 11:42:01 2004
+++ perl/perl.c Thu Sep 9 14:45:33 2004
@@no-spam -2339,6 +2339,10 @@no-spam
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
#else
+ /* fail now; otherwise we could fail after the JMPENV_PUSH but
+ * before a PUSHEVAL, which corrupts the stack after a croak */
+ TAINT_PROPER("eval_sv()");
+
JMPENV_PUSH(ret);
#endif
switch (ret) {
@@no-spam -3240,9 +3244,8 @@no-spam
#endif /* IAMSUID */
if (!PL_rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s%s\n",
- CopFILE(PL_curcop), Strerror(errno),
- ".\nUse -S to search $PATH for it.");
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
==== //depot/maint-5.8/perl/perl.h#66 (text) ====
Index: perl/perl.h
--- perl/perl.h#65~22628~ Thu Apr 1 05:27:14 2004
+++ perl/perl.h Thu Sep 9 14:45:33 2004
@@no-spam -535,7 +535,7 @@no-spam
# define MALLOC_CHECK_TAINT(argc,argv,env)
#endif /* MYMALLOC */
-#define TOO_LATE_FOR_(ch,s) Perl_croak(aTHX_ "Too late for \"-%c\" option%s", (char)(ch), s)
+#define TOO_LATE_FOR_(ch,s) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line", (char)(ch), s)
#define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "")
#define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}")
#define MALLOC_CHECK_TAINT2(argc,argv) MALLOC_CHECK_TAINT(argc,argv,NULL)
@@no-spam -4188,6 +4188,13 @@no-spam
Zero(my_cxtp, 1, my_cxt_t); \
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+/* Clones the per-interpreter data. */
+#define MY_CXT_CLONE \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
#define MY_CXT (*my_cxtp)
@@no-spam -4207,6 +4214,7 @@no-spam
#define dMY_CXT_SV dNOOP
#define dMY_CXT dNOOP
#define MY_CXT_INIT NOOP
+#define MY_CXT_CLONE NOOP
#define MY_CXT my_cxt
#define pMY_CXT void
==== //depot/maint-5.8/perl/pod/perldebug.pod#6 (text) ====
Index: perl/pod/perldebug.pod
--- perl/pod/perldebug.pod#5~22644~ Sun Apr 4 06:50:28 2004
+++ perl/pod/perldebug.pod Thu Sep 9 14:45:33 2004
@@no-spam -1014,6 +1014,12 @@no-spam
and
L<perlrun>.
+When debugging a script that uses #! and is thus normally found in
+$PATH, the -S option causes perl to search $PATH for it, so you don't
+have to type the path or `which $scriptname`.
+
+ $ perl -Sd foo.pl
+
=head1 BUGS
You cannot get stack frame information or in any fashion debug functions
==== //depot/maint-5.8/perl/pod/perldiag.pod#61 (text) ====
Index: perl/pod/perldiag.pod
--- perl/pod/perldiag.pod#60~23259~ Sat Sep 4 12:40:24 2004
+++ perl/pod/perldiag.pod Thu Sep 9 14:45:33 2004
@@no-spam -924,6 +924,10 @@no-spam
(F) The script you specified can't be opened for the indicated reason.
+If you're debugging a script that uses #!, and normally relies on the
+shell's $PATH search, the -S option causes perl to do that search, so
+you don't have to type the path or C<`which $scriptname`>.
+
=item Can't read CRTL environ
(S) A warning peculiar to VMS. Perl tried to read an element of %ENV
@@no-spam -3631,6 +3635,22 @@no-spam
(F) Perl can't peek at the stdio buffer of filehandles when it doesn't
know about your kind of stdio. You'll have to use a filename instead.
+=item "-T" is on the #! line, it must also be used on the command line
+
+(X) The #! line (or local equivalent) in a Perl script contains the
+B<-T> option, but Perl was not invoked with B<-T> in its command line.
+This is an error because, by the time Perl discovers a B<-T> in a
+script, it's too late to properly taint everything from the environment.
+So Perl gives up.
+
+If the Perl script is being executed as a command using the #!
+mechanism (or its local equivalent), this error can usually be fixed by
+editing the #! line so that the B<-T> option is a part of Perl's first
+argument: e.g. change C<perl -n -T> to C<perl -T -n>.
+
+If the Perl script is being executed as C<perl scriptname>, then the
+B<-T> option must appear on the command line: C<perl -T scriptname>.
+
=item Target of goto is too deeply nested
(F) You tried to use C<goto> to reach a label that was too deeply nested
@@no-spam -3729,22 +3749,6 @@no-spam
(X) The #! line (or local equivalent) in a Perl script contains the
B<-M> or B<-m> option. This is an error because B<-M> and B<-m> options
are not intended for use inside scripts. Use the C<use> pragma instead.
-
-=item Too late for "B<-T>" option
-
-(X) The #! line (or local equivalent) in a Perl script contains the
-B<-T> option, but Perl was not invoked with B<-T> in its command line.
-This is an error because, by the time Perl discovers a B<-T> in a
-script, it's too late to properly taint everything from the environment.
-So Perl gives up.
-
-If the Perl script is being executed as a command using the #!
-mechanism (or its local equivalent), this error can usually be fixed by
-editing the #! line so that the B<-T> option is a part of Perl's first
-argument: e.g. change C<perl -n -T> to C<perl -T -n>.
-
-If the Perl script is being executed as C<perl scriptname>, then the
-B<-T> option must appear on the command line: C<perl -T scriptname>.
=item Too late to run %s block
==== //depot/maint-5.8/perl/pod/perlrun.pod#39 (text) ====
Index: perl/pod/perlrun.pod
--- perl/pod/perlrun.pod#38~22864~ Sun May 30 05:38:30 2004
+++ perl/pod/perlrun.pod Thu Sep 9 14:45:33 2004
@@no-spam -723,9 +723,12 @@no-spam
of those suffixes. If your Perl was compiled with DEBUGGING turned
on, using the -Dp switch to Perl shows how the search progresses.
-Typically this is used to emulate #! startup on platforms that
-don't support #!. This example works on many platforms that
-have a shell compatible with Bourne shell:
+Typically this is used to emulate #! startup on platforms that don't
+support #!. Its also convenient when debugging a script that uses #!,
+and is thus normally found by the shell's $PATH search mechanism.
+
+This example works on many platforms that have a shell compatible with
+Bourne shell:
#!/usr/bin/perl
eval 'exec /usr/bin/perl -wS $0 ${1+"$@no-spam"}'
==== //depot/maint-5.8/perl/pp.c#42 (text) ====
Index: perl/pp.c
--- perl/pp.c#41~23294~ Thu Sep 9 04:12:47 2004
+++ perl/pp.c Thu Sep 9 14:45:33 2004
@@no-spam -4444,7 +4444,6 @@no-spam
I32 origlimit = limit;
I32 realarray = 0;
I32 base;
- AV *oldstack = PL_curstack;
I32 gimme = GIMME_V;
I32 oldsave = PL_savestack_ix;
I32 make_mortal = 1;
@@no-spam -4497,8 +4496,7 @@no-spam
AvARRAY(ary)[i] = &PL_sv_undef; /* don't free mere refs */
}
/* temporarily switch stacks */
- SWITCHSTACK(PL_curstack, ary);
- PL_curstackinfo->si_stack = ary;
+ SAVESWITCHSTACK(PL_curstack, ary);
make_mortal = 0;
}
}
@@no-spam -4667,7 +4665,6 @@no-spam
}
}
- LEAVE_SCOPE(oldsave);
iters = (SP - PL_stack_base) - base;
if (iters > maxiters)
DIE(aTHX_ "Split loop");
@@no-spam -4693,10 +4690,11 @@no-spam
}
}
+ PUTBACK;
+ LEAVE_SCOPE(oldsave); /* may undo an earlier SWITCHSTACK */
+ SPAGAIN;
if (realarray) {
if (!mg) {
- SWITCHSTACK(ary, oldstack);
- PL_curstackinfo->si_stack = oldstack;
if (SvSMAGICAL(ary)) {
PUTBACK;
mg_set((SV*)ary);
==== //depot/maint-5.8/perl/scope.c#19 (text) ====
Index: perl/scope.c
--- perl/scope.c#18~23264~ Sun Sep 5 11:42:01 2004
+++ perl/scope.c Thu Sep 9 14:45:33 2004
@@no-spam -1039,6 +1039,15 @@no-spam
AvARRAY((PAD*)ptr)[off] = (SV*)SSPOPPTR;
}
break;
+ case SAVEt_SAVESWITCHSTACK:
+ {
+ dSP;
+ AV* t = (AV*)SSPOPPTR;
+ AV* f = (AV*)SSPOPPTR;
+ SWITCHSTACK(t,f);
+ PL_curstackinfo->si_stack = f;
+ }
+ break;
default:
Perl_croak(aTHX_ "panic: leave_scope inconsistency");
}
==== //depot/maint-5.8/perl/scope.h#14 (text) ====
Index: perl/scope.h
--- perl/scope.h#13~22622~ Wed Mar 31 07:16:49 2004
+++ perl/scope.h Thu Sep 9 14:45:33 2004
@@no-spam -47,6 +47,7 @@no-spam
#define SAVEt_MORTALIZESV 36
#define SAVEt_SHARED_PVREF 37
#define SAVEt_BOOL 38
+#define SAVEt_SAVESWITCHSTACK 40
#ifndef SCOPE_SAVES_SIGNAL_MASK
#define SCOPE_SAVES_SIGNAL_MASK 0
@@no-spam -165,6 +166,16 @@no-spam
SSCHECK(2); \
SSPUSHPTR((SV*)PL_comppad); \
SSPUSHINT(SAVEt_COMPPAD); \
+ } STMT_END
+
+#define SAVESWITCHSTACK(f,t) \
+ STMT_START { \
+ SSCHECK(3); \
+ SSPUSHPTR((SV*)(f)); \
+ SSPUSHPTR((SV*)(t)); \
+ SSPUSHINT(SAVEt_SAVESWITCHSTACK); \
+ SWITCHSTACK((f),(t)); \
+ PL_curstackinfo->si_stack = (t); \
} STMT_END
#ifdef USE_ITHREADS
==== //depot/maint-5.8/perl/t/op/delete.t#3 (xtext) ====
Index: perl/t/op/delete.t
--- perl/t/op/delete.t#2~22784~ Wed May 5 14:43:32 2004
+++ perl/t/op/delete.t Thu Sep 9 14:45:33 2004
@@no-spam -1,6 +1,6 @@no-spam
#!./perl
-print "1..37\n";
+print "1..38\n";
# delete() on hash elements
@@no-spam -128,4 +128,17 @@no-spam
my ($x,$y) = (1, scalar delete @no-spam
print "not " if defined $y;
print "ok 37\n";
+}
+
+{
+ # [perl #30733] array delete didn't free returned element
+ my $x = 0;
+ sub X::DESTROY { $x++ }
+ {
+ my @no-spam
+ $a[0] = bless [], 'X';
+ my $y = delete $a[0];
+ }
+ print "not " unless $x == 1;
+ print "ok 38\n";
}
End of Patch.