Change 19844 by [EMAIL PROTECTED] on 2003/06/22 19:38:58
Integrate:
[ 19830]
Retract #19785 and #19756: JPL nowadays works without this
(verified by a true JPL user).
[ 19831]
More Perl malloc debugging magic from Ilya. Seems to work in
Linux, Solaris, AIX. Had to do #ifdef OS2 for the <io.h> in
malloc.c, found in AIX since there is no such header.
In Tru64 miniperl fails an assert: "free()ed/realloc()ed-away
memory was overwritten?"
(In IRIX compiles but that doesn't prove much since in IRIX
Perl's malloc is simply not used.)
[ 19832]
Show the source code location of an "assertion botch".
[ 19833]
Don't do sprintf().
[ 19834]
Allow for things like -DFILL_CHECK_DEFAULT=0 (from Ilya).
[ 19835]
For characters beyond the BMP the $bits will be undef,
which will cause utf8_heavy.pl noise (reported by Daniel Yacob,
analysis and fix from SADAHIRO Tomoyuki)
[ 19836]
Debian fix from Brendan O'Dea:
Bug#156284: the stucture used by pp_accept is too small to hold an
IPv6 address.
[ 19837]
Debian fix from Brendan O'Dea:
Use a temporary directory to avoid symlink attacks.
Specify -gstabs explicitly (not the default format for gcc 3.2).
[ 19838]
Debian fix from Brendan O'Dea:
Adjust output to screen width.
(adjusted to probe for the stty command)
[ 19839]
Subject: FileCache 1.03 broken on VMS -- possible patch
From: "Craig A. Berry" <[EMAIL PROTECTED]>
Date: Sat, 21 Jun 2003 10:31:59 -0500
Message-ID: <[EMAIL PROTECTED]>
[ 19840]
Subject: [perl #22753] overload::StrVal() fails for regexp refs
From: "[EMAIL PROTECTED] (via RT)" <[EMAIL PROTECTED]>
Date: 21 Jun 2003 19:02:30 -0000
Message-ID: <[EMAIL PROTECTED]>
[ 19841]
Subject: [PATCH] Re: Is it a Bug? ($c .= "5") . "6"
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Sat, 21 Jun 2003 03:19:31 +0300
Message-ID: <[EMAIL PROTECTED]>
[ 19842]
Until the Perl malloc problems in Tru64 are fixed.
[ 19843]
Move the (pseudo)seed functio for (pseudo)random numbers to util.c.
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#63 integrate
... //depot/maint-5.8/perl/dosish.h#7 integrate
... //depot/maint-5.8/perl/embed.fnc#31 integrate
... //depot/maint-5.8/perl/embed.h#34 integrate
... //depot/maint-5.8/perl/epoc/epocish.h#3 integrate
... //depot/maint-5.8/perl/hints/dec_osf.sh#6 integrate
... //depot/maint-5.8/perl/lib/FileCache.pm#3 integrate
... //depot/maint-5.8/perl/lib/FileCache/t/01open.t#2 integrate
... //depot/maint-5.8/perl/lib/FileCache/t/03append.t#2 integrate
... //depot/maint-5.8/perl/lib/FileCache/t/05override.t#2 integrate
... //depot/maint-5.8/perl/lib/overload.pm#3 integrate
... //depot/maint-5.8/perl/lib/overload.t#3 integrate
... //depot/maint-5.8/perl/lib/utf8_heavy.pl#4 integrate
... //depot/maint-5.8/perl/malloc.c#3 integrate
... //depot/maint-5.8/perl/malloc_ctl.h#1 branch
... //depot/maint-5.8/perl/op.c#32 integrate
... //depot/maint-5.8/perl/os2/os2ish.h#4 integrate
... //depot/maint-5.8/perl/perl.c#35 integrate
... //depot/maint-5.8/perl/perl.h#33 integrate
... //depot/maint-5.8/perl/plan9/plan9ish.h#3 integrate
... //depot/maint-5.8/perl/pp.c#23 integrate
... //depot/maint-5.8/perl/pp_sys.c#24 integrate
... //depot/maint-5.8/perl/proto.h#29 integrate
... //depot/maint-5.8/perl/sv.c#53 integrate
... //depot/maint-5.8/perl/t/op/concat.t#3 integrate
... //depot/maint-5.8/perl/unixish.h#6 integrate
... //depot/maint-5.8/perl/util.c#23 integrate
... //depot/maint-5.8/perl/utils/c2ph.PL#3 integrate
... //depot/maint-5.8/perl/utils/dprofpp.PL#4 integrate
... //depot/maint-5.8/perl/vms/vmsish.h#4 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#63 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#62~19791~ Sun Jun 15 10:57:06 2003
+++ perl/MANIFEST Sun Jun 22 12:38:58 2003
@@ -2082,6 +2082,7 @@
Makefile.micro microperl Makefile
Makefile.SH A script that generates Makefile
malloc.c A version of malloc you might not want
+malloc_ctl.h A version of malloc you might not want
MANIFEST This list of files
mg.c Magic code
mg.h Magic header
==== //depot/maint-5.8/perl/dosish.h#7 (text) ====
Index: perl/dosish.h
--- perl/dosish.h#6~19515~ Tue May 13 10:51:05 2003
+++ perl/dosish.h Sun Jun 22 12:38:58 2003
@@ -16,7 +16,7 @@
#ifdef DJGPP
# define BIT_BUCKET "nul"
# define OP_BINARY O_BINARY
-# define PERL_SYS_INIT(c,v) Perl_DJGPP_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v)
# define init_os_extras Perl_init_os_extras
# include <signal.h>
# define HAS_UTIME
@@ -32,15 +32,15 @@
# define PERL_FS_VER_FMT "%d_%d_%d"
#else /* DJGPP */
# ifdef WIN32
-# define PERL_SYS_INIT(c,v) Perl_win32_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v)
# define PERL_SYS_TERM() Perl_win32_term()
# define BIT_BUCKET "nul"
# else
# ifdef NETWARE
-# define PERL_SYS_INIT(c,v) Perl_nw5_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v)
# define BIT_BUCKET "nwnul"
# else
-# define PERL_SYS_INIT(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v)
# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?"
*/
# endif /* NETWARE */
# endif
==== //depot/maint-5.8/perl/embed.fnc#31 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#30~19823~ Thu Jun 19 07:51:22 2003
+++ perl/embed.fnc Sun Jun 22 12:38:58 2003
@@ -851,6 +851,7 @@
p |void |vivify_ref |SV* sv|U32 to_what
p |I32 |wait4pid |Pid_t pid|int* statusp|int flags
p |U32 |parse_unicode_opts|char **popt
+p |U32 |seed
p |void |report_evil_fh |GV *gv|IO *io|I32 op
pd |void |report_uninit
Afpd |void |warn |const char* pat|...
@@ -1082,7 +1083,6 @@
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
s |SV* |refto |SV* sv
-s |U32 |seed
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/embed.h#34 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#33~19823~ Thu Jun 19 07:51:22 2003
+++ perl/embed.h Sun Jun 22 12:38:58 2003
@@ -1130,6 +1130,9 @@
#define parse_unicode_opts Perl_parse_unicode_opts
#endif
#ifdef PERL_CORE
+#define seed Perl_seed
+#endif
+#ifdef PERL_CORE
#define report_evil_fh Perl_report_evil_fh
#endif
#ifdef PERL_CORE
@@ -1501,9 +1504,6 @@
#ifdef PERL_CORE
#define refto S_refto
#endif
-#ifdef PERL_CORE
-#define seed S_seed
-#endif
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
@@ -3634,6 +3634,9 @@
#define parse_unicode_opts(a) Perl_parse_unicode_opts(aTHX_ a)
#endif
#ifdef PERL_CORE
+#define seed() Perl_seed(aTHX)
+#endif
+#ifdef PERL_CORE
#define report_evil_fh(a,b,c) Perl_report_evil_fh(aTHX_ a,b,c)
#endif
#ifdef PERL_CORE
@@ -3998,9 +4001,6 @@
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define refto(a) S_refto(aTHX_ a)
-#endif
-#ifdef PERL_CORE
-#define seed() S_seed(aTHX)
#endif
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/epoc/epocish.h#3 (text) ====
Index: perl/epoc/epocish.h
--- perl/epoc/epocish.h#2~19611~ Sat May 24 00:50:43 2003
+++ perl/epoc/epocish.h Sun Jun 22 12:38:58 2003
@@ -108,7 +108,7 @@
/* epocemx setenv bug workaround */
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) putenv(".dummy=foo"); putenv(".dummy"); MALLOC_INIT
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) putenv(".dummy=foo");
putenv(".dummy"); MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/hints/dec_osf.sh#6 (text) ====
Index: perl/hints/dec_osf.sh
--- perl/hints/dec_osf.sh#5~19093~ Sun Mar 30 07:16:16 2003
+++ perl/hints/dec_osf.sh Sun Jun 22 12:38:58 2003
@@ -341,8 +341,13 @@
esac
case "$usemymalloc" in
- '')
- usemymalloc='n'
+ ''|'n') usemymalloc='n'
+ ;;
+ *) # The FILLCHECK_DEADBEEF() are failing.
+ case "$ccflags" in
+ *-DFILL_CHECK_DEFAULT=*) ;;
+ *) ccflags="$ccflags -DFILL_CHECK_DEFAULT=0" ;;
+ esac
;;
esac
# These symbols are renamed in <time.h> so
==== //depot/maint-5.8/perl/lib/FileCache.pm#3 (text) ====
Index: perl/lib/FileCache.pm
--- perl/lib/FileCache.pm#2~19771~ Fri Jun 13 21:40:49 2003
+++ perl/lib/FileCache.pm Sun Jun 22 12:38:58 2003
@@ -72,6 +72,7 @@
require 5.006;
use Carp;
+use Config;
use strict;
no strict 'refs';
# These are not C<my> for legacy reasons.
@@ -88,7 +89,9 @@
*{$pkg.'::close'} = \&cacheout_close;
# Reap our children
- @{"$pkg\::SIG"}{'CLD', 'CHLD', 'PIPE'} = ('IGNORE')x3;
+ ${"$pkg\::SIG"}{'CLD'} = 'IGNORE' if $Config{sig_name} =~ /\bCLD\b/;
+ ${"$pkg\::SIG"}{'CHLD'} = 'IGNORE' if $Config{sig_name} =~ /\bCHLD\b/;
+ ${"$pkg\::SIG"}{'PIPE'} = 'IGNORE' if $Config{sig_name} =~ /\bPIPE\b/;
# Truth is okay here because setting maxopen to 0 would be bad
return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
==== //depot/maint-5.8/perl/lib/FileCache/t/01open.t#2 (text) ====
Index: perl/lib/FileCache/t/01open.t
--- perl/lib/FileCache/t/01open.t#1~19791~ Sun Jun 15 10:57:06 2003
+++ perl/lib/FileCache/t/01open.t Sun Jun 22 12:38:58 2003
@@ -2,7 +2,7 @@
use FileCache;
use vars qw(@files);
BEGIN {
- @files = qw(foo bar baz quux Foo'Bar);
+ @files = qw(foo bar baz quux Foo_Bar);
chdir 't' if -d 't';
#For tests within the perl distribution
==== //depot/maint-5.8/perl/lib/FileCache/t/03append.t#2 (text) ====
Index: perl/lib/FileCache/t/03append.t
--- perl/lib/FileCache/t/03append.t#1~19791~ Sun Jun 15 10:57:06 2003
+++ perl/lib/FileCache/t/03append.t Sun Jun 22 12:38:58 2003
@@ -2,7 +2,7 @@
use FileCache maxopen=>2;
use vars qw(@files);
BEGIN {
- @files = qw(foo bar baz quux Foo'Bar);
+ @files = qw(foo bar baz quux Foo_Bar);
chdir 't' if -d 't';
#For tests within the perl distribution
==== //depot/maint-5.8/perl/lib/FileCache/t/05override.t#2 (text) ====
Index: perl/lib/FileCache/t/05override.t
--- perl/lib/FileCache/t/05override.t#1~19791~ Sun Jun 15 10:57:06 2003
+++ perl/lib/FileCache/t/05override.t Sun Jun 22 12:38:58 2003
@@ -8,12 +8,12 @@
END;
}
END{
- unlink("Foo'Bar");
+ unlink("Foo_Bar");
}
print "1..1\n";
{# Test 5: that close is overridden properly within the caller
- cacheout local $_ = "Foo'Bar";
+ cacheout local $_ = "Foo_Bar";
print $_ "Hello World\n";
close($_);
print 'not ' if fileno($_);
==== //depot/maint-5.8/perl/lib/overload.pm#3 (text) ====
Index: perl/lib/overload.pm
--- perl/lib/overload.pm#2~18227~ Mon Dec 2 05:23:48 2002
+++ perl/lib/overload.pm Sun Jun 22 12:38:58 2003
@@ -84,10 +84,13 @@
sub AddrRef {
my $package = ref $_[0];
return "$_[0]" unless $package;
- bless $_[0], overload::Fake; # Non-overloaded package
- my $str = "$_[0]";
- bless $_[0], $package; # Back
- $package . substr $str, index $str, '=';
+
+ require Scalar::Util;
+ my $class = Scalar::Util::blessed($_[0]);
+ my $class_prefix = defined($class) ? "$class=" : "";
+ my $type = Scalar::Util::reftype($_[0]);
+ my $addr = Scalar::Util::refaddr($_[0]);
+ return sprintf("$class_prefix$type(0x%x)", $addr);
}
sub StrVal {
==== //depot/maint-5.8/perl/lib/overload.t#3 (text) ====
Index: perl/lib/overload.t
--- perl/lib/overload.t#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/lib/overload.t Sun Jun 22 12:38:58 2003
@@ -1085,5 +1085,7 @@
print defined eval { $a->{b} } ? "not ok 226\n" : "ok 226\n";
print $@ =~ /zap/ ? "ok 227\n" : "not ok 227\n";
+print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : "not
ok 228\n";
+
# Last test is:
-sub last {227}
+sub last {228}
==== //depot/maint-5.8/perl/lib/utf8_heavy.pl#4 (text) ====
Index: perl/lib/utf8_heavy.pl
--- perl/lib/utf8_heavy.pl#3~18254~ Sat Dec 7 08:26:27 2002
+++ perl/lib/utf8_heavy.pl Sun Jun 22 12:38:58 2003
@@ -160,7 +160,7 @@
}
my $extras;
- my $bits;
+ my $bits = 0;
my $ORIG = $list;
if ($list) {
==== //depot/maint-5.8/perl/malloc.c#3 (text) ====
Index: perl/malloc.c
--- perl/malloc.c#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/malloc.c Sun Jun 22 12:38:58 2003
@@ -27,9 +27,12 @@
options take a precise value, while the others are just boolean.
The boolean ones are listed first.
+ # Read configuration settings from malloc_cfg.h
+ HAVE_MALLOC_CFG_H undef
+
# Enable code for an emergency memory pool in $^M. See perlvar.pod
# for a description of $^M.
- PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && PERL_CORE)
+ PERL_EMERGENCY_SBRK (!PLAIN_MALLOC && (PERL_CORE ||
!NO_MALLOC_DYNAMIC_CFG))
# Enable code for printing memory statistics.
DEBUGGING_MSTATS (!PLAIN_MALLOC && PERL_CORE)
@@ -78,6 +81,22 @@
# pessimization, error reporting optimization
RCHECK (DEBUGGING && !NO_RCHECK)
+ # Do not overwrite uninit areas with DEBUGGING. Speed
+ # optimization, error reporting pessimization
+ NO_MFILL undef
+
+ # Overwrite uninit areas with DEBUGGING. Speed
+ # pessimization, error reporting optimization
+ MALLOC_FILL (DEBUGGING && !NO_RCHECK && !NO_MFILL)
+
+ # Do not check overwritten uninit areas with DEBUGGING. Speed
+ # optimization, error reporting pessimization
+ NO_FILL_CHECK undef
+
+ # Check overwritten uninit areas with DEBUGGING. Speed
+ # pessimization, error reporting optimization
+ MALLOC_FILL_CHECK (DEBUGGING && !NO_RCHECK && !NO_FILL_CHECK)
+
# Failed allocations bigger than this size croak (if
# PERL_EMERGENCY_SBRK is enabled) without touching $^M. See
# perlvar.pod for a description of $^M.
@@ -98,6 +117,9 @@
# Round up sbrk()s to multiples of this percent of footprint.
MIN_SBRK_FRAC 3
+ # Round up sbrk()s to multiples of this multiple of 1/1000 of footprint.
+ MIN_SBRK_FRAC1000 (10 * MIN_SBRK_FRAC)
+
# Add this much memory to big powers of two to get the bucket size.
PERL_PAGESIZE 4096
@@ -114,6 +136,20 @@
# define this to disable 12-byte bucket (will increase memory footprint)
STRICT_ALIGNMENT undef
+ # Do not allow configuration of runtime options at runtime
+ NO_MALLOC_DYNAMIC_CFG undef
+
+ # Do not allow configuration of runtime options via $ENV{PERL_MALLOC_OPT}
+ NO_PERL_MALLOC_ENV undef
+
+ [The variable consists of ;-separated parts of the form CODE=VALUE
+ with 1-character codes F, M, f, A, P, G, d, a, c for runtime
+ configuration of FIRST_SBRK, MIN_SBRK, MIN_SBRK_FRAC1000,
+ SBRK_ALLOW_FAILURES, SBRK_FAILURE_PRICE, sbrk_goodness,
+ filldead, fillalive, fillcheck. The last 3 are for DEBUGGING
+ build, and allow switching the tests for free()ed memory read,
+ uninit memory reads, and free()ed memory write.]
+
This implementation assumes that calling PerlIO_printf() does not
result in any memory allocation calls (used during a panic).
@@ -138,12 +174,30 @@
# Unsigned integer type big enough to keep a pointer
UV unsigned long
+ # Signed integer of the same sizeof() as UV
+ IV long
+
# Type of pointer with 1-byte granularity
caddr_t char *
# Type returned by free()
Free_t void
+ # Conversion of pointer to integer
+ PTR2UV(ptr) ((UV)(ptr))
+
+ # Conversion of integer to pointer
+ INT2PTR(type, i) ((type)(i))
+
+ # printf()-%-Conversion of UV to pointer
+ UVuf "lu"
+
+ # printf()-%-Conversion of UV to hex pointer
+ UVxf "lx"
+
+ # Alignment to use
+ MEM_ALIGNBYTES 4
+
# Very fatal condition reporting function (cannot call any )
fatalcroak(arg) write(2,arg,strlen(arg)) + exit(2)
@@ -168,6 +222,10 @@
MUTEX_UNLOCK(l) void
*/
+#ifdef HAVE_MALLOC_CFG_H
+# include "malloc_cfg.h"
+#endif
+
#ifndef NO_FANCY_MALLOC
# ifndef SMALL_BUCKET_VIA_TABLE
# define SMALL_BUCKET_VIA_TABLE
@@ -187,7 +245,7 @@
# ifndef TWO_POT_OPTIMIZE
# define TWO_POT_OPTIMIZE
# endif
-# if defined(PERL_CORE) && !defined(PERL_EMERGENCY_SBRK)
+# if (defined(PERL_CORE) || !defined(NO_MALLOC_DYNAMIC_CFG)) &&
!defined(PERL_EMERGENCY_SBRK)
# define PERL_EMERGENCY_SBRK
# endif
# if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
@@ -211,6 +269,12 @@
# if defined(DEBUGGING) && !defined(NO_RCHECK)
# define RCHECK
# endif
+# if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_MFILL) &&
!defined(MALLOC_FILL)
+# define MALLOC_FILL
+# endif
+# if defined(DEBUGGING) && !defined(NO_RCHECK) && !defined(NO_FILL_CHECK) &&
!defined(MALLOC_FILL_CHECK)
+# define MALLOC_FILL_CHECK
+# endif
# if defined(RCHECK) && defined(IGNORE_SMALL_BAD_FREE)
# undef IGNORE_SMALL_BAD_FREE
# endif
@@ -251,6 +315,11 @@
# define croak2 croak
# define warn2 warn
# endif
+# if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+# define PERL_MAYBE_ALIVE PL_thr_key
+# else
+# define PERL_MAYBE_ALIVE 1
+# endif
#else
# ifdef PERL_FOR_X2P
# include "../EXTERN.h"
@@ -259,6 +328,10 @@
# include <stdlib.h>
# include <stdio.h>
# include <memory.h>
+# ifdef OS2
+# include <io.h>
+# endif
+# include <string.h>
# ifndef Malloc_t
# define Malloc_t void *
# endif
@@ -274,6 +347,9 @@
# ifndef UV
# define UV unsigned long
# endif
+# ifndef IV
+# define IV long
+# endif
# ifndef caddr_t
# define caddr_t char *
# endif
@@ -284,6 +360,25 @@
# define PerlEnv_getenv getenv
# define PerlIO_printf fprintf
# define PerlIO_stderr() stderr
+# define PerlIO_puts(f,s) fputs(s,f)
+# ifndef INT2PTR
+# define INT2PTR(t,i) ((t)(i))
+# endif
+# ifndef PTR2UV
+# define PTR2UV(p) ((UV)(p))
+# endif
+# ifndef UVuf
+# define UVuf "lu"
+# endif
+# ifndef UVxf
+# define UVxf "lx"
+# endif
+# ifndef Nullch
+# define Nullch NULL
+# endif
+# ifndef MEM_ALIGNBYTES
+# define MEM_ALIGNBYTES 4
+# endif
# endif
# ifndef croak /* make depend */
# define croak(mess, arg) (warn((mess), (arg)), exit(1))
@@ -295,7 +390,7 @@
# define warn(mess, arg) fprintf(stderr, (mess), (arg))
# endif
# ifndef warn2
-# define warn2(mess, arg1) fprintf(stderr, (mess), (arg1), (arg2))
+# define warn2(mess, arg1, arg2) fprintf(stderr, (mess), (arg1), (arg2))
# endif
# ifdef DEBUG_m
# undef DEBUG_m
@@ -317,6 +412,7 @@
# ifndef PERL_GET_INTERP
# define PERL_GET_INTERP PL_curinterp
# endif
+# define PERL_MAYBE_ALIVE 1
# ifndef Perl_malloc
# define Perl_malloc malloc
# endif
@@ -332,7 +428,7 @@
# ifndef Perl_strdup
# define Perl_strdup strdup
# endif
-#endif
+#endif /* defined PERL_CORE */
#ifndef MUTEX_LOCK
# define MUTEX_LOCK(l)
@@ -358,7 +454,7 @@
# undef DEBUG_m
# define DEBUG_m(a) \
STMT_START { \
- if (PERL_GET_INTERP) { \
+ if (PERL_MAYBE_ALIVE && PERL_GET_THX) {
\
dTHX; \
if (DEBUG_m_TEST) { \
PL_debug &= ~DEBUG_m_FLAG; \
@@ -480,7 +576,7 @@
u_char ovu_index; /* bucket # */
u_char ovu_magic; /* magic number */
#ifdef RCHECK
- u_short ovu_size; /* actual block size */
+ u_short ovu_size; /* block size (requested + overhead - 1) */
u_int ovu_rmagic; /* range magic number */
#endif
} ovu;
@@ -497,7 +593,7 @@
#ifdef RCHECK
# define RSLOP sizeof (u_int)
# ifdef TWO_POT_OPTIMIZE
-# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2)
+# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */
# else
# define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
# endif
@@ -866,7 +962,7 @@
static void morecore (register int bucket);
# if defined(DEBUGGING)
-static void botch (char *diag, char *s);
+static void botch (char *diag, char *s, char *file, int line);
# endif
static void add_to_chain (void *p, MEM_SIZE size, MEM_SIZE chip);
static void* get_from_chain (MEM_SIZE size);
@@ -883,6 +979,12 @@
# define MUTEX_UNLOCK(m) STMT_START { if (*m) mutex_unlock(*m); } STMT_END
#endif
+#endif /* defined PERL_CORE */
+
+#ifndef PTRSIZE
+# define PTRSIZE sizeof(void*)
+#endif
+
#ifndef BITS_IN_PTR
# define BITS_IN_PTR (8*PTRSIZE)
#endif
@@ -908,6 +1010,92 @@
# endif
#endif
+#ifndef MIN_SBRK_FRAC1000 /* Backward compatibility */
+# define MIN_SBRK_FRAC1000 (MIN_SBRK_FRAC * 10)
+#endif
+
+#ifndef START_EXTERN_C
+# ifdef __cplusplus
+# define START_EXTERN_C extern "C" {
+# else
+# define START_EXTERN_C
+# endif
+#endif
+
+#ifndef END_EXTERN_C
+# ifdef __cplusplus
+# define END_EXTERN_C };
+# else
+# define END_EXTERN_C
+# endif
+#endif
+
+#include "malloc_ctl.h"
+
+#ifndef NO_MALLOC_DYNAMIC_CFG
+# define PERL_MALLOC_OPT_CHARS "FMfAPGdac"
+
+# ifndef FILL_DEAD_DEFAULT
+# define FILL_DEAD_DEFAULT 1
+# endif
+# ifndef FILL_ALIVE_DEFAULT
+# define FILL_ALIVE_DEFAULT 1
+# endif
+# ifndef FILL_CHECK_DEFAULT
+# define FILL_CHECK_DEFAULT 1
+# endif
+
+static IV MallocCfg[MallocCfg_last] = {
+ FIRST_SBRK,
+ MIN_SBRK,
+ MIN_SBRK_FRAC,
+ SBRK_ALLOW_FAILURES,
+ SBRK_FAILURE_PRICE,
+ SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE, /* sbrk_goodness */
+ FILL_DEAD_DEFAULT, /* FILL_DEAD */
+ FILL_ALIVE_DEFAULT, /* FILL_ALIVE */
+ FILL_CHECK_DEFAULT, /* FILL_CHECK */
+ 0, /* MallocCfg_skip_cfg_env */
+ 0, /* MallocCfg_cfg_env_read */
+ 0, /* MallocCfg_emergency_buffer_size */
+ 0, /* MallocCfg_emergency_buffer_prepared_size */
+ 0 /* MallocCfg_emergency_buffer_last_req */
+};
+IV *MallocCfg_ptr = MallocCfg;
+
+# undef MIN_SBRK
+# undef FIRST_SBRK
+# undef MIN_SBRK_FRAC1000
+# undef SBRK_ALLOW_FAILURES
+# undef SBRK_FAILURE_PRICE
+
+# define MIN_SBRK MallocCfg[MallocCfg_MIN_SBRK]
+# define FIRST_SBRK MallocCfg[MallocCfg_FIRST_SBRK]
+# define MIN_SBRK_FRAC1000 MallocCfg[MallocCfg_MIN_SBRK_FRAC1000]
+# define SBRK_ALLOW_FAILURES MallocCfg[MallocCfg_SBRK_ALLOW_FAILURES]
+# define SBRK_FAILURE_PRICE MallocCfg[MallocCfg_SBRK_FAILURE_PRICE]
+
+# define sbrk_goodness MallocCfg[MallocCfg_sbrk_goodness]
+
+# define emergency_buffer_size MallocCfg[MallocCfg_emergency_buffer_size]
+# define emergency_buffer_last_req MallocCfg[MallocCfg_emergency_buffer_last_req]
+
+# define FILL_DEAD MallocCfg[MallocCfg_filldead]
+# define FILL_ALIVE MallocCfg[MallocCfg_fillalive]
+# define FILL_CHECK_CFG MallocCfg[MallocCfg_fillcheck]
+# define FILL_CHECK (FILL_DEAD && FILL_CHECK_CFG)
+
+#else /* defined(NO_MALLOC_DYNAMIC_CFG) */
+
+# define FILL_DEAD 1
+# define FILL_ALIVE 1
+# define FILL_CHECK 1
+static int sbrk_goodness = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
+
+# define NO_PERL_MALLOC_ENV
+
+#endif
+
#ifdef DEBUGGING_MSTATS
/*
* nmalloc[i] is the difference between the number of mallocs and frees
@@ -922,27 +1110,107 @@
static u_int goodsbrk;
-# ifdef PERL_EMERGENCY_SBRK
+#ifdef PERL_EMERGENCY_SBRK
# ifndef BIG_SIZE
# define BIG_SIZE (1<<16) /* 64K */
# endif
static char *emergency_buffer;
+static char *emergency_buffer_prepared;
+
+# ifdef NO_MALLOC_DYNAMIC_CFG
static MEM_SIZE emergency_buffer_size;
-static MEM_SIZE no_mem; /* 0 if the last request for more memory succeeded.
- Otherwise the size of the failing request. */
+ /* 0 if the last request for more memory succeeded.
+ Otherwise the size of the failing request. */
+static MEM_SIZE emergency_buffer_last_req;
+# endif
+
+# ifndef emergency_sbrk_croak
+# define emergency_sbrk_croak croak2
+# endif
+
+# ifdef PERL_CORE
+static char *
+perl_get_emergency_buffer(IV *size)
+{
+ dTHX;
+ /* First offense, give a possibility to recover by dieing. */
+ /* No malloc involved here: */
+ GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
+ SV *sv;
+ char *pv;
+ STRLEN n_a;
+
+ if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
+ if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
+ || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD))
+ return NULL; /* Now die die die... */
+ /* Got it, now detach SvPV: */
+ pv = SvPV(sv, n_a);
+ /* Check alignment: */
+ if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
+ PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
+ return NULL; /* die die die */
+ }
+
+ SvPOK_off(sv);
+ SvPVX(sv) = Nullch;
+ SvCUR(sv) = SvLEN(sv) = 0;
+ *size = malloced_size(pv) + M_OVERHEAD;
+ return pv - sizeof(union overhead);
+}
+# define PERL_GET_EMERGENCY_BUFFER(p) perl_get_emergency_buffer(p)
+# else
+# define PERL_GET_EMERGENCY_BUFFER(p) NULL
+# endif /* defined PERL_CORE */
+
+# ifndef NO_MALLOC_DYNAMIC_CFG
+static char *
+get_emergency_buffer(IV *size)
+{
+ char *pv = emergency_buffer_prepared;
+
+ *size = MallocCfg[MallocCfg_emergency_buffer_prepared_size];
+ emergency_buffer_prepared = 0;
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size] = 0;
+ return pv;
+}
+
+/* Returns 0 on success, -1 on bad alignment, -2 if not implemented */
+int
+set_emergency_buffer(char *b, IV size)
+{
+ if (PTR2UV(b) & (NEEDED_ALIGNMENT - 1))
+ return -1;
+ if (MallocCfg[MallocCfg_emergency_buffer_prepared_size])
+ add_to_chain((void*)emergency_buffer_prepared,
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size], 0);
+ emergency_buffer_prepared = b;
+ MallocCfg[MallocCfg_emergency_buffer_prepared_size] = size;
+ return 0;
+}
+# define GET_EMERGENCY_BUFFER(p) get_emergency_buffer(p)
+# else /* NO_MALLOC_DYNAMIC_CFG */
+# define GET_EMERGENCY_BUFFER(p) NULL
+int
+set_emergency_buffer(char *b, IV size)
+{
+ return -1;
+}
+# endif
static Malloc_t
emergency_sbrk(MEM_SIZE size)
{
MEM_SIZE rsize = (((size - 1)>>LOG_OF_MIN_ARENA) + 1)<<LOG_OF_MIN_ARENA;
- if (size >= BIG_SIZE && (!no_mem || (size < no_mem))) {
+ if (size >= BIG_SIZE
+ && (!emergency_buffer_last_req || (size < emergency_buffer_last_req))) {
/* Give the possibility to recover, but avoid an infinite cycle. */
MALLOC_UNLOCK;
- no_mem = size;
- croak2("Out of memory during \"large\" request for %"UVuf" bytes, total sbrk()
is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+ emergency_buffer_last_req = size;
+ emergency_sbrk_croak("Out of memory during \"large\" request for %"UVuf"
bytes, total sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
}
if (emergency_buffer_size >= rsize) {
@@ -952,14 +1220,11 @@
emergency_buffer += rsize;
return old;
} else {
- dTHX;
/* First offense, give a possibility to recover by dieing. */
/* No malloc involved here: */
- GV **gvp = (GV**)hv_fetch(PL_defstash, "^M", 2, 0);
- SV *sv;
- char *pv;
+ IV Size;
+ char *pv = GET_EMERGENCY_BUFFER(&Size);
int have = 0;
- STRLEN n_a;
if (emergency_buffer_size) {
add_to_chain(emergency_buffer, emergency_buffer_size, 0);
@@ -967,53 +1232,159 @@
emergency_buffer = Nullch;
have = 1;
}
- if (!gvp) gvp = (GV**)hv_fetch(PL_defstash, "\015", 1, 0);
- if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
- || (SvLEN(sv) < (1<<LOG_OF_MIN_ARENA) - M_OVERHEAD)) {
+
+ if (!pv)
+ pv = PERL_GET_EMERGENCY_BUFFER(&Size);
+ if (!pv) {
if (have)
goto do_croak;
return (char *)-1; /* Now die die die... */
}
- /* Got it, now detach SvPV: */
- pv = SvPV(sv, n_a);
+
/* Check alignment: */
- if ((PTR2UV(pv) - sizeof(union overhead)) & (NEEDED_ALIGNMENT - 1)) {
+ if (PTR2UV(pv) & (NEEDED_ALIGNMENT - 1)) {
+ dTHX;
+
PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
return (char *)-1; /* die die die */
}
- emergency_buffer = pv - sizeof(union overhead);
- emergency_buffer_size = malloced_size(pv) + M_OVERHEAD;
- SvPOK_off(sv);
- SvPVX(sv) = Nullch;
- SvCUR(sv) = SvLEN(sv) = 0;
+ emergency_buffer = pv;
+ emergency_buffer_size = Size;
}
do_croak:
MALLOC_UNLOCK;
- croak("Out of memory during request for %"UVuf" bytes, total sbrk() is %"UVuf"
bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
+ emergency_sbrk_croak("Out of memory during request for %"UVuf" bytes, total
sbrk() is %"UVuf" bytes", (UV)size, (UV)(goodsbrk + sbrk_slack));
/* NOTREACHED */
return Nullch;
}
-# else /* !defined(PERL_EMERGENCY_SBRK) */
+#else /* !defined(PERL_EMERGENCY_SBRK) */
# define emergency_sbrk(size) -1
-# endif
-#endif /* ifdef PERL_CORE */
+#endif /* defined PERL_EMERGENCY_SBRK */
+
+static void
+write2(char *mess)
+{
+ write(2, mess, strlen(mess));
+}
#ifdef DEBUGGING
#undef ASSERT
-#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p)); else
+#define ASSERT(p,diag) if (!(p)) botch(diag,STRINGIFY(p),__FILE__,__LINE__);
else
static void
-botch(char *diag, char *s)
+botch(char *diag, char *s, char *file, int line)
{
+ if (!(PERL_MAYBE_ALIVE && PERL_GET_THX))
+ goto do_write;
+ else {
dTHX;
- PerlIO_printf(PerlIO_stderr(), "assertion botched (%s?): %s\n", diag, s);
+ if (PerlIO_printf(PerlIO_stderr(),
+ "assertion botched (%s?): %s%s %s:%d\n",
+ diag, s, file, line) != 0) {
+ do_write: /* Can be initializing interpreter */
+ write2("assertion botched (");
+ write2(diag);
+ write2("?): ");
+ write2(s);
+ write2(" (");
+ write2(file);
+ write2(":");
+ {
+ char linebuf[10];
+ char *s = linebuf + sizeof(linebuf) - 1;
+ int n = line;
+ *s = 0;
+ do {
+ *--s = '0' + (n % 10);
+ } while (n /= 10);
+ write2(s);
+ }
+ write2(")\n");
+ }
PerlProc_abort();
+ }
}
#else
#define ASSERT(p, diag)
#endif
+#ifdef MALLOC_FILL
+/* Fill should be long enough to cover long */
+static void
+fill_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
+{
+ unsigned char *e = s + nbytes;
+ long *lp;
+ long lfill = *(long*)fill;
+
+ if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
+ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
+ unsigned const char *f = fill + sizeof(long) - shift;
+ unsigned char *e1 = s + shift;
+
+ while (s < e1)
+ *s++ = *f++;
+ }
+ lp = (long*)s;
+ while ((unsigned char*)(lp + 1) <= e)
+ *lp++ = lfill;
+ s = (unsigned char*)lp;
+ while (s < e)
+ *s++ = *fill++;
+}
+/* Just malloc()ed */
+static const unsigned char fill_feedadad[] =
+ {0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD,
+ 0xFE, 0xED, 0xAD, 0xAD, 0xFE, 0xED, 0xAD, 0xAD};
+/* Just free()ed */
+static const unsigned char fill_deadbeef[] =
+ {0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF,
+ 0xDE, 0xAD, 0xBE, 0xEF, 0xDE, 0xAD, 0xBE, 0xEF};
+# define FILL_DEADBEEF(s, n) \
+ (void)(FILL_DEAD? (fill_pat_4bytes((s), (n), fill_deadbeef), 0) : 0)
+# define FILL_FEEDADAD(s, n) \
+ (void)(FILL_ALIVE? (fill_pat_4bytes((s), (n), fill_feedadad), 0) : 0)
+#else
+# define FILL_DEADBEEF(s, n) ((void)0)
+# define FILL_FEEDADAD(s, n) ((void)0)
+# undef MALLOC_FILL_CHECK
+#endif
+
+#ifdef MALLOC_FILL_CHECK
+static int
+cmp_pat_4bytes(unsigned char *s, size_t nbytes, const unsigned char *fill)
+{
+ unsigned char *e = s + nbytes;
+ long *lp;
+ long lfill = *(long*)fill;
+
+ if (PTR2UV(s) & (sizeof(long)-1)) { /* Align the pattern */
+ int shift = sizeof(long) - (PTR2UV(s) & (sizeof(long)-1));
+ unsigned const char *f = fill + sizeof(long) - shift;
+ unsigned char *e1 = s + shift;
+
+ while (s < e1)
+ if (*s++ != *f++)
+ return 1;
+ }
+ lp = (long*)s;
+ while ((unsigned char*)(lp + 1) <= e)
+ if (*lp++ != lfill)
+ return 1;
+ s = (unsigned char*)lp;
+ while (s < e)
+ if (*s++ != *fill++)
+ return 1;
+ return 0;
+}
+# define FILLCHECK_DEADBEEF(s, n) \
+ ASSERT(!FILL_CHECK || !cmp_pat_4bytes(s, n, fill_deadbeef), \
+ "free()ed/realloc()ed-away memory was overwritten")
+#else
+# define FILLCHECK_DEADBEEF(s, n) ((void)0)
+#endif
+
Malloc_t
Perl_malloc(register size_t nbytes)
{
@@ -1111,14 +1482,17 @@
}
/* remove from linked list */
-#if defined(RCHECK)
- if ((PTR2UV(p)) & (MEM_ALIGNBYTES - 1)) {
+#ifdef DEBUGGING
+ if ( (PTR2UV(p) & (MEM_ALIGNBYTES - 1))
+ /* Can't get this low */
+ || (p && PTR2UV(p) < (1<<LOG_OF_MIN_ARENA)) ) {
dTHX;
PerlIO_printf(PerlIO_stderr(),
"Unaligned pointer in the free chain 0x%"UVxf"\n",
PTR2UV(p));
}
- if ((PTR2UV(p->ov_next)) & (MEM_ALIGNBYTES - 1)) {
+ if ( (PTR2UV(p->ov_next) & (MEM_ALIGNBYTES - 1))
+ || (p->ov_next && PTR2UV(p->ov_next) < (1<<LOG_OF_MIN_ARENA)) ) {
dTHX;
PerlIO_printf(PerlIO_stderr(),
"Unaligned `next' pointer in the free "
@@ -1135,6 +1509,9 @@
PTR2UV((Malloc_t)(p + CHUNK_SHIFT)), (unsigned
long)(PL_an++),
(long)size));
+ FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
+ BUCKET_SIZE_REAL(bucket));
+
#ifdef IGNORE_SMALL_BAD_FREE
if (bucket >= FIRST_BUCKET_WITH_CHECK)
#endif
@@ -1161,6 +1538,7 @@
nbytes = (nbytes + 3) &~ 3;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
}
+ FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size);
#endif
return ((Malloc_t)(p + CHUNK_SHIFT));
}
@@ -1168,7 +1546,6 @@
static char *last_sbrk_top;
static char *last_op; /* This arena can be easily extended. */
static MEM_SIZE sbrked_remains;
-static int sbrk_good = SBRK_ALLOW_FAILURES * SBRK_FAILURE_PRICE;
#ifdef DEBUGGING_MSTATS
static int sbrks;
@@ -1274,13 +1651,13 @@
union overhead *ovp;
MEM_SIZE slack = 0;
- if (sbrk_good > 0) {
+ if (sbrk_goodness > 0) {
if (!last_sbrk_top && require < FIRST_SBRK)
require = FIRST_SBRK;
else if (require < MIN_SBRK) require = MIN_SBRK;
- if (require < goodsbrk * MIN_SBRK_FRAC / 100)
- require = goodsbrk * MIN_SBRK_FRAC / 100;
+ if (require < goodsbrk * MIN_SBRK_FRAC1000 / 1000)
+ require = goodsbrk * MIN_SBRK_FRAC1000 / 1000;
require = ((require - 1 + MIN_SBRK) / MIN_SBRK) * MIN_SBRK;
} else {
require = needed;
@@ -1297,7 +1674,7 @@
#endif
if (cp == last_sbrk_top) {
/* Common case, anything is fine. */
- sbrk_good++;
+ sbrk_goodness++;
ovp = (union overhead *) (cp - sbrked_remains);
last_op = cp - sbrked_remains;
sbrked_remains = require - (needed - sbrked_remains);
@@ -1369,7 +1746,7 @@
if (cp == (char *)-1)
return 0;
}
- sbrk_good = -1; /* Disable optimization!
+ sbrk_goodness = -1; /* Disable optimization!
Continue with not-aligned... */
} else {
cp += slack;
@@ -1378,7 +1755,7 @@
}
if (last_sbrk_top) {
- sbrk_good -= SBRK_FAILURE_PRICE;
+ sbrk_goodness -= SBRK_FAILURE_PRICE;
}
ovp = (union overhead *) cp;
@@ -1411,7 +1788,7 @@
last_op = cp;
}
#if !defined(PLAIN_MALLOC) && !defined(NO_FANCY_MALLOC)
- no_mem = 0;
+ emergency_buffer_last_req = 0;
#endif
last_sbrk_top = cp + require;
#ifdef DEBUGGING_MSTATS
@@ -1450,7 +1827,7 @@
add_to_chain((void*)(last_sbrk_top - sbrked_remains),
sbrked_remains, 0);
add_to_chain((void*)cp, require, 0);
- sbrk_good -= SBRK_FAILURE_PRICE;
+ sbrk_goodness -= SBRK_FAILURE_PRICE;
sbrked_remains = 0;
last_sbrk_top = 0;
last_op = 0;
@@ -1471,9 +1848,44 @@
register int rnu; /* 2^rnu bytes will be requested */
int nblks; /* become nblks blocks of the desired size */
register MEM_SIZE siz, needed;
+ static int were_called = 0;
if (nextf[bucket])
return;
+#ifndef NO_PERL_MALLOC_ENV
+ if (!were_called) {
+ /* It's the our first time. Initialize ourselves */
+ were_called = 1; /* Avoid a loop */
+ if (!MallocCfg[MallocCfg_skip_cfg_env]) {
+ char *s = getenv("PERL_MALLOC_OPT"), *t = s, *off;
+ const char *opts = PERL_MALLOC_OPT_CHARS;
+ int changed = 0;
+
+ while ( t && t[0] && t[1] == '='
+ && ((off = strchr(opts, *t))) ) {
+ IV val = 0;
+
+ t += 2;
+ while (*t <= '9' && *t >= '0')
+ val = 10*val + *t++ - '0';
+ if (!*t || *t == ';') {
+ if (MallocCfg[off - opts] != val)
+ changed = 1;
+ MallocCfg[off - opts] = val;
+ if (*t)
+ t++;
+ }
+ }
+ if (t && *t) {
+ write2("Unrecognized part of PERL_MALLOC_OPT: `");
+ write2(t);
+ write2("'\n");
+ }
+ if (changed)
+ MallocCfg[MallocCfg_cfg_env_read] = 1;
+ }
+ }
+#endif
if (bucket == sizeof(MEM_SIZE)*8*BUCKETS_PER_POW2) {
MALLOC_UNLOCK;
croak("%s", "Out of memory during ridiculously large request");
@@ -1518,6 +1930,7 @@
if (!ovp)
return;
+ FILL_DEADBEEF((unsigned char*)ovp, needed);
/*
* Add new memory allocated to that on
@@ -1544,6 +1957,7 @@
start_slack += M_OVERHEAD * nblks;
}
#endif
+
while (--nblks > 0) {
ovp->ov_next = (union overhead *)((caddr_t)ovp + siz);
ovp = (union overhead *)((caddr_t)ovp + siz);
@@ -1577,6 +1991,10 @@
if (cp == NULL)
return;
+#ifdef DEBUGGING
+ if (PTR2UV(cp) & (MEM_ALIGNBYTES - 1))
+ croak("%s", "wrong alignment in free()");
+#endif
ovp = (union overhead *)((caddr_t)cp
- sizeof (union overhead) * CHUNK_SHIFT);
#ifdef PACK_MALLOC
@@ -1638,7 +2056,10 @@
}
nbytes = (nbytes + 3) &~ 3;
ASSERT(*(u_int *)((caddr_t)ovp + nbytes - RSLOP) == RMAGIC, "chunk's tail
overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes - RSLOP +
sizeof(u_int)),
+ BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nbytes - RSLOP +
sizeof(u_int)));
}
+ FILL_DEADBEEF((unsigned char*)(ovp+1), BUCKET_SIZE_REAL(OV_INDEX(ovp)));
ovp->ov_rmagic = RMAGIC - 1;
#endif
ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
@@ -1708,9 +2129,9 @@
? "of freed memory " : "");
}
#else
- warn("%srealloc() %signored",
- (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
- ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
+ warn2("%srealloc() %signored",
+ (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+ ovp->ov_rmagic == RMAGIC - 1 ? "of freed memory " : "");
#endif
#else
#ifdef PERL_CORE
@@ -1776,6 +2197,14 @@
}
nb = (nb + 3) &~ 3;
ASSERT(*(u_int *)((caddr_t)ovp + nb - RSLOP) == RMAGIC,
"chunk's tail overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb - RSLOP +
sizeof(u_int)),
+ BUCKET_SIZE_REAL(OV_INDEX(ovp)) - (nb - RSLOP +
sizeof(u_int)));
+ if (nbytes > ovp->ov_size + 1 - M_OVERHEAD)
+ FILL_FEEDADAD((unsigned char*)cp + ovp->ov_size + 1 -
M_OVERHEAD,
+ nbytes - (ovp->ov_size + 1 - M_OVERHEAD));
+ else
+ FILL_DEADBEEF((unsigned char*)cp + nbytes,
+ nb - M_OVERHEAD + RSLOP - nbytes);
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
@@ -1954,7 +2383,7 @@
}
buf->total_sbrk = goodsbrk + sbrk_slack;
buf->sbrks = sbrks;
- buf->sbrk_good = sbrk_good;
+ buf->sbrk_good = sbrk_goodness;
buf->sbrk_slack = sbrk_slack;
buf->start_slack = start_slack;
buf->sbrked_remains = sbrked_remains;
==== //depot/maint-5.8/perl/malloc_ctl.h#1 (text) ====
Index: perl/malloc_ctl.h
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/malloc_ctl.h Sun Jun 22 12:38:58 2003
@@ -0,0 +1,54 @@
+#ifndef MALLOC_CTL_H
+# define MALLOC_CTL_H
+
+struct perl_mstats {
+ UV *nfree;
+ UV *ntotal;
+ IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
+ IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
+ IV minbucket;
+ /* Level 1 info */
+ UV *bucket_mem_size;
+ UV *bucket_available_size;
+ UV nbuckets;
+};
+typedef struct perl_mstats perl_mstats_t;
+
+START_EXTERN_C
+Malloc_t Perl_malloc (MEM_SIZE nbytes);
+Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size);
+Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes);
+/* 'mfree' rather than 'free', since there is already a 'perl_free'
+ * that causes clashes with case-insensitive linkers */
+Free_t Perl_mfree (Malloc_t where);
+END_EXTERN_C
+
+#ifndef NO_MALLOC_DYNAMIC_CFG
+
+enum {
+ MallocCfg_FIRST_SBRK,
+ MallocCfg_MIN_SBRK,
+ MallocCfg_MIN_SBRK_FRAC1000,
+ MallocCfg_SBRK_ALLOW_FAILURES,
+ MallocCfg_SBRK_FAILURE_PRICE,
+ MallocCfg_sbrk_goodness,
+
+ MallocCfg_filldead,
+ MallocCfg_fillalive,
+ MallocCfg_fillcheck,
+
+ MallocCfg_skip_cfg_env,
+ MallocCfg_cfg_env_read,
+
+ MallocCfg_emergency_buffer_size,
+ MallocCfg_emergency_buffer_last_req,
+
+ MallocCfg_emergency_buffer_prepared_size,
+
+ MallocCfg_last
+};
+extern IV *MallocCfg_ptr;
+
+#endif
+
+#endif
==== //depot/maint-5.8/perl/op.c#32 (text) ====
Index: perl/op.c
--- perl/op.c#31~19738~ Tue Jun 10 22:13:38 2003
+++ perl/op.c Sun Jun 22 12:38:58 2003
@@ -4791,8 +4791,9 @@
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- if (cUNOPo->op_first->op_type == OP_CONCAT)
- o->op_flags |= OPf_STACKED;
+ OP *kid = cUNOPo->op_first;
+ if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
+ o->op_flags |= OPf_STACKED;
return o;
}
==== //depot/maint-5.8/perl/os2/os2ish.h#4 (text) ====
Index: perl/os2/os2ish.h
--- perl/os2/os2ish.h#3~19791~ Sun Jun 15 10:57:06 2003
+++ perl/os2/os2ish.h Sun Jun 22 12:38:58 2003
@@ -220,6 +220,7 @@
# define PERL_SYS_INIT3(argcp, argvp, envp) \
{ void *xreg[2]; \
+ MALLOC_CHECK_TAINT(*argcp, *argvp, *envp) \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
Perl_OS2_init3(*envp, xreg, 0)
==== //depot/maint-5.8/perl/perl.c#35 (text) ====
Index: perl/perl.c
--- perl/perl.c#34~19791~ Sun Jun 15 10:57:06 2003
+++ perl/perl.c Sun Jun 22 12:38:58 2003
@@ -1162,6 +1162,7 @@
break;
case 't':
+ CHECK_MALLOC_TOO_LATE_FOR('t');
if( !PL_tainting ) {
PL_taint_warn = TRUE;
PL_tainting = TRUE;
@@ -1169,6 +1170,7 @@
s++;
goto reswitch;
case 'T':
+ CHECK_MALLOC_TOO_LATE_FOR('T');
PL_tainting = TRUE;
PL_taint_warn = FALSE;
s++;
@@ -1351,6 +1353,7 @@
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
+ CHECK_MALLOC_TOO_LATE_FOR('T');
PL_tainting = TRUE;
PL_taint_warn = FALSE;
}
@@ -2539,12 +2542,12 @@
return s;
case 't':
if (!PL_tainting)
- Perl_croak(aTHX_ "Too late for \"-t\" option");
+ TOO_LATE_FOR('t');
s++;
return s;
case 'T':
if (!PL_tainting)
- Perl_croak(aTHX_ "Too late for \"-T\" option");
+ TOO_LATE_FOR('T');
s++;
return s;
case 'u':
@@ -3402,9 +3405,37 @@
PL_uid |= PL_gid << 16;
PL_euid |= PL_egid << 16;
#endif
+ /* Should not happen: */
+ CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
}
+#ifdef MYMALLOC
+/* This is used very early in the lifetime of the program. */
+int
+Perl_doing_taint(int argc, char *argv[], char *envp[])
+{
+ int uid = PerlProc_getuid();
+ int euid = PerlProc_geteuid();
+ int gid = PerlProc_getgid();
+ int egid = PerlProc_getegid();
+
+#ifdef VMS
+ uid |= gid << 16;
+ euid |= egid << 16;
+#endif
+ if (uid && (euid != uid || egid != gid))
+ return 1;
+ /* This is a really primitive check; $ENV{PERL_MALLOC_OPT} is
+ ignored only if -T are the first chars together; otherwise one
+ gets "Too late" message. */
+ if ( argc > 1 && argv[1][0] == '-'
+ && (argv[1][1] == 't' || argv[1][1] == 'T') )
+ return 1;
+ return 0;
+}
+#endif
+
STATIC void
S_forbid_setid(pTHX_ char *s)
{
@@ -3632,10 +3663,6 @@
char *s;
SV *sv;
GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- char **dup_env_base = 0;
- int dup_env_count = 0;
-#endif
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3690,26 +3717,6 @@
{
environ[0] = Nullch;
}
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- {
- char **env_base;
- for (env_base = env; *env; env++)
- dup_env_count++;
- if ((dup_env_base = (char **)
- safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
- char **dup_env;
- for (env = env_base, dup_env = dup_env_base;
- *env;
- env++, dup_env++) {
- /* With environ one needs to use safesysmalloc(). */
- *dup_env = safesysmalloc(strlen(*env) + 1);
- (void)strcpy(*dup_env, *env);
- }
- *dup_env = Nullch;
- env = dup_env_base;
- } /* else what? */
- }
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
if (env)
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
@@ -3724,14 +3731,6 @@
if (env != environ)
mg_set(sv);
}
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- if (dup_env_base) {
- char **dup_env;
- for (dup_env = dup_env_base; *dup_env; dup_env++)
- safesysfree(*dup_env);
- safesysfree(dup_env_base);
- }
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
#endif /* USE_ENVIRON_ARRAY */
}
TAINT_NOT;
==== //depot/maint-5.8/perl/perl.h#33 (text) ====
Index: perl/perl.h
--- perl/perl.h#32~19771~ Fri Jun 13 21:40:49 2003
+++ perl/perl.h Sun Jun 22 12:38:58 2003
@@ -500,28 +500,43 @@
# else
# define EMBEDMYMALLOC /* for compatibility */
# endif
-START_EXTERN_C
-Malloc_t Perl_malloc (MEM_SIZE nbytes);
-Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size);
-Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes);
-/* 'mfree' rather than 'free', since there is already a 'perl_free'
- * that causes clashes with case-insensitive linkers */
-Free_t Perl_mfree (Malloc_t where);
-END_EXTERN_C
-
-typedef struct perl_mstats perl_mstats_t;
# define safemalloc Perl_malloc
# define safecalloc Perl_calloc
# define saferealloc Perl_realloc
# define safefree Perl_mfree
+# define CHECK_MALLOC_TOO_LATE_FOR_(code) STMT_START { \
+ if (!PL_tainting && MallocCfg_ptr[MallocCfg_cfg_env_read]) \
+ code; \
+ } STMT_END
+# define CHECK_MALLOC_TOO_LATE_FOR(ch) \
+ CHECK_MALLOC_TOO_LATE_FOR_(MALLOC_TOO_LATE_FOR(ch))
+# define panic_write2(s) write(2, s, strlen(s))
+# define CHECK_MALLOC_TAINT(newval) \
+ CHECK_MALLOC_TOO_LATE_FOR_( \
+ if (newval) { \
+ panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\
+ exit(1); })
+extern int Perl_doing_taint(int argc, char *argv[], char *envp[]);
+# define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \
+ if (Perl_doing_taint(argc, argv, env)) { \
+ MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
+ }} STMT_END;
#else /* MYMALLOC */
# define safemalloc safesysmalloc
# define safecalloc safesyscalloc
# define saferealloc safesysrealloc
# define safefree safesysfree
+# define CHECK_MALLOC_TOO_LATE_FOR(ch) ((void)0)
+# define CHECK_MALLOC_TAINT(newval) ((void)0)
+# 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) 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)
+
#if !defined(HAS_STRCHR) && defined(HAS_INDEX) && !defined(strchr)
#define strchr index
#define strrchr rindex
@@ -1712,17 +1727,10 @@
#endif
-struct perl_mstats {
- UV *nfree;
- UV *ntotal;
- IV topbucket, topbucket_ev, topbucket_odd, totfree, total, total_chain;
- IV total_sbrk, sbrks, sbrk_good, sbrk_slack, start_slack, sbrked_remains;
- IV minbucket;
- /* Level 1 info */
- UV *bucket_mem_size;
- UV *bucket_available_size;
- UV nbuckets;
-};
+#ifdef MYMALLOC
+# include "malloc_ctl.h"
+#endif
+
struct RExC_state_t;
typedef MEM_SIZE STRLEN;
@@ -1969,13 +1977,6 @@
# define PERL_FPU_INIT
# endif
# endif
-#endif
-
-#ifdef JPL
- /* E.g. JPL needs to operate on a copy of the real environment.
- * JDK 1.2 and 1.3 seem to get upset if the original environment
- * is diddled with. */
-# define NEED_ENVIRON_DUP_FOR_MODIFY
#endif
#ifndef PERL_SYS_INIT3
==== //depot/maint-5.8/perl/plan9/plan9ish.h#3 (text) ====
Index: perl/plan9/plan9ish.h
--- perl/plan9/plan9ish.h#2~18587~ Sun Jan 26 01:29:52 2003
+++ perl/plan9/plan9ish.h Sun Jun 22 12:38:58 2003
@@ -106,7 +106,7 @@
#define ABORT() kill(PerlProc_getpid(),SIGABRT);
#define BIT_BUCKET "/dev/null"
-#define PERL_SYS_INIT(c,v) MALLOC_INIT
+#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) MALLOC_INIT
#define dXSUB_SYS
#define PERL_SYS_TERM() MALLOC_TERM
==== //depot/maint-5.8/perl/pp.c#23 (text) ====
Index: perl/pp.c
--- perl/pp.c#22~19817~ Wed Jun 18 22:24:45 2003
+++ perl/pp.c Sun Jun 22 12:38:58 2003
@@ -2724,87 +2724,6 @@
RETPUSHYES;
}
-STATIC U32
-S_seed(pTHX)
-{
- /*
- * This is really just a quick hack which grabs various garbage
- * values. It really should be a real hash algorithm which
- * spreads the effect of every input bit onto every output bit,
- * if someone who knows about such things would bother to write it.
- * Might be a good idea to add that function to CORE as well.
- * No numbers below come from careful analysis or anything here,
- * except they are primes and SEED_C1 > 1E6 to get a full-width
- * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
- * probably be bigger too.
- */
-#if RANDBITS > 16
-# define SEED_C1 1000003
-#define SEED_C4 73819
-#else
-# define SEED_C1 25747
-#define SEED_C4 20639
-#endif
-#define SEED_C2 3
-#define SEED_C3 269
-#define SEED_C5 26107
-
-#ifndef PERL_NO_DEV_RANDOM
- int fd;
-#endif
- U32 u;
-#ifdef VMS
-# include <starlet.h>
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
- struct timeval when;
-# else
- Time_t when;
-# endif
-#endif
-
-/* This test is an escape hatch, this symbol isn't set by Configure. */
-#ifndef PERL_NO_DEV_RANDOM
-#ifndef PERL_RANDOM_DEVICE
- /* /dev/random isn't used by default because reads from it will block
- * if there isn't enough entropy available. You can compile with
- * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
- * is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
-#endif
- fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
- if (fd != -1) {
- if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
- u = 0;
- PerlLIO_close(fd);
- if (u)
- return u;
- }
-#endif
-
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
- PerlProc_gettimeofday(&when,NULL);
- u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
- (void)time(&when);
- u = (U32)SEED_C1 * when;
-# endif
-#endif
- u += SEED_C3 * (U32)PerlProc_getpid();
- u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
-#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)PTR2UV(&when);
-#endif
- return u;
-}
-
PP(pp_exp)
{
dSP; dTARGET; tryAMAGICun(exp);
==== //depot/maint-5.8/perl/pp_sys.c#24 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#23~19803~ Mon Jun 16 22:18:41 2003
+++ perl/pp_sys.c Sun Jun 22 12:38:58 2003
@@ -2479,8 +2479,12 @@
GV *ggv;
register IO *nstio;
register IO *gstio;
- struct sockaddr saddr; /* use a struct to avoid alignment problems */
- Sock_size_t len = sizeof saddr;
+ char namebuf[MAXPATHLEN];
+#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) ||
defined(__QNXNTO__)
+ Sock_size_t len = sizeof (struct sockaddr_in);
+#else
+ Sock_size_t len = sizeof namebuf;
+#endif
int fd;
ggv = (GV*)POPs;
@@ -2496,7 +2500,7 @@
goto nuts;
nstio = GvIOn(ngv);
- fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr,
&len);
+ fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf,
&len);
if (fd < 0)
goto badexit;
if (IoIFP(nstio))
@@ -2515,14 +2519,14 @@
#endif
#ifdef EPOC
- len = sizeof saddr; /* EPOC somehow truncates info */
+ len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
#endif
#ifdef __SCO_VERSION__
- len = sizeof saddr; /* OpenUNIX 8 somehow truncates info */
+ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
#endif
- PUSHp((char *)&saddr, len);
+ PUSHp(namebuf, len);
RETURN;
nuts:
==== //depot/maint-5.8/perl/proto.h#29 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#28~19823~ Thu Jun 19 07:51:22 2003
+++ perl/proto.h Sun Jun 22 12:38:58 2003
@@ -811,6 +811,7 @@
PERL_CALLCONV void Perl_vivify_ref(pTHX_ SV* sv, U32 to_what);
PERL_CALLCONV I32 Perl_wait4pid(pTHX_ Pid_t pid, int* statusp, int flags);
PERL_CALLCONV U32 Perl_parse_unicode_opts(pTHX_ char **popt);
+PERL_CALLCONV U32 Perl_seed(pTHX);
PERL_CALLCONV void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op);
PERL_CALLCONV void Perl_report_uninit(pTHX);
PERL_CALLCONV void Perl_warn(pTHX_ const char* pat, ...)
@@ -1038,7 +1039,6 @@
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
STATIC SV* S_refto(pTHX_ SV* sv);
-STATIC U32 S_seed(pTHX);
#endif
#if defined(PERL_IN_PP_PACK_C) || defined(PERL_DECL_PROT)
==== //depot/maint-5.8/perl/sv.c#53 (text) ====
Index: perl/sv.c
--- perl/sv.c#52~19791~ Sun Jun 15 10:57:06 2003
+++ perl/sv.c Sun Jun 22 12:38:58 2003
@@ -10449,6 +10449,8 @@
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
@@ -10480,6 +10482,8 @@
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
==== //depot/maint-5.8/perl/t/op/concat.t#3 (text) ====
Index: perl/t/op/concat.t
--- perl/t/op/concat.t#2~18783~ Wed Feb 26 11:39:59 2003
+++ perl/t/op/concat.t Sun Jun 22 12:38:58 2003
@@ -18,7 +18,7 @@
return $ok;
}
-print "1..18\n";
+print "1..19\n";
($a, $b, $c) = qw(foo bar);
@@ -103,4 +103,9 @@
ok(beq($l.$r, $c), "concat byte and utf8");
ok(beq($l, "\x{fe}"), "right not changed after concat b+u");
ok(beq($r, "\x{101}"), "left not changed after concat b+u");
+}
+
+{
+ my $a; ($a .= 5) . 6;
+ ok($a == 5, "($a .= 5) . 6 - present since 5.000");
}
==== //depot/maint-5.8/perl/unixish.h#6 (text) ====
Index: perl/unixish.h
--- perl/unixish.h#5~19611~ Sat May 24 00:50:43 2003
+++ perl/unixish.h Sun Jun 22 12:38:58 2003
@@ -129,7 +129,7 @@
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) PERL_FPU_INIT MALLOC_INIT
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/util.c#23 (text) ====
Index: perl/util.c
--- perl/util.c#22~19823~ Thu Jun 19 07:51:22 2003
+++ perl/util.c Sun Jun 22 12:38:58 2003
@@ -4357,3 +4357,84 @@
return opt;
}
+U32
+Perl_seed(pTHX)
+{
+ /*
+ * This is really just a quick hack which grabs various garbage
+ * values. It really should be a real hash algorithm which
+ * spreads the effect of every input bit onto every output bit,
+ * if someone who knows about such things would bother to write it.
+ * Might be a good idea to add that function to CORE as well.
+ * No numbers below come from careful analysis or anything here,
+ * except they are primes and SEED_C1 > 1E6 to get a full-width
+ * value from (tv_sec * SEED_C1 + tv_usec). The multipliers should
+ * probably be bigger too.
+ */
+#if RANDBITS > 16
+# define SEED_C1 1000003
+#define SEED_C4 73819
+#else
+# define SEED_C1 25747
+#define SEED_C4 20639
+#endif
+#define SEED_C2 3
+#define SEED_C3 269
+#define SEED_C5 26107
+
+#ifndef PERL_NO_DEV_RANDOM
+ int fd;
+#endif
+ U32 u;
+#ifdef VMS
+# include <starlet.h>
+ /* when[] = (low 32 bits, high 32 bits) of time since epoch
+ * in 100-ns units, typically incremented ever 10 ms. */
+ unsigned int when[2];
+#else
+# ifdef HAS_GETTIMEOFDAY
+ struct timeval when;
+# else
+ Time_t when;
+# endif
+#endif
+
+/* This test is an escape hatch, this symbol isn't set by Configure. */
+#ifndef PERL_NO_DEV_RANDOM
+#ifndef PERL_RANDOM_DEVICE
+ /* /dev/random isn't used by default because reads from it will block
+ * if there isn't enough entropy available. You can compile with
+ * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
+ * is enough real entropy to fill the seed. */
+# define PERL_RANDOM_DEVICE "/dev/urandom"
+#endif
+ fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
+ if (fd != -1) {
+ if (PerlLIO_read(fd, &u, sizeof u) != sizeof u)
+ u = 0;
+ PerlLIO_close(fd);
+ if (u)
+ return u;
+ }
+#endif
+
+#ifdef VMS
+ _ckvmssts(sys$gettim(when));
+ u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
+#else
+# ifdef HAS_GETTIMEOFDAY
+ PerlProc_gettimeofday(&when,NULL);
+ u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
+# else
+ (void)time(&when);
+ u = (U32)SEED_C1 * when;
+# endif
+#endif
+ u += SEED_C3 * (U32)PerlProc_getpid();
+ u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)PTR2UV(&when);
+#endif
+ return u;
+}
+
==== //depot/maint-5.8/perl/utils/c2ph.PL#3 (text) ====
Index: perl/utils/c2ph.PL
--- perl/utils/c2ph.PL#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/utils/c2ph.PL Sun Jun 22 12:38:58 2003
@@ -353,13 +353,25 @@
$indent = 2;
$CC = 'cc';
-$CFLAGS = '-g -S';
+!NO!SUBS!
+
+if (($Config{gccversion} || '') =~ /^(\d+)\.(\d+)/
+ and ($1 > 3 or ($1 == 3 and $2 >= 2))) {
+ print OUT q/$CFLAGS = '-gstabs -S';/;
+} else {
+ print OUT q/$CFLAGS = '-g -S';/;
+}
+
+print OUT <<'!NO!SUBS!';
+
$DEFINES = '';
$perl++ if $0 =~ m#/?c2ph$#;
require 'getopts.pl';
+use File::Temp 'tempdir';
+
eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
&Getopts('aixdpvtnws:') || &usage(0);
@@ -488,9 +500,10 @@
$ARGV[0] =~ s/\.c$/.s/;
}
else {
- $TMP = "/tmp/c2ph.$$.c";
+ $TMPDIR = tempdir(CLEANUP => 1);
+ $TMP = "$TMPDIR/c2ph.$$.c";
&system("cat @ARGV > $TMP") && exit 1;
- &system("cd /tmp; $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ &system("cd $TMPDIR; $CC $CFLAGS $DEFINES $TMP") && exit 1;
unlink $TMP;
$TMP =~ s/\.c$/.s/;
@ARGV = ($TMP);
@@ -1261,7 +1274,8 @@
}
sub compute_intrinsics {
- local($TMP) = "/tmp/c2ph-i.$$.c";
+ $TMPDIR ||= tempdir(CLEANUP => 1);
+ local($TMP) = "$TMPDIR/c2ph-i.$$.c";
open (TMP, ">$TMP") || die "can't open $TMP: $!";
select(TMP);
@@ -1289,7 +1303,7 @@
close TMP;
select(STDOUT);
- open(PIPE, "cd /tmp && $CC $TMP && /tmp/a.out|");
+ open(PIPE, "cd $TMPDIR && $CC $TMP && $TMPDIR/a.out|");
while (<PIPE>) {
chop;
split(' ',$_,2);;
@@ -1298,7 +1312,7 @@
$intrinsics{$_[1]} = $template{$_[0]};
}
close(PIPE) || die "couldn't read intrinsics!";
- unlink($TMP, '/tmp/a.out');
+ unlink($TMP, '$TMPDIR/a.out');
print STDERR "done\n" if $trace;
}
==== //depot/maint-5.8/perl/utils/dprofpp.PL#4 (text) ====
Index: perl/utils/dprofpp.PL
--- perl/utils/dprofpp.PL#3~19008~ Sun Mar 16 20:59:15 2003
+++ perl/utils/dprofpp.PL Sun Jun 22 12:38:58 2003
@@ -31,6 +31,13 @@
if( $VERSION == 0 ){
die "Did not find VERSION in $dprof_pm";
}
+my $stty = 'undef';
+foreach my $s (qw(/bin/stty /usr/bin/stty)) {
+ if (-x $s) {
+ $stty = qq["$s"];
+ last;
+ }
+}
open OUT,">$file" or die "Can't create $file: $!";
print "Extracting $file (with variable substitutions)\n";
@@ -46,6 +53,7 @@
require 5.003;
my \$VERSION = '$VERSION';
+my \$stty = $stty;
!GROK!THIS!
@@ -937,11 +945,17 @@
%Time ExclSec CumulS #Calls sec/call Csec/c Name
.
-format STAT =
- ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
-.
+BEGIN {
+ my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>>
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
+ if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~
/\bcolumns\s+(\d+)/)
+ {
+ $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
+ }
+ eval "format STAT = \n$fmt" . '
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.';
+}
!NO!SUBS!
close OUT or die "Can't close $file: $!";
==== //depot/maint-5.8/perl/vms/vmsish.h#4 (text) ====
Index: perl/vms/vmsish.h
--- perl/vms/vmsish.h#3~19161~ Sun Apr 6 21:20:20 2003
+++ perl/vms/vmsish.h Sun Jun 22 12:38:58 2003
@@ -331,7 +331,7 @@
#endif
#define BIT_BUCKET "_NLA0:"
-#define PERL_SYS_INIT(c,v) vms_image_init((c),(v)); MALLOC_INIT
+#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v));
MALLOC_INIT
#define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM
#define dXSUB_SYS
#define HAS_KILL
End of Patch.
