Change 33942 by [EMAIL PROTECTED] on 2008/05/28 01:21:26
Integrate:
[ 33337]
Setting the f flag on length causes the op to be constant folded.
[ 33342]
fix variable names in 'ununit var' warnings in evals
[ 33363]
Subject: [PATCH] B::Debug enhancements
From: "Reini Urban" <[EMAIL PROTECTED]>
Date: Fri, 22 Feb 2008 09:52:32 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 33367]
Avoid a segfault case in MRO code, based on :
Subject: [perl #51092] [PATCH] Segfault when calling ->next::method on
non-existing package
From: [EMAIL PROTECTED] (via RT) <[EMAIL PROTECTED]>
Date: Thu, 21 Feb 2008 20:29:42 -0800
Message-ID: <[EMAIL PROTECTED]>
[ 33369]
Ensure that constant folding runs with IN_PERL_RUNTIME true, by copying
the current compiling cop to a different address. This ensures that
lexical hints are correctly honoured, and allows us to fold sprintf.
[ 33377]
If we have malloced_size() available, then avoid rounding up the string
to the next (guessed) plausible alignment size, and instead find out
how much memory was actually allocated, so that we can set this in the
scalar's SvLEN(). This way, sv_grow() will be called far less often.
[ 33378]
In Perl_sv_usepvn_flags(), with MYMALLOC, use the actual malloc()ed
size for SvLEN(), rather than an estimate.
[ 33379]
If the C library provides malloc_size(), we can use that in the same
places as Perl's malloced_size(), except that we need to be careful of
any PERL_TRACK_MEMPOOL manipulations in force. Wrap both as
Perl_safesysmalloc_size(), to give a consistent name and interface.
[ 33380]
Fix preprocessor syntax
[ 33383]
Comment on why I don't think changing Perl_safesysmalloc_size() in av.c
analagous to the change in sv.c is a good idea. [It's not a language
design issue, so sadly I can't get a talk out of it. Or is that
fortunately? :-)]
[ 33389]
Add Perl_malloc_good_size to malloc.c. (A routine that rounds up the
passed in request to the size that will actually be allocated. It's
the same interface as Darwin already provides with malloc_good_size().)
[ 33390]
Use malloc_good_size() to round up the size of requested arenas to the
size that will actually be allocated, to squeeze last few bytes into
use.
Affected files ...
... //depot/maint-5.10/perl/av.c#4 integrate
... //depot/maint-5.10/perl/embed.fnc#10 integrate
... //depot/maint-5.10/perl/embed.h#6 integrate
... //depot/maint-5.10/perl/ext/B/B/Debug.pm#3 integrate
... //depot/maint-5.10/perl/handy.h#5 integrate
... //depot/maint-5.10/perl/hv.c#3 integrate
... //depot/maint-5.10/perl/makedef.pl#2 integrate
... //depot/maint-5.10/perl/malloc.c#3 integrate
... //depot/maint-5.10/perl/mro.c#5 integrate
... //depot/maint-5.10/perl/op.c#11 integrate
... //depot/maint-5.10/perl/opcode.h#2 integrate
... //depot/maint-5.10/perl/opcode.pl#3 integrate
... //depot/maint-5.10/perl/perl.h#12 integrate
... //depot/maint-5.10/perl/proto.h#8 integrate
... //depot/maint-5.10/perl/sv.c#15 integrate
... //depot/maint-5.10/perl/t/lib/warnings/7fatal#2 integrate
... //depot/maint-5.10/perl/t/lib/warnings/9uninit#4 integrate
... //depot/maint-5.10/perl/t/mro/next_edgecases.t#2 integrate
Differences ...
==== //depot/maint-5.10/perl/av.c#4 (text) ====
Index: perl/av.c
--- perl/av.c#3~33614~ 2008-03-31 09:59:07.000000000 -0700
+++ perl/av.c 2008-05-27 18:21:26.000000000 -0700
@@ -117,8 +117,22 @@
IV itmp;
#endif
-#ifdef MYMALLOC
- newmax = malloced_size((void*)AvALLOC(av))/sizeof(SV*) - 1;
+#ifdef Perl_safesysmalloc_size
+ /* Whilst it would be quite possible to move this logic around
+ (as I did in the SV code), so as to set AvMAX(av) early,
+ based on calling Perl_safesysmalloc_size() immediately after
+ allocation, I'm not convinced that it is a great idea here.
+ In an array we have to loop round setting everything to
+ &PL_sv_undef, which means writing to memory, potentially lots
+ of it, whereas for the SV buffer case we don't touch the
+ "bonus" memory. So there there is no cost in telling the
+ world about it, whereas here we have to do work before we can
+ tell the world about it, and that work involves writing to
+ memory that might never be read. So, I feel, better to keep
+ the current lazy system of only writing to it if our caller
+ has a need for more space. NWC */
+ newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) /
+ sizeof(SV*) - 1;
if (key <= newmax)
goto resized;
@@ -147,7 +161,7 @@
Safefree(AvALLOC(av));
AvALLOC(av) = ary;
#endif
-#ifdef MYMALLOC
+#ifdef Perl_safesysmalloc_size
resized:
#endif
ary = AvALLOC(av) + AvMAX(av) + 1;
==== //depot/maint-5.10/perl/embed.fnc#10 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#9~33611~ 2008-03-31 05:32:56.000000000 -0700
+++ perl/embed.fnc 2008-05-27 18:21:26.000000000 -0700
@@ -78,6 +78,7 @@
Anop |Free_t |mfree |Malloc_t where
#if defined(MYMALLOC)
npR |MEM_SIZE|malloced_size |NN void *p
+npR |MEM_SIZE|malloc_good_size |size_t nbytes
#endif
AnpR |void* |get_context
==== //depot/maint-5.10/perl/embed.h#6 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#5~33167~ 2008-02-01 06:04:12.000000000 -0800
+++ perl/embed.h 2008-05-27 18:21:26.000000000 -0700
@@ -38,6 +38,7 @@
#if defined(MYMALLOC)
#ifdef PERL_CORE
#define malloced_size Perl_malloced_size
+#define malloc_good_size Perl_malloc_good_size
#endif
#endif
#define get_context Perl_get_context
@@ -2348,6 +2349,7 @@
#if defined(MYMALLOC)
#ifdef PERL_CORE
#define malloced_size Perl_malloced_size
+#define malloc_good_size Perl_malloc_good_size
#endif
#endif
#define get_context Perl_get_context
==== //depot/maint-5.10/perl/ext/B/B/Debug.pm#3 (text) ====
Index: perl/ext/B/B/Debug.pm
--- perl/ext/B/B/Debug.pm#2~33921~ 2008-05-24 09:32:36.000000000 -0700
+++ perl/ext/B/B/Debug.pm 2008-05-27 18:21:26.000000000 -0700
@@ -1,20 +1,36 @@
package B::Debug;
-our $VERSION = '1.05';
+our $VERSION = '1.05_02';
use strict;
use B qw(peekop class walkoptree walkoptree_exec
main_start main_root cstring sv_undef @specialsv_name);
+# <=5.008 had @specialsv_name exported from B::Asmdata
+BEGIN {
+ use Config;
+ my $ithreads = $Config{'useithreads'} eq 'define';
+ eval qq{
+ sub ITHREADS() { $ithreads }
+ sub VERSION() { $] }
+ }; die $@ if $@;
+}
my %done_gv;
+sub _printop {
+ my $op = shift;
+ my $addr = ${$op} ? $op->ppaddr : '';
+ $addr =~ s/^PL_ppaddr// if $addr;
+ return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
+}
+
sub B::OP::debug {
my ($op) = @_;
- printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling},
$op->ppaddr, $op->targ, $op->type;
+ printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next),
_printop($op->sibling), $op->targ, $op->type;
%s (0x%lx)
- op_next 0x%x
- op_sibling 0x%x
op_ppaddr %s
+ op_next %s
+ op_sibling %s
op_targ %d
op_type %d
EOT
@@ -36,29 +52,29 @@
sub B::UNOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_first\t0x%x\n", ${$op->first};
+ printf "\top_first\t%s\n", _printop($op->first);
}
sub B::BINOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
- printf "\top_last\t\t0x%x\n", ${$op->last};
+ printf "\top_last \t%s\n", _printop($op->last);
}
sub B::LOOP::debug {
my ($op) = @_;
$op->B::BINOP::debug();
- printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
- op_redoop 0x%x
- op_nextop 0x%x
- op_lastop 0x%x
+ printf <<'EOT', _printop($op->redoop), _printop($op->nextop),
_printop($op->lastop);
+ op_redoop %s
+ op_nextop %s
+ op_lastop %s
EOT
}
sub B::LOGOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
- printf "\top_other\t0x%x\n", ${$op->other};
+ printf "\top_other\t%s\n", _printop($op->other);
}
sub B::LISTOP::debug {
@@ -73,8 +89,17 @@
printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
- printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
+ if (ITHREADS) {
+ printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
+ printf "\top_pmoffset\t%d\n", $op->pmoffset;
+ } else {
+ printf "\top_pmstash\t%s\n", cstring($op->pmstash);
+ }
+ printf "\top_precomp->precomp\t%s\n", cstring($op->precomp);
printf "\top_pmflags\t0x%x\n", $op->pmflags;
+ printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
+ printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
+ printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
$op->pmreplroot->debug;
}
@@ -83,9 +108,9 @@
$op->B::OP::debug();
my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq,
$op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
- cop_label %s
- cop_stashpv %s
- cop_file %s
+ cop_label "%s"
+ cop_stashpv "%s"
+ cop_file "%s"
cop_seq %d
cop_arybase %d
cop_line %d
@@ -110,7 +135,7 @@
sub B::PADOP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf "\top_padix\t\t%ld\n", $op->padix;
+ printf "\top_padix\t%ld\n", $op->padix;
}
sub B::NULL::debug {
@@ -294,7 +319,12 @@
=head1 DESCRIPTION
-See F<ext/B/README>.
+See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
+
+=head1 OPTIONS
+
+With option -exec, walks tree in execute order,
+otherwise in basic order.
=head1 AUTHOR
==== //depot/maint-5.10/perl/handy.h#5 (text) ====
Index: perl/handy.h
--- perl/handy.h#4~33875~ 2008-05-20 01:32:47.000000000 -0700
+++ perl/handy.h 2008-05-27 18:21:26.000000000 -0700
@@ -175,7 +175,7 @@
#endif
/* HMB H.Merijn Brand - a placeholder for preparing Configure patches */
-#if defined(HAS_MALLOC_SIZE) && defined(LOCALTIME_R_NEEDS_TZSET) &&
defined(HAS_PSEUDOFORK) && defined(USE_DTRACE)
+#if defined(LOCALTIME_R_NEEDS_TZSET) && defined(HAS_PSEUDOFORK) &&
defined(USE_DTRACE)
/* Not (yet) used at top level, but mention them for metaconfig */
#endif
==== //depot/maint-5.10/perl/hv.c#3 (text) ====
Index: perl/hv.c
--- perl/hv.c#2~33139~ 2008-01-30 15:19:42.000000000 -0800
+++ perl/hv.c 2008-05-27 18:21:26.000000000 -0700
@@ -40,8 +40,11 @@
S_more_he(pTHX)
{
dVAR;
- HE* he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
- HE * const heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
+ /* We could generate this at compile time via (another) auxiliary C
+ program? */
+ const size_t arena_size = Perl_malloc_good_size(PERL_ARENA_SIZE);
+ HE* he = (HE*) Perl_get_arena(aTHX_ arena_size, HE_SVSLOT);
+ HE * const heend = &he[arena_size / sizeof(HE) - 1];
PL_body_roots[HE_SVSLOT] = he;
while (he < heend) {
==== //depot/maint-5.10/perl/makedef.pl#2 (text) ====
Index: perl/makedef.pl
--- perl/makedef.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/makedef.pl 2008-05-27 18:21:26.000000000 -0700
@@ -667,6 +667,7 @@
Perl_dump_mstats
Perl_get_mstats
Perl_malloced_size
+ Perl_malloc_good_size
MallocCfg_ptr
MallocCfgP_ptr
)];
==== //depot/maint-5.10/perl/malloc.c#3 (text) ====
Index: perl/malloc.c
--- perl/malloc.c#2~33161~ 2008-01-31 14:14:13.000000000 -0800
+++ perl/malloc.c 2008-05-27 18:21:26.000000000 -0700
@@ -1404,23 +1404,12 @@
# define FILLCHECK_DEADBEEF(s, n) ((void)0)
#endif
-Malloc_t
-Perl_malloc(register size_t nbytes)
+int
+S_ajust_size_and_find_bucket(size_t *nbytes_p)
{
- dVAR;
- register union overhead *p;
- register int bucket;
- register MEM_SIZE shiftr;
-
-#if defined(DEBUGGING) || defined(RCHECK)
- MEM_SIZE size = nbytes;
-#endif
-
- BARK_64K_LIMIT("Allocation",nbytes,nbytes);
-#ifdef DEBUGGING
- if ((long)nbytes < 0)
- croak("%s", "panic: malloc");
-#endif
+ MEM_SIZE shiftr;
+ int bucket;
+ size_t nbytes = *nbytes_p;
/*
* Convert amount of memory requested into
@@ -1455,6 +1444,28 @@
while (shiftr >>= 1)
bucket += BUCKETS_PER_POW2;
}
+ *nbytes_p = nbytes;
+ return bucket;
+}
+
+Malloc_t
+Perl_malloc(size_t nbytes)
+{
+ dVAR;
+ register union overhead *p;
+ register int bucket;
+
+#if defined(DEBUGGING) || defined(RCHECK)
+ MEM_SIZE size = nbytes;
+#endif
+
+ BARK_64K_LIMIT("Allocation",nbytes,nbytes);
+#ifdef DEBUGGING
+ if ((long)nbytes < 0)
+ croak("%s", "panic: malloc");
+#endif
+
+ bucket = S_ajust_size_and_find_bucket(&nbytes);
MALLOC_LOCK;
/*
* If nothing in hash bucket right now,
@@ -2373,6 +2384,13 @@
return BUCKET_SIZE_REAL(bucket);
}
+
+MEM_SIZE
+Perl_malloc_good_size(size_t wanted)
+{
+ return BUCKET_SIZE_REAL(S_ajust_size_and_find_bucket(&wanted));
+}
+
# ifdef BUCKETS_ROOT2
# define MIN_EVEN_REPORT 6
# else
==== //depot/maint-5.10/perl/mro.c#5 (text) ====
Index: perl/mro.c
--- perl/mro.c#4~33746~ 2008-04-25 07:45:48.000000000 -0700
+++ perl/mro.c 2008-05-27 18:21:26.000000000 -0700
@@ -957,7 +957,7 @@
if(sv_isobject(self))
selfstash = SvSTASH(SvRV(self));
else
- selfstash = gv_stashsv(self, 0);
+ selfstash = gv_stashsv(self, GV_ADD);
assert(selfstash);
==== //depot/maint-5.10/perl/op.c#11 (text) ====
Index: perl/op.c
--- perl/op.c#10~33941~ 2008-05-27 15:58:13.000000000 -0700
+++ perl/op.c 2008-05-27 18:21:26.000000000 -0700
@@ -2351,6 +2351,7 @@
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
+ COP not_compiling;
dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
@@ -2413,6 +2414,13 @@
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ /* Verify that we don't need to save it: */
+ assert(PL_curcop == &PL_compiling);
+ StructCopy(&PL_compiling, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
JMPENV_PUSH(ret);
@@ -2446,6 +2454,7 @@
JMPENV_POP;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
+ PL_curcop = &PL_compiling;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
==== //depot/maint-5.10/perl/opcode.h#2 (text+w) ====
Index: perl/opcode.h
--- perl/opcode.h#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/opcode.h 2008-05-27 18:21:26.000000000 -0700
@@ -1650,12 +1650,12 @@
0x0001378e, /* hex */
0x0001378e, /* oct */
0x0001378e, /* abs */
- 0x0001379c, /* length */
+ 0x0001379e, /* length */
0x1322280c, /* substr */
0x0022281c, /* vec */
0x0122291c, /* index */
0x0122291c, /* rindex */
- 0x0004280d, /* sprintf */
+ 0x0004280f, /* sprintf */
0x00042805, /* formline */
0x0001379e, /* ord */
0x0001378e, /* chr */
==== //depot/maint-5.10/perl/opcode.pl#3 (xtext) ====
Index: perl/opcode.pl
--- perl/opcode.pl#2~33136~ 2008-01-30 11:55:32.000000000 -0800
+++ perl/opcode.pl 2008-05-27 18:21:26.000000000 -0700
@@ -728,14 +728,14 @@
# String stuff.
-length length ck_lengthconst isTu% S?
+length length ck_lengthconst ifsTu% S?
substr substr ck_substr st@ S S S? S?
vec vec ck_fun ist@ S S S
index index ck_index isT@ S S S?
rindex rindex ck_index isT@ S S S?
-sprintf sprintf ck_fun mst@ S L
+sprintf sprintf ck_fun fmst@ S L
formline formline ck_fun ms@ S L
ord ord ck_fun ifsTu% S?
chr chr ck_fun fsTu% S?
==== //depot/maint-5.10/perl/perl.h#12 (text) ====
Index: perl/perl.h
--- perl/perl.h#11~33894~ 2008-05-20 16:39:57.000000000 -0700
+++ perl/perl.h 2008-05-27 18:21:26.000000000 -0700
@@ -4048,6 +4048,8 @@
(MEM_ALIGNBYTES - sizeof(struct perl_memory_debug_header) \
%MEM_ALIGNBYTES) % MEM_ALIGNBYTES)
+#else
+# define sTHX 0
#endif
#ifdef PERL_TRACK_MEMPOOL
@@ -4065,6 +4067,21 @@
# include <malloc/malloc.h>
#endif
+#ifdef MYMALLOC
+# define Perl_safesysmalloc_size(where) Perl_malloced_size(where)
+#else
+# ifdef HAS_MALLOC_SIZE
+# define Perl_safesysmalloc_size(where) \
+ (malloc_size(((char *)(where)) - sTHX) - sTHX)
+# endif
+# ifdef HAS_MALLOC_GOOD_SIZE
+# define Perl_malloc_good_size(how_much) \
+ (malloc_good_size((how_much) + sTHX) - sTHX)
+# else
+/* Having this as the identity operation makes some code simpler. */
+# define Perl_malloc_good_size(how_much) (how_much)
+# endif
+#endif
typedef int (CPERLscope(*runops_proc_t)) (pTHX);
typedef void (CPERLscope(*share_proc_t)) (pTHX_ SV *sv);
==== //depot/maint-5.10/perl/proto.h#8 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#7~33611~ 2008-03-31 05:32:56.000000000 -0700
+++ perl/proto.h 2008-05-27 18:21:26.000000000 -0700
@@ -88,6 +88,9 @@
__attribute__warn_unused_result__
__attribute__nonnull__(1);
+PERL_CALLCONV MEM_SIZE Perl_malloc_good_size(size_t nbytes)
+ __attribute__warn_unused_result__;
+
#endif
PERL_CALLCONV void* Perl_get_context(void)
==== //depot/maint-5.10/perl/sv.c#15 (text) ====
Index: perl/sv.c
--- perl/sv.c#14~33856~ 2008-05-18 09:11:18.000000000 -0700
+++ perl/sv.c 2008-05-27 18:21:26.000000000 -0700
@@ -1034,6 +1034,7 @@
const size_t body_size = bdp->body_size;
char *start;
const char *end;
+ const size_t arena_size = Perl_malloc_good_size(bdp->arena_size);
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
@@ -1051,20 +1052,28 @@
assert(bdp->arena_size);
- start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type);
+ start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type);
- end = start + bdp->arena_size - body_size;
+ end = start + arena_size - 2 * body_size;
/* computed count doesnt reflect the 1st slot reservation */
+#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE)
+ DEBUG_m(PerlIO_printf(Perl_debug_log,
+ "arena %p end %p arena-size %d (from %d) type %d "
+ "size %d ct %d\n",
+ (void*)start, (void*)end, (int)arena_size,
+ (int)bdp->arena_size, sv_type, (int)body_size,
+ (int)arena_size / (int)body_size));
+#else
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct
%d\n",
(void*)start, (void*)end,
(int)bdp->arena_size, sv_type, (int)body_size,
(int)bdp->arena_size / (int)body_size));
-
+#endif
*root = (void *)start;
- while (start < end) {
+ while (start <= end) {
char * const next = start + body_size;
*(void**) start = (void *)next;
start = next;
@@ -1429,15 +1438,10 @@
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv)) { /* need more room? */
+#ifndef MYMALLOC
newlen = PERL_STRLEN_ROUNDUP(newlen);
- if (SvLEN(sv) && s) {
-#ifdef MYMALLOC
- const STRLEN l = malloced_size((void*)SvPVX_const(sv));
- if (newlen <= l) {
- SvLEN_set(sv, l);
- return s;
- } else
#endif
+ if (SvLEN(sv) && s) {
s = (char*)saferealloc(s, newlen);
}
else {
@@ -1447,7 +1451,14 @@
}
}
SvPV_set(sv, s);
+#ifdef Perl_safesysmalloc_size
+ /* Do this here, do it once, do it right, and then we will never get
+ called back into sv_grow() unless there really is some growing
+ needed. */
+ SvLEN_set(sv, Perl_safesysmalloc_size(s));
+#else
SvLEN_set(sv, newlen);
+#endif
}
return s;
}
@@ -4024,7 +4035,12 @@
#endif
allocate = (flags & SV_HAS_TRAILING_NUL)
- ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+ ? len + 1 :
+#ifdef Perl_safesysmalloc_size
+ len + 1;
+#else
+ PERL_STRLEN_ROUNDUP(len + 1);
+#endif
if (flags & SV_HAS_TRAILING_NUL) {
/* It's long enough - do nothing.
Specfically Perl_newCONSTSUB is relying on this. */
@@ -4040,9 +4056,13 @@
ptr = (char*) saferealloc (ptr, allocate);
#endif
}
- SvPV_set(sv, ptr);
- SvCUR_set(sv, len);
+#ifdef Perl_safesysmalloc_size
+ SvLEN_set(sv, Perl_safesysmalloc_size(ptr));
+#else
SvLEN_set(sv, allocate);
+#endif
+ SvCUR_set(sv, len);
+ SvPV_set(sv, ptr);
if (!(flags & SV_HAS_TRAILING_NUL)) {
ptr[len] = '\0';
}
@@ -12150,6 +12170,7 @@
goto do_op2;
+ case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */
case OP_RV2SV:
case OP_CUSTOM:
match = 1; /* XS or custom code could trigger random warnings */
==== //depot/maint-5.10/perl/t/lib/warnings/7fatal#2 (text) ====
Index: perl/t/lib/warnings/7fatal
--- perl/t/lib/warnings/7fatal#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/t/lib/warnings/7fatal 2008-05-27 18:21:26.000000000 -0700
@@ -285,7 +285,8 @@
{
use warnings FATAL => qw(void) ;
- length "abc" ;
+ $a = "abc";
+ length $a ;
}
join "", 1,2,3 ;
@@ -293,7 +294,7 @@
print "done\n" ;
EXPECT
Useless use of time in void context at - line 4.
-Useless use of length in void context at - line 8.
+Useless use of length in void context at - line 9.
########
# TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) >
1 ? "Parser leaks OPs, which leak shared hash keys" : ''
@@ -303,7 +304,8 @@
{
use warnings FATAL => qw(void) ;
- length "abc" ;
+ $a = "abc";
+ length $a ;
}
join "", 1,2,3 ;
@@ -311,7 +313,7 @@
print "done\n" ;
EXPECT
Useless use of time in void context at - line 4.
-Useless use of length in void context at - line 8.
+Useless use of length in void context at - line 9.
########
use warnings FATAL => 'all';
@@ -362,35 +364,39 @@
use warnings FATAL => 'syntax', NONFATAL => 'void' ;
-length "abc";
+$a = "abc";
+length $a;
print STDERR "The End.\n" ;
EXPECT
-Useless use of length in void context at - line 4.
+Useless use of length in void context at - line 5.
The End.
########
use warnings FATAL => 'all', NONFATAL => 'void' ;
-length "abc";
+$a = "abc";
+length $a;
print STDERR "The End.\n" ;
EXPECT
-Useless use of length in void context at - line 4.
+Useless use of length in void context at - line 5.
The End.
########
use warnings FATAL => 'all', NONFATAL => 'void' ;
my $a ; chomp $a;
-length "abc";
+
+$b = "abc" ;
+length $b;
print STDERR "The End.\n" ;
EXPECT
-Useless use of length in void context at - line 5.
+Useless use of length in void context at - line 7.
Use of uninitialized value $a in scalar chomp at - line 4.
########
use warnings FATAL => 'void', NONFATAL => 'void' ;
-
-length "abc";
+$a = "abc";
+length $a;
print STDERR "The End.\n" ;
EXPECT
Useless use of length in void context at - line 4.
@@ -399,8 +405,8 @@
# TODO ? !$Config{usethreads} && $::UTF8 && ($ENV{PERL_DESTRUCT_LEVEL} || 0) >
1 ? "Parser leaks OPs, which leak shared hash keys" : ''
use warnings NONFATAL => 'void', FATAL => 'void' ;
-
-length "abc";
+$a = "abc";
+length $a;
print STDERR "The End.\n" ;
EXPECT
Useless use of length in void context at - line 4.
==== //depot/maint-5.10/perl/t/lib/warnings/9uninit#4 (text) ====
Index: perl/t/lib/warnings/9uninit
--- perl/t/lib/warnings/9uninit#3~33880~ 2008-05-20 05:15:13.000000000
-0700
+++ perl/t/lib/warnings/9uninit 2008-05-27 18:21:26.000000000 -0700
@@ -669,6 +669,9 @@
$foo =~ s//$g1/;
$foo =~ s/$m1/$g1/;
$foo =~ s/./$m1/e;
+undef $g1;
+$m1 = '$g1';
+$foo =~ s//$m1/ee;
EXPECT
Use of uninitialized value $_ in pattern match (m//) at - line 5.
Use of uninitialized value $m1 in regexp compilation at - line 6.
@@ -731,6 +734,7 @@
Use of uninitialized value $m1 in regexp compilation at - line 40.
Use of uninitialized value $g1 in substitution iterator at - line 40.
Use of uninitialized value $m1 in substitution iterator at - line 41.
+Use of uninitialized value in substitution iterator at - line 44.
########
use warnings 'uninitialized';
my ($m1);
@@ -1298,13 +1302,15 @@
Use of uninitialized value $g1 in gmtime at - line 6.
########
use warnings 'uninitialized';
-my ($m1, $v);
+my ($m1, $m2, $v);
$v = eval;
$v = eval $m1;
+$m2 = q($m1); $v = 1 + eval $m2;
EXPECT
Use of uninitialized value $_ in eval "string" at - line 4.
Use of uninitialized value $m1 in eval "string" at - line 5.
+Use of uninitialized value in addition (+) at - line 6.
########
use warnings 'uninitialized';
my ($m1);
==== //depot/maint-5.10/perl/t/mro/next_edgecases.t#2 (text) ====
Index: perl/t/mro/next_edgecases.t
--- perl/t/mro/next_edgecases.t#1~32694~ 2007-12-22 01:23:09.000000000
-0800
+++ perl/t/mro/next_edgecases.t 2008-05-27 18:21:26.000000000 -0700
@@ -3,7 +3,7 @@
use strict;
use warnings;
-require q(./test.pl); plan(tests => 11);
+require q(./test.pl); plan(tests => 12);
{
@@ -78,5 +78,16 @@
eval { $baz->bar() };
ok($@, '... calling bar() with next::method failed') || diag $@;
- }
+ }
+
+ # Test with non-existing class (used to segfault)
+ {
+ package Qux;
+ use mro;
+ sub foo { No::Such::Class->next::can }
+ }
+
+ eval { Qux->foo() };
+ is($@, '', "->next::can on non-existing package name");
+
}
End of Patch.
