Change 19891 by [EMAIL PROTECTED] on 2003/06/30 09:39:29
Integrate:
[ 19857]
Regen Changes.
[ 19858]
perlhack update, by Steve Grazzini
about macro support in gdb and gcc.
[ 19859]
Hash/Util.t and Encode/t/Aliases.t seem to be having
random failures. To make these easier to reproduce,
add a variable, PERL_HASH_SEED_DEBUG, to display the
hash seed. E.g. in Debian/x86 Linux 3.0 PERL_HASH_SEED
of 82972356 makes the first one to fail.
[ 19860]
Subject: Re: Change 19854: Bite the bullet and apply the hash randomisation
patch.
From: Tim Bunce <[EMAIL PROTECTED]>
Date: Thu, 26 Jun 2003 10:53:22 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 19861]
Do not obey PERL_HASH_SEED or PERL_HASH_SEED_DEBUG
if tainting-- but is this a good thing or a bad thing?
(At least it makes debugging lib/Hash/Util.t harder,
since it has, for no apparent good reason, -T: one must
make a copy of it without the -T.)
[ 19862]
Make doing_taint() always available (though not
part of the public API).
[ 19863]
Introduce (global) variable PL_earlytaint which
is set very early in main(), before perl_parse()
has been called and PL_tainting (or PL_taint_warn)
might have been set.
[ 19864]
Use the PL_earlytaint. (PL_earlytaint is a global,
not per-interp, since perl_construct() is not passed
the argc, argv, and therefore it can't set the per-interp
PL_tainting.)
[ 19865]
atoi() doesn't cut the mustard if the PERL_HASH_SEED
is larger than INT_MAX (atoi() returns -1 in that case).
[ 19866]
Some warnings about the (im)proper uses of the hash randomisation.
[ 19867]
The two-for-loops is no more a valid way to walk through
a hash (this was the reason the Hash/Util.t intermittently
failed, the two-loop didn't find all the SVs of the HV).
[ 19868]
Integrate mainline
[ 19869]
Fix test count, by Abe Timmerman.
[ 19870]
Two debugging patches.
The first allows to hold symbolic switches in $^D
and more generally fixes assignment to $^D. The
second one improves the information given by -Dl.
Subject: [PATCH] allow $^D = "flags"
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Fri, 27 Jun 2003 22:26:24 +0100
Message-ID: <[EMAIL PROTECTED]>
Subject: [PATCH] make -Dl show more scope info
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Fri, 27 Jun 2003 23:00:36 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 19871]
Subject: [Encode] pre-1.97 patches
From: Dan Kogai <[EMAIL PROTECTED]>
Date: Sat, 28 Jun 2003 01:20:59 +0900
Message-Id: <[EMAIL PROTECTED]>
[ 19872]
Some clarification about the current semantics of CHECK and
INIT blocks. See bug [perl #22826].
[ 19873]
Using $1 without testing success of the regexp, bad.
[ 19874]
Retract #19867; the bug was really much simpler:
the < max must be <= max instead.
[ 19875]
Duh.
[ 19876]
Subject: Re: your malloc patches
From: Ilya Zakharevich <[EMAIL PROTECTED]>
Date: Fri, 27 Jun 2003 06:54:06 -0700
Message-ID: <[EMAIL PROTECTED]>
More malloc patches: now they seem to work even in Tru64.
[ 19877]
The #19842 is no more needed thanks to #19876,
and the #19842 was wrong anyway (it affected
only the threaded case.)
[ 19878]
Move the PL_earlytaint initialization to the PERL_SYS_INIT()
as per suggestion from Sarathy.
[ 19879]
Another spot where a zero $test{$max} can make things go boom.
[ 19880]
argc, argv.
[ 19881]
More coffee...
[ 19882]
Perl_doing_taint must be public, for programs that embed perl
[ 19883]
More on the macro debugging and expansion.
[ 19884]
The joy of $0. Undoing the #16399 makes Andreas'
tests (see [perl #22811]) pass (yes, padding with space instead
of nul makes no sense, but that seems to work, maybe Linux does
some deep magic in ps(1)?); moving the PL_origalen computation
earlier makes also the threaded-first case fully pass.
But in general modifying the argv[] is very non-portable.
(e.g. in Tru64 it seems to be limited to the size of the
original argv[0] since the argv[] are not contiguous?)
Everybody should just have setproctitle().
[ 19885]
Fix a faulty alias.
[ 19886]
Misc Pod Nits.
[ 19887]
$0 test tweaks from Andreas.
[ 19888]
$0 doc tweakage.
[ 19889]
The 'contiguous' test for argv[], envp[] was bogus
since those need not be in memory end-to-end, e.g.
in Tru64 they are aligned by eight. Loosen the test
so that 'contiguousness' is fulfilled if the elements
are within PTRSIZE alignment. This makes Tru64 to pass
the join.t, too.
[ 19890]
int is not UV.
Affected files ...
... //depot/maint-5.8/perl/INSTALL#12 integrate
... //depot/maint-5.8/perl/cop.h#9 integrate
... //depot/maint-5.8/perl/dosish.h#8 integrate
... //depot/maint-5.8/perl/embed.fnc#32 integrate
... //depot/maint-5.8/perl/embed.h#35 integrate
... //depot/maint-5.8/perl/embedvar.h#21 integrate
... //depot/maint-5.8/perl/epoc/epocish.h#4 integrate
... //depot/maint-5.8/perl/ext/B/B.pm#7 integrate
... //depot/maint-5.8/perl/ext/Encode/Changes#17 integrate
... //depot/maint-5.8/perl/ext/Encode/Encode.pm#16 integrate
... //depot/maint-5.8/perl/ext/Encode/lib/Encode/Alias.pm#6 integrate
... //depot/maint-5.8/perl/ext/Encode/lib/Encode/Guess.pm#4 integrate
... //depot/maint-5.8/perl/ext/threads/t/join.t#12 integrate
... //depot/maint-5.8/perl/global.sym#15 integrate
... //depot/maint-5.8/perl/hints/dec_osf.sh#7 integrate
... //depot/maint-5.8/perl/hv.c#16 integrate
... //depot/maint-5.8/perl/lib/Test/Harness.pm#5 integrate
... //depot/maint-5.8/perl/malloc.c#4 integrate
... //depot/maint-5.8/perl/mg.c#21 integrate
... //depot/maint-5.8/perl/miniperlmain.c#5 integrate
... //depot/maint-5.8/perl/mpeix/mpeixish.h#3 integrate
... //depot/maint-5.8/perl/os2/os2ish.h#5 integrate
... //depot/maint-5.8/perl/perl.c#37 integrate
... //depot/maint-5.8/perl/perl.h#35 integrate
... //depot/maint-5.8/perl/perlapi.h#19 integrate
... //depot/maint-5.8/perl/perlvars.h#9 integrate
... //depot/maint-5.8/perl/plan9/plan9ish.h#4 integrate
... //depot/maint-5.8/perl/pod/perlhack.pod#5 integrate
... //depot/maint-5.8/perl/pod/perlmod.pod#5 integrate
... //depot/maint-5.8/perl/pod/perlretut.pod#3 integrate
... //depot/maint-5.8/perl/pod/perlrun.pod#22 integrate
... //depot/maint-5.8/perl/pod/perlsec.pod#5 integrate
... //depot/maint-5.8/perl/pod/perlvar.pod#15 integrate
... //depot/maint-5.8/perl/proto.h#30 integrate
... //depot/maint-5.8/perl/scope.h#8 integrate
... //depot/maint-5.8/perl/t/comp/require.t#5 integrate
... //depot/maint-5.8/perl/t/op/magic.t#12 integrate
... //depot/maint-5.8/perl/unixish.h#7 integrate
... //depot/maint-5.8/perl/vms/vmsish.h#5 integrate
Differences ...
==== //depot/maint-5.8/perl/INSTALL#12 (text) ====
Index: perl/INSTALL
--- perl/INSTALL#11~19855~ Wed Jun 25 22:36:41 2003
+++ perl/INSTALL Mon Jun 30 02:39:29 2003
@@ -840,7 +840,7 @@
In Perls 5.8.0 and earlier it was easy to create degenerate hashes.
Processing such hashes would consume large amounts of CPU time,
-causing a "Denial of Service" attack against Perl. Such hashes may be
+enabling a "Denial of Service" attack against Perl. Such hashes may be
a problem for example for mod_perl sites, sites with Perl CGI scripts
and web services, that process data originating from external sources.
@@ -848,23 +848,23 @@
to create such degenerate hashes.
Because of this feature the keys(), values(), and each() functions
-will return the hash elements in different order between different
+may return the hash elements in different order between different
runs of Perl even with the same data. One can still revert to the old
-predictable order by setting the environment variable PERL_HASH_SEED,
+repeatable order by setting the environment variable PERL_HASH_SEED,
see L<perlrun>. Another option is to add -DUSE_HASH_SEED_EXPLICIT to
the compilation flags, in which case one has to explicitly set the
PERL_HASH_SEED environment variable to enable the security feature,
or -DNO_HASH_SEED to completely disable the feature.
-B<Perl does not guarantee any ordering of the hash keys>, and the
+B<Perl has never guaranteed any ordering of the hash keys>, and the
ordering has already changed several times during the lifetime of
-Perl 5. Also, the ordering of hash keys already (in Perl 5.8.0 and
-earlier) depends on the insertion order.
+Perl 5. Also, the ordering of hash keys has always been, and
+continues to be, affected by the insertion order.
Note that because of this randomisation for example the Data::Dumper
results will be different between different runs of Perl since
Data::Dumper by default dumps hashes "unordered". The use of the
-Data::Dumper C<Sortkeys> filter is recommended.
+Data::Dumper C<Sortkeys> option is recommended.
=head2 SOCKS
==== //depot/maint-5.8/perl/cop.h#9 (text) ====
Index: perl/cop.h
--- perl/cop.h#8~19400~ Sun May 4 01:29:43 2003
+++ perl/cop.h Mon Jun 30 02:39:29 2003
@@ -340,6 +340,7 @@
PL_retstack_ix = cx->blk_oldretsp, \
pm = cx->blk_oldpm, \
gimme = cx->blk_gimme; \
+ DEBUG_SCOPE("POPBLOCK"); \
DEBUG_l( PerlIO_printf(Perl_debug_log, "Leaving block %ld, type %s\n",
\
(long)cxstack_ix+1,PL_block_type[CxTYPE(cx)]); )
@@ -349,7 +350,8 @@
PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp, \
PL_scopestack_ix = cx->blk_oldscopesp, \
PL_retstack_ix = cx->blk_oldretsp, \
- PL_curpm = cx->blk_oldpm
+ PL_curpm = cx->blk_oldpm; \
+ DEBUG_SCOPE("TOPBLOCK");
/* substitution context */
struct subst {
==== //depot/maint-5.8/perl/dosish.h#8 (text) ====
Index: perl/dosish.h
--- perl/dosish.h#7~19844~ Sun Jun 22 12:38:58 2003
+++ perl/dosish.h Mon Jun 30 02:39:29 2003
@@ -16,7 +16,7 @@
#ifdef DJGPP
# define BIT_BUCKET "nul"
# define OP_BINARY O_BINARY
-# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v)
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*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) MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v)
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*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) MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v)
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
Perl_nw5_init(c,v)
# define BIT_BUCKET "nwnul"
# else
-# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v)
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*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#32 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#31~19844~ Sun Jun 22 12:38:58 2003
+++ perl/embed.fnc Mon Jun 30 02:39:29 2003
@@ -45,6 +45,7 @@
Anod |int |perl_run |PerlInterpreter* interp
Anod |int |perl_parse |PerlInterpreter* interp|XSINIT_t xsinit \
|int argc|char** argv|char** env
+Anp |bool |doing_taint |int argc|char** argv|char** env
#if defined(USE_ITHREADS)
Anod |PerlInterpreter*|perl_clone|PerlInterpreter* interp, UV flags
# if defined(PERL_IMPLICIT_SYS)
@@ -1401,6 +1402,9 @@
#endif
pd |CV* |find_runcv |U32 *db_seqp
p |void |free_tied_hv_pool
+#if defined(DEBUGGING)
+p |int |get_debug_opts |char **s
+#endif
==== //depot/maint-5.8/perl/embed.h#35 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#34~19844~ Sun Jun 22 12:38:58 2003
+++ perl/embed.h Mon Jun 30 02:39:29 2003
@@ -29,6 +29,7 @@
#if defined(PERL_IMPLICIT_SYS)
#endif
+#define doing_taint Perl_doing_taint
#if defined(USE_ITHREADS)
# if defined(PERL_IMPLICIT_SYS)
# endif
@@ -2165,6 +2166,11 @@
#ifdef PERL_CORE
#define free_tied_hv_pool Perl_free_tied_hv_pool
#endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts Perl_get_debug_opts
+#endif
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -2556,6 +2562,7 @@
#if defined(PERL_IMPLICIT_SYS)
#endif
+#define doing_taint Perl_doing_taint
#if defined(USE_ITHREADS)
# if defined(PERL_IMPLICIT_SYS)
# endif
@@ -4661,6 +4668,11 @@
#endif
#ifdef PERL_CORE
#define free_tied_hv_pool() Perl_free_tied_hv_pool(aTHX)
+#endif
+#if defined(DEBUGGING)
+#ifdef PERL_CORE
+#define get_debug_opts(a) Perl_get_debug_opts(aTHX_ a)
+#endif
#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
==== //depot/maint-5.8/perl/embedvar.h#21 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#20~19855~ Wed Jun 25 22:36:41 2003
+++ perl/embedvar.h Mon Jun 30 02:39:29 2003
@@ -275,6 +275,7 @@
#define PL_gid (PERL_GET_INTERP->Igid)
#define PL_glob_index (PERL_GET_INTERP->Iglob_index)
#define PL_globalstash (PERL_GET_INTERP->Iglobalstash)
+#define PL_hash_seed (PERL_GET_INTERP->Ihash_seed)
#define PL_he_arenaroot (PERL_GET_INTERP->Ihe_arenaroot)
#define PL_he_root (PERL_GET_INTERP->Ihe_root)
#define PL_hintgv (PERL_GET_INTERP->Ihintgv)
@@ -1420,6 +1421,7 @@
#define PL_curinterp (PL_Vars.Gcurinterp)
#define PL_do_undump (PL_Vars.Gdo_undump)
#define PL_dollarzero_mutex (PL_Vars.Gdollarzero_mutex)
+#define PL_earlytaint (PL_Vars.Gearlytaint)
#define PL_hexdigit (PL_Vars.Ghexdigit)
#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
#define PL_op_mutex (PL_Vars.Gop_mutex)
@@ -1434,6 +1436,7 @@
#define PL_Gcurinterp PL_curinterp
#define PL_Gdo_undump PL_do_undump
#define PL_Gdollarzero_mutex PL_dollarzero_mutex
+#define PL_Gearlytaint PL_earlytaint
#define PL_Ghexdigit PL_hexdigit
#define PL_Gmalloc_mutex PL_malloc_mutex
#define PL_Gop_mutex PL_op_mutex
==== //depot/maint-5.8/perl/epoc/epocish.h#4 (text) ====
Index: perl/epoc/epocish.h
--- perl/epoc/epocish.h#3~19844~ Sun Jun 22 12:38:58 2003
+++ perl/epoc/epocish.h Mon Jun 30 02:39:29 2003
@@ -108,7 +108,7 @@
/* epocemx setenv bug workaround */
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) putenv(".dummy=foo");
putenv(".dummy"); MALLOC_INIT
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
putenv(".dummy=foo"); putenv(".dummy"); MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/ext/B/B.pm#7 (text) ====
Index: perl/ext/B/B.pm
--- perl/ext/B/B.pm#6~18866~ Sun Mar 9 05:59:01 2003
+++ perl/ext/B/B.pm Mon Jun 30 02:39:29 2003
@@ -370,7 +370,7 @@
Returns the SV object corresponding to the C variable C<amagic_generation>.
-=item C<init_av>
+=item init_av
Returns the AV object (i.e. in class B::AV) representing INIT blocks.
@@ -394,7 +394,7 @@
Only when perl was compiled with ithreads.
-=item C<main_cv>
+=item main_cv
Return the (faked) CV corresponding to the main part of the Perl
program.
==== //depot/maint-5.8/perl/ext/Encode/Changes#17 (text) ====
Index: perl/ext/Encode/Changes
--- perl/ext/Encode/Changes#16~19817~ Wed Jun 18 22:24:45 2003
+++ perl/ext/Encode/Changes Mon Jun 30 02:39:29 2003
@@ -3,6 +3,16 @@
# $Id: Changes,v 1.96 2003/06/18 09:29:02 dankogai Exp $
#
$Revision: 1.96 $ $Date: 2003/06/18 09:29:02 $
+! lib/Encode/Guess.pm
+ $Encode::Guess::NoUTFAutoGuess is added so you can turn off
+ automatic utf(8|16|32) guessing -- originally by Autrijus
+ Message-Id: <[EMAIL PROTECTED]>
+! Encode.pm
+ Addressed the following;
+ Subject: [perl #22835] FB_QUIET doesn't work with Encode::encode
+ Message-Id: <[EMAIL PROTECTED]>
+
+1.96 2003/06/18 09:29:02
! lib/Encode/JP/JP.pm t/guess.t
m/(...)/ in void context then $1 is considered a Bad Thing
Message-Id: <[EMAIL PROTECTED]>
==== //depot/maint-5.8/perl/ext/Encode/Encode.pm#16 (text) ====
Index: perl/ext/Encode/Encode.pm
--- perl/ext/Encode/Encode.pm#15~19817~ Wed Jun 18 22:24:45 2003
+++ perl/ext/Encode/Encode.pm Mon Jun 30 02:39:29 2003
@@ -147,7 +147,7 @@
Carp::croak("Unknown encoding '$name'");
}
my $octets = $enc->encode($string,$check);
- return undef if ($check && length($string));
+ $_[1] = $string if $check;
return $octets;
}
==== //depot/maint-5.8/perl/ext/Encode/lib/Encode/Alias.pm#6 (text) ====
Index: perl/ext/Encode/lib/Encode/Alias.pm
--- perl/ext/Encode/lib/Encode/Alias.pm#5~19591~ Thu May 22 04:59:21 2003
+++ perl/ext/Encode/lib/Encode/Alias.pm Mon Jun 30 02:39:29 2003
@@ -204,7 +204,7 @@
# CP936 doesn't have vendor-addon for GBK, so they're identical.
define_alias( qr/^gbk$/i => '"cp936"');
# This fixes gb2312 vs. euc-cn confusion, practically
- define_alias( qr/\bGB[-_ ]?2312(?:\D.*$|$)/i => '"euc-cn"' );
+ define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
# for Encode::JP
define_alias( qr/\bjis$/i => '"7bit-jis"' );
define_alias( qr/\beuc.*jp$/i => '"euc-jp"' );
==== //depot/maint-5.8/perl/ext/Encode/lib/Encode/Guess.pm#4 (text) ====
Index: perl/ext/Encode/lib/Encode/Guess.pm
--- perl/ext/Encode/lib/Encode/Guess.pm#3~19331~ Fri Apr 25 07:51:16 2003
+++ perl/ext/Encode/lib/Encode/Guess.pm Mon Jun 30 02:39:29 2003
@@ -18,6 +18,7 @@
sub perlio_ok { 0 }
our @EXPORT = qw(guess_encoding);
+our $NoUTFAutoGuess = 0;
sub import { # Exporter not used so we do it on our own
my $callpkg = caller;
@@ -70,75 +71,80 @@
return unless defined $octet and length $octet;
# cheat 0: utf8 flag;
- Encode::is_utf8($octet) and return find_encoding('utf8');
+ if ( Encode::is_utf8($octet) ) {
+ return find_encoding('utf8') unless $NoUTFAutoGuess;
+ Encode::_utf8_off($octet);
+ }
# cheat 1: BOM
use Encode::Unicode;
- my $BOM = unpack('n', $octet);
- return find_encoding('UTF-16')
- if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe));
- $BOM = unpack('N', $octet);
- return find_encoding('UTF-32')
- if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe0000));
+ unless ($NoUTFAutoGuess) {
+ my $BOM = unpack('n', $octet);
+ return find_encoding('UTF-16')
+ if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe));
+ $BOM = unpack('N', $octet);
+ return find_encoding('UTF-32')
+ if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe0000));
+ if ($octet =~ /\x00/o){ # if \x00 found, we assume UTF-(16|32)(BE|LE)
+ my $utf;
+ my ($be, $le) = (0, 0);
+ if ($octet =~ /\x00\x00/o){ # UTF-32(BE|LE) assumed
+ $utf = "UTF-32";
+ for my $char (unpack('N*', $octet)){
+ $char & 0x0000ffff and $be++;
+ $char & 0xffff0000 and $le++;
+ }
+ }else{ # UTF-16(BE|LE) assumed
+ $utf = "UTF-16";
+ for my $char (unpack('n*', $octet)){
+ $char & 0x00ff and $be++;
+ $char & 0xff00 and $le++;
+ }
+ }
+ $DEBUG and warn "$utf, be == $be, le == $le";
+ $be == $le
+ and return
+ "Encodings ambiguous between $utf BE and LE ($be, $le)";
+ $utf .= ($be > $le) ? 'BE' : 'LE';
+ return find_encoding($utf);
+ }
+ }
my %try = %{$obj->{Suspects}};
for my $c (@_){
my $e = find_encoding($c) or die "Unknown encoding: $c";
$try{$e->name} = $e;
$DEBUG and warn "Added: ", $e->name;
}
- if ($octet =~ /\x00/o){ # if \x00 found, we assume UTF-(16|32)(BE|LE)
- my $utf;
- my ($be, $le) = (0, 0);
- if ($octet =~ /\x00\x00/o){ # UTF-32(BE|LE) assumed
- $utf = "UTF-32";
- for my $char (unpack('N*', $octet)){
- $char & 0x0000ffff and $be++;
- $char & 0xffff0000 and $le++;
- }
- }else{ # UTF-16(BE|LE) assumed
- $utf = "UTF-16";
- for my $char (unpack('n*', $octet)){
- $char & 0x00ff and $be++;
- $char & 0xff00 and $le++;
+ my $nline = 1;
+ for my $line (split /\r\n?|\n/, $octet){
+ # cheat 2 -- \e in the string
+ if ($line =~ /\e/o){
+ my @keys = keys %try;
+ delete @try{qw/utf8 ascii/};
+ for my $k (@keys){
+ ref($try{$k}) eq 'Encode::XS' and delete $try{$k};
}
}
- $DEBUG and warn "$utf, be == $be, le == $le";
- $be == $le
- and return "Encodings ambiguous between $utf BE and LE ($be, $le)";
- $utf .= ($be > $le) ? 'BE' : 'LE';
- return find_encoding($utf);
- }else{
- my $nline = 1;
- for my $line (split /\r\n?|\n/, $octet){
- # cheat 2 -- \e in the string
- if ($line =~ /\e/o){
- my @keys = keys %try;
- delete @try{qw/utf8 ascii/};
- for my $k (@keys){
- ref($try{$k}) eq 'Encode::XS' and delete $try{$k};
- }
- }
- my %ok = %try;
- # warn join(",", keys %try);
- for my $k (keys %try){
- my $scratch = $line;
- $try{$k}->decode($scratch, FB_QUIET);
- if ($scratch eq ''){
- $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k);
- }else{
- use bytes ();
- $DEBUG and
- warn sprintf("%4d:%-24s not ok; %d bytes left\n",
- $nline, $k, bytes::length($scratch));
- delete $ok{$k};
- }
+ my %ok = %try;
+ # warn join(",", keys %try);
+ for my $k (keys %try){
+ my $scratch = $line;
+ $try{$k}->decode($scratch, FB_QUIET);
+ if ($scratch eq ''){
+ $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k);
+ }else{
+ use bytes ();
+ $DEBUG and
+ warn sprintf("%4d:%-24s not ok; %d bytes left\n",
+ $nline, $k, bytes::length($scratch));
+ delete $ok{$k};
}
- %ok or return "No appropriate encodings found!";
- if (scalar(keys(%ok)) == 1){
- my ($retval) = values(%ok);
- return $retval;
- }
- %try = %ok; $nline++;
}
+ %ok or return "No appropriate encodings found!";
+ if (scalar(keys(%ok)) == 1){
+ my ($retval) = values(%ok);
+ return $retval;
+ }
+ %try = %ok; $nline++;
}
$try{ascii} or
return "Encodings too ambiguous: ", join(" or ", keys %try);
@@ -188,6 +194,10 @@
# tries all major Japanese Encodings as well
use Encode::Guess qw/euc-jp shiftjis 7bit-jis/;
+
+If the C<$Encode::Guess::NoUTFAutoGuess> variable is set to a true
+value, no heuristics will be applied to UTF8/16/32, and the result
+will be limited to the suspects and C<ascii>.
=over 4
==== //depot/maint-5.8/perl/ext/threads/t/join.t#12 (text) ====
Index: perl/ext/threads/t/join.t
--- perl/ext/threads/t/join.t#11~19722~ Mon Jun 9 10:52:25 2003
+++ perl/ext/threads/t/join.t Mon Jun 30 02:39:29 2003
@@ -91,7 +91,8 @@
ok(1,"");
}
-if ($^O eq 'linux') { # We parse ps output so this is OS-dependent.
+# We parse ps output so this is OS-dependent.
+if ($^O =~ /^(linux|dec_osf)$/) {
# First modify $0 in a subthread.
print "# mainthread: \$0 = $0\n";
threads->new( sub {
@@ -100,20 +101,20 @@
print "# subthread: \$0 = $0\n" } )->join;
print "# mainthread: \$0 = $0\n";
print "# pid = $$\n";
- if (open PS, "ps -f |") { # Note: must work in (all) Linux(es).
+ if (open PS, "ps -f |") { # Note: must work in (all) systems.
my ($sawpid, $sawexe);
while (<PS>) {
- s/\s+$//; # there seems to be extra whitespace at the end by ps(1)?
- print "# $_\n";
+ chomp;
+ print "# [$_]\n";
if (/^\S+\s+$$\s/) {
$sawpid++;
- if (/\sfoobar\b/) {
+ if (/\sfoobar$/) {
$sawexe++;
}
last;
}
}
- close PS;
+ close PS or die;
if ($sawpid) {
ok($sawpid && $sawexe, 'altering $0 is effective');
} else {
==== //depot/maint-5.8/perl/global.sym#15 (text+w) ====
Index: perl/global.sym
--- perl/global.sym#14~19439~ Wed May 7 10:11:48 2003
+++ perl/global.sym Mon Jun 30 02:39:29 2003
@@ -21,6 +21,7 @@
perl_free
perl_run
perl_parse
+Perl_doing_taint
perl_clone
perl_clone_using
Perl_malloc
==== //depot/maint-5.8/perl/hints/dec_osf.sh#7 (text) ====
Index: perl/hints/dec_osf.sh
--- perl/hints/dec_osf.sh#6~19844~ Sun Jun 22 12:38:58 2003
+++ perl/hints/dec_osf.sh Mon Jun 30 02:39:29 2003
@@ -341,13 +341,8 @@
esac
case "$usemymalloc" in
- ''|'n') usemymalloc='n'
- ;;
- *) # The FILLCHECK_DEADBEEF() are failing.
- case "$ccflags" in
- *-DFILL_CHECK_DEFAULT=*) ;;
- *) ccflags="$ccflags -DFILL_CHECK_DEFAULT=0" ;;
- esac
+ '')
+ usemymalloc='n'
;;
esac
# These symbols are renamed in <time.h> so
==== //depot/maint-5.8/perl/hv.c#16 (text) ====
Index: perl/hv.c
--- perl/hv.c#15~19636~ Thu May 29 07:19:35 2003
+++ perl/hv.c Mon Jun 30 02:39:29 2003
@@ -1693,11 +1693,11 @@
xhv = (XPVHV*)SvANY(hv);
- if(SvREADONLY(hv)) {
+ if (SvREADONLY(hv)) {
/* restricted hash: convert all keys to placeholders */
I32 i;
HE* entry;
- for (i=0; i< (I32) xhv->xhv_max; i++) {
+ for (i = 0; i <= (I32) xhv->xhv_max; i++) {
entry = ((HE**)xhv->xhv_array)[i];
for (; entry; entry = HeNEXT(entry)) {
/* not already placeholder */
==== //depot/maint-5.8/perl/lib/Test/Harness.pm#5 (text) ====
Index: perl/lib/Test/Harness.pm
--- perl/lib/Test/Harness.pm#4~19771~ Fri Jun 13 21:40:49 2003
+++ perl/lib/Test/Harness.pm Mon Jun 30 02:39:29 2003
@@ -523,7 +523,7 @@
$failedtests{$tfile}{name} = $tfile;
}
elsif($results{seen}) {
- if (@{$test{failed}}) {
+ if (@{$test{failed}} and $test{max}) {
my ($txt, $canon) = canonfailed($test{max},$test{skipped},
@{$test{failed}});
print "$test{ml}$txt";
==== //depot/maint-5.8/perl/malloc.c#4 (text) ====
Index: perl/malloc.c
--- perl/malloc.c#3~19844~ Sun Jun 22 12:38:58 2003
+++ perl/malloc.c Mon Jun 30 02:39:29 2003
@@ -576,6 +576,7 @@
u_char ovu_index; /* bucket # */
u_char ovu_magic; /* magic number */
#ifdef RCHECK
+ /* Subtract one to fit into u_short for an extra bucket */
u_short ovu_size; /* block size (requested + overhead - 1) */
u_int ovu_rmagic; /* range magic number */
#endif
@@ -591,14 +592,14 @@
#define RMAGIC_C 0x55 /* magic # on range info */
#ifdef RCHECK
-# define RSLOP sizeof (u_int)
+# define RMAGIC_SZ sizeof (u_int) /* Overhead at end of bucket */
# ifdef TWO_POT_OPTIMIZE
# define MAX_SHORT_BUCKET (12 * BUCKETS_PER_POW2) /* size-1 fits in short */
# else
# define MAX_SHORT_BUCKET (13 * BUCKETS_PER_POW2)
# endif
#else
-# define RSLOP 0
+# define RMAGIC_SZ 0
#endif
#if !defined(PACK_MALLOC) && defined(BUCKETS_ROOT2)
@@ -634,15 +635,16 @@
{
0, 0, 0, 0, 4, 4, 8, 12, 16, 24, 32, 48, 64, 80,
};
-# define BUCKET_SIZE(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >> BUCKET_POW2_SHIFT)))
+# define BUCKET_SIZE_NO_SURPLUS(i) ((i) % 2 ? buck_size[i] : (1 << ((i) >>
BUCKET_POW2_SHIFT)))
# define BUCKET_SIZE_REAL(i) ((i) <= MAX_BUCKET_BY_TABLE \
? buck_size[i] \
: ((1 << ((i) >> BUCKET_POW2_SHIFT)) \
- MEM_OVERHEAD(i) \
+ POW2_OPTIMIZE_SURPLUS(i)))
#else
-# define BUCKET_SIZE(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
-# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i) +
POW2_OPTIMIZE_SURPLUS(i))
+# define BUCKET_SIZE_NO_SURPLUS(i) (1 << ((i) >> BUCKET_POW2_SHIFT))
+# define BUCKET_SIZE(i) (BUCKET_SIZE_NO_SURPLUS(i) + POW2_OPTIMIZE_SURPLUS(i))
+# define BUCKET_SIZE_REAL(i) (BUCKET_SIZE(i) - MEM_OVERHEAD(i))
#endif
@@ -787,7 +789,7 @@
#ifdef IGNORE_SMALL_BAD_FREE
#define FIRST_BUCKET_WITH_CHECK (6 * BUCKETS_PER_POW2) /* 64 */
# define N_BLKS(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
- ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE(bucket) \
+ ? ((1<<LOG_OF_MIN_ARENA) - 1)/BUCKET_SIZE_NO_SURPLUS(bucket) \
: n_blks[bucket] )
#else
# define N_BLKS(bucket) n_blks[bucket]
@@ -810,7 +812,7 @@
#ifdef IGNORE_SMALL_BAD_FREE
# define BLK_SHIFT(bucket) ( (bucket) < FIRST_BUCKET_WITH_CHECK \
? ((1<<LOG_OF_MIN_ARENA) \
- - BUCKET_SIZE(bucket) * N_BLKS(bucket)) \
+ - BUCKET_SIZE_NO_SURPLUS(bucket) * N_BLKS(bucket)) \
: blk_shift[bucket])
#else
# define BLK_SHIFT(bucket) blk_shift[bucket]
@@ -851,7 +853,7 @@
#endif /* !PACK_MALLOC */
-#define M_OVERHEAD (sizeof(union overhead) + RSLOP)
+#define M_OVERHEAD (sizeof(union overhead) + RMAGIC_SZ) /* overhead at start+end */
#ifdef PACK_MALLOC
# define MEM_OVERHEAD(bucket) \
@@ -1510,7 +1512,7 @@
(long)size));
FILLCHECK_DEADBEEF((unsigned char*)(p + CHUNK_SHIFT),
- BUCKET_SIZE_REAL(bucket));
+ BUCKET_SIZE_REAL(bucket) + RMAGIC_SZ);
#ifdef IGNORE_SMALL_BAD_FREE
if (bucket >= FIRST_BUCKET_WITH_CHECK)
@@ -1530,13 +1532,14 @@
nbytes = size + M_OVERHEAD;
p->ov_size = nbytes - 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--)
- *((char *)((caddr_t)p + nbytes - RSLOP + i)) = RMAGIC_C;
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
+ ((caddr_t)p + nbytes - RMAGIC_SZ)[i] = RMAGIC_C;
}
- nbytes = (nbytes + 3) &~ 3;
- *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + RMAGIC_SZ - 1) & ~(RMAGIC_SZ - 1);
+ ((u_int *)((caddr_t)p + nbytes))[-1] = RMAGIC;
}
FILL_FEEDADAD((unsigned char *)(p + CHUNK_SHIFT), size);
#endif
@@ -1631,7 +1634,7 @@
nmalloc[bucket]--;
start_slack -= M_OVERHEAD;
#endif
- add_to_chain(ret, (BUCKET_SIZE(bucket) +
+ add_to_chain(ret, (BUCKET_SIZE_NO_SURPLUS(bucket) +
POW2_OPTIMIZE_SURPLUS(bucket)),
size);
return ret;
@@ -1936,7 +1939,7 @@
* Add new memory allocated to that on
* free list for this hash bucket.
*/
- siz = BUCKET_SIZE(bucket);
+ siz = BUCKET_SIZE_NO_SURPLUS(bucket); /* No surplus if nblks > 1 */
#ifdef PACK_MALLOC
*(u_char*)ovp = bucket; /* Fill index. */
if (bucket <= MAX_PACKED) {
@@ -2047,19 +2050,22 @@
int i;
MEM_SIZE nbytes = ovp->ov_size + 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--) {
- ASSERT(*((char *)((caddr_t)ovp + nbytes - RSLOP + i))
- == RMAGIC_C, "chunk's tail overwrite");
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) { /* nbytes - RMAGIC_SZ is end of alloced area */
+ ASSERT(((caddr_t)ovp + nbytes - RMAGIC_SZ)[i] == RMAGIC_C,
+ "chunk's tail overwrite");
}
}
- 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)));
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
+ ASSERT(((u_int *)((caddr_t)ovp + nbytes))[-1] == RMAGIC,
+ "chunk's tail overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nbytes),
+ BUCKET_SIZE(OV_INDEX(ovp)) - nbytes);
}
- FILL_DEADBEEF((unsigned char*)(ovp+1), BUCKET_SIZE_REAL(OV_INDEX(ovp)));
+ FILL_DEADBEEF((unsigned char*)(ovp+CHUNK_SHIFT),
+ BUCKET_SIZE_REAL(OV_INDEX(ovp)) + RMAGIC_SZ);
ovp->ov_rmagic = RMAGIC - 1;
#endif
ASSERT(OV_INDEX(ovp) < NBUCKETS, "chunk's head overwrite");
@@ -2189,22 +2195,24 @@
if (OV_INDEX(ovp) <= MAX_SHORT_BUCKET) {
int i, nb = ovp->ov_size + 1;
- if ((i = nb & 3)) {
- i = 4 - i;
- while (i--) {
- ASSERT(*((char *)((caddr_t)ovp + nb - RSLOP + i)) ==
RMAGIC_C, "chunk's tail overwrite");
+ if ((i = nb & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) { /* nb - RMAGIC_SZ is end of alloced area */
+ ASSERT(((caddr_t)ovp + nb - RMAGIC_SZ)[i] == RMAGIC_C,
"chunk's tail overwrite");
}
}
- 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)));
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nb = (nb + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ-1);
+ ASSERT(((u_int *)((caddr_t)ovp + nb))[-1] == RMAGIC,
+ "chunk's tail overwrite");
+ FILLCHECK_DEADBEEF((unsigned char*)((caddr_t)ovp + nb),
+ BUCKET_SIZE(OV_INDEX(ovp)) - nb);
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);
+ nb - M_OVERHEAD + RMAGIC_SZ - nbytes);
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
@@ -2213,14 +2221,15 @@
*/
nbytes += M_OVERHEAD;
ovp->ov_size = nbytes - 1;
- if ((i = nbytes & 3)) {
- i = 4 - i;
- while (i--)
- *((char *)((caddr_t)ovp + nbytes - RSLOP + i))
+ if ((i = nbytes & (RMAGIC_SZ-1))) {
+ i = RMAGIC_SZ - i;
+ while (i--) /* nbytes - RMAGIC_SZ is end of alloced area */
+ ((caddr_t)ovp + nbytes - RMAGIC_SZ)[i]
= RMAGIC_C;
}
- nbytes = (nbytes + 3) &~ 3;
- *((u_int *)((caddr_t)ovp + nbytes - RSLOP)) = RMAGIC;
+ /* Same at RMAGIC_SZ-aligned RMAGIC */
+ nbytes = (nbytes + (RMAGIC_SZ-1)) & ~(RMAGIC_SZ - 1);
+ ((u_int *)((caddr_t)ovp + nbytes))[-1] = RMAGIC;
}
#endif
res = cp;
@@ -2337,7 +2346,7 @@
if (bucket <= MAX_SHORT_BUCKET) {
MEM_SIZE size = BUCKET_SIZE_REAL(bucket);
ovp->ov_size = size + M_OVERHEAD - 1;
- *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RSLOP)) = RMAGIC;
+ *((u_int *)((caddr_t)ovp + size + M_OVERHEAD - RMAGIC_SZ)) = RMAGIC;
}
#endif
return BUCKET_SIZE_REAL(bucket);
@@ -2393,7 +2402,7 @@
for (i = MIN_BUCKET ; i < NBUCKETS; i++) {
if (i >= buflen)
break;
- buf->bucket_mem_size[i] = BUCKET_SIZE(i);
+ buf->bucket_mem_size[i] = BUCKET_SIZE_NO_SURPLUS(i);
buf->bucket_available_size[i] = BUCKET_SIZE_REAL(i);
}
}
@@ -2425,9 +2434,9 @@
"Memory allocation statistics %s (buckets
%"IVdf"(%"IVdf")..%"IVdf"(%"IVdf")\n",
s,
(IV)BUCKET_SIZE_REAL(MIN_BUCKET),
- (IV)BUCKET_SIZE(MIN_BUCKET),
+ (IV)BUCKET_SIZE_NO_SURPLUS(MIN_BUCKET),
(IV)BUCKET_SIZE_REAL(buffer.topbucket),
- (IV)BUCKET_SIZE(buffer.topbucket));
+ (IV)BUCKET_SIZE_NO_SURPLUS(buffer.topbucket));
PerlIO_printf(Perl_error_log, "%8"IVdf" free:", buffer.totfree);
for (i = MIN_EVEN_REPORT; i <= buffer.topbucket; i += BUCKETS_PER_POW2) {
PerlIO_printf(Perl_error_log,
==== //depot/maint-5.8/perl/mg.c#21 (text) ====
Index: perl/mg.c
--- perl/mg.c#20~19400~ Sun May 4 01:29:43 2003
+++ perl/mg.c Mon Jun 30 02:39:29 2003
@@ -1982,8 +1982,13 @@
break;
case '\004': /* ^D */
- PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#ifdef DEBUGGING
+ s = SvPV_nolen(sv);
+ PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
+#else
+ PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
@@ -2378,60 +2383,26 @@
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
#endif
- if (!PL_origalen) {
- s = PL_origargv[0];
- s += strlen(s);
- /* See if all the arguments are contiguous in memory */
- for (i = 1; i < PL_origargc; i++) {
- if (PL_origargv[i] == s + 1
-#ifdef OS2
- || PL_origargv[i] == s + 2
-#endif
- )
- {
- ++s;
- s += strlen(s); /* this one is ok too */
- }
- else
- break;
- }
- /* can grab env area too? */
- if (PL_origenviron
-#ifdef USE_ITHREADS
- && PL_curinterp == aTHX
-#endif
- && (PL_origenviron[0] == s + 1))
- {
- my_setenv("NoNe SuCh", Nullch);
- /* force copy of environment */
- for (i = 0; PL_origenviron[i]; i++)
- if (PL_origenviron[i] == s + 1) {
- ++s;
- s += strlen(s);
- }
- else
- break;
- }
- PL_origalen = s - PL_origargv[0];
- }
+ /* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
- i = len;
- if (i >= (I32)PL_origalen) {
- i = PL_origalen;
- /* don't allow system to limit $0 seen by script */
- /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s = '\0';
+ if (len >= (I32)PL_origalen) {
+ /* Longer than original, will be truncated. */
+ Copy(s, PL_origargv[0], PL_origalen, char);
+ PL_origargv[0][PL_origalen - 1] = 0;
}
else {
- Copy(s, PL_origargv[0], i, char);
- s = PL_origargv[0]+i;
- *s++ = '\0';
- while (++i < (I32)PL_origalen)
- *s++ = '\0';
+ /* Shorter than original, will be padded. */
+ Copy(s, PL_origargv[0], len, char);
+ PL_origargv[0][len] = 0;
+ memset(PL_origargv[0] + len + 1,
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ (int)' ',
+ PL_origalen - len - 1);
for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = Nullch;
+ PL_origargv[i] = 0;
}
UNLOCK_DOLLARZERO_MUTEX;
break;
==== //depot/maint-5.8/perl/mpeix/mpeixish.h#3 (text) ====
Index: perl/mpeix/mpeixish.h
--- perl/mpeix/mpeixish.h#2~19611~ Sat May 24 00:50:43 2003
+++ perl/mpeix/mpeixish.h Mon Jun 30 02:39:29 2003
@@ -113,7 +113,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) EARLY_INIT2(*c,*v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/os2/os2ish.h#5 (text) ====
Index: perl/os2/os2ish.h
--- perl/os2/os2ish.h#4~19844~ Sun Jun 22 12:38:58 2003
+++ perl/os2/os2ish.h Mon Jun 30 02:39:29 2003
@@ -220,6 +220,7 @@
# define PERL_SYS_INIT3(argcp, argvp, envp) \
{ void *xreg[2]; \
+ EARLY_INIT3(argcp, argvp, envp) \
MALLOC_CHECK_TAINT(*argcp, *argvp, *envp) \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
@@ -227,6 +228,7 @@
# define PERL_SYS_INIT(argcp, argvp) { \
{ void *xreg[2]; \
+ EARLY_INIT2(argcp, argvp) \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
Perl_OS2_init3(NULL, xreg, 0)
@@ -235,9 +237,11 @@
# define PERL_SYS_INIT3(argcp, argvp, envp) \
{ void *xreg[2]; \
+ EARLY_INIT3(argcp, argvp, envp) \
Perl_OS2_init3(*envp, xreg, 0)
# define PERL_SYS_INIT(argcp, argvp) { \
{ void *xreg[2]; \
+ EARLY_INIT2(argcp, argvp) \
Perl_OS2_init3(NULL, xreg, 0)
#endif
==== //depot/maint-5.8/perl/perl.c#37 (text) ====
Index: perl/perl.c
--- perl/perl.c#36~19855~ Wed Jun 25 22:36:41 2003
+++ perl/perl.c Mon Jun 30 02:39:29 2003
@@ -171,7 +171,6 @@
if (PL_perl_destruct_level > 0)
init_interp();
#endif
-
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
#ifdef USE_5005THREADS
@@ -319,11 +318,14 @@
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
/* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */
{
- char *s = PerlEnv_getenv("PERL_HASH_SEED");
+ char *s = NULL;
+
+ if (!PL_earlytaint)
+ s = PerlEnv_getenv("PERL_HASH_SEED");
if (s)
while (isSPACE(*s)) s++;
if (s && isDIGIT(*s))
- PL_hash_seed = (UV)atoi(s);
+ PL_hash_seed = (UV)Atoul(s);
#ifndef USE_HASH_SEED_EXPLICIT
else {
/* Compute a random seed */
@@ -340,6 +342,9 @@
#endif /* RANDBITS < (UVSIZE * 8) */
}
#endif /* USE_HASH_SEED_EXPLICIT */
+ if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
+ PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
+ PL_hash_seed);
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
@@ -1058,6 +1063,60 @@
PL_origargc = argc;
PL_origargv = argv;
+ {
+ /* Set PL_origalen be the sum of the contiguous argv[]
+ * elements plus the size of the env in case that it is
+ * contiguous with the argv[]. This is used in mg.c:mg_set()
+ * as the maximum modifiable length of $0. In the worst case
+ * the area we are able to modify is limited to the size of
+ * the original argv[0].
+ * --jhi */
+ char *s;
+ int i;
+ UV mask =
+ ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
+
+ /* See if all the arguments are contiguous in memory.
+ * Note that 'contiguous' is a loose term because some
+ * platforms align the argv[] and the envp[]. We just check
+ * that they are within aligned PTRSIZE bytes. As long as no
+ * system has something bizarre like the argv[] interleaved
+ * with some other data, we are fine. (Did I just evoke
+ * Murphy's Law?) --jhi */
+ s = PL_origargv[0];
+ while (*s) s++;
+ for (i = 1; i < PL_origargc; i++) {
+ if (PL_origargv[i] > s &&
+ PL_origargv[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
+ s = PL_origargv[i];
+ while (*s) s++;
+ }
+ else
+ break;
+ }
+ /* Can we grab env area too to be used as the area for $0? */
+ if (PL_origenviron &&
+ PL_origenviron[0] > s &&
+ PL_origenviron[0] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
+ s = PL_origenviron[0];
+ while (*s) s++;
+ my_setenv("NoNe SuCh", Nullch);
+ /* Force copy of environment. */
+ for (i = 1; PL_origenviron[i]; i++)
+ if (PL_origenviron[i] > s &&
+ PL_origenviron[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)) {
+ s = PL_origenviron[i];
+ while (*s) s++;
+ }
+ else
+ break;
+ }
+ PL_origalen = s - PL_origargv[0];
+ }
+
if (PL_do_undump) {
/* Come here if running an undumped a.out. */
@@ -2320,6 +2379,40 @@
PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
}
+/* convert a string of -D options (or digits) into an int.
+ * sets *s to point to the char after the options */
+
+#ifdef DEBUGGING
+int
+Perl_get_debug_opts(pTHX_ char **s)
+{
+ int i = 0;
+ if (isALPHA(**s)) {
+ /* if adding extra options, remember to update DEBUG_MASK */
+ static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+
+ for (; isALNUM(**s); (*s)++) {
+ char *d = strchr(debopts,**s);
+ if (d)
+ i |= 1 << (d - debopts);
+ else if (ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "invalid option -D%c\n", **s);
+ }
+ }
+ else {
+ i = atoi(*s);
+ for (; isALNUM(**s); (*s)++) ;
+ }
+# ifdef EBCDIC
+ if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "-Dp not implemented on this platform\n");
+# endif
+ return i;
+}
+#endif
+
/* This routine handles any switches that can be given during run */
char *
@@ -2419,24 +2512,8 @@
{
#ifdef DEBUGGING
forbid_setid("-D");
- if (isALPHA(s[1])) {
- /* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxu HXDSTRJv";
- char *d;
-
- for (s++; *s && (d = strchr(debopts,*s)); s++)
- PL_debug |= 1 << (d - debopts);
- }
- else {
- PL_debug = atoi(s+1);
- for (s++; isDIGIT(*s); s++) ;
- }
-#ifdef EBCDIC
- if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "-Dp not implemented on this platform\n");
-#endif
- PL_debug |= DEBUG_TOP_FLAG;
+ s++;
+ PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
@@ -3437,31 +3514,32 @@
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
+/* This is used very early in the lifetime of the program,
+ * before even the options are parsed, so PL_tainting has
+ * not been initialized properly. The variable PL_earlytaint
+ * is set early in main() to the result of this function. */
+bool
Perl_doing_taint(int argc, char *argv[], char *envp[])
{
- int uid = PerlProc_getuid();
+ int uid = PerlProc_getuid();
int euid = PerlProc_geteuid();
- int gid = PerlProc_getgid();
+ int gid = PerlProc_getgid();
int egid = PerlProc_getegid();
#ifdef VMS
- uid |= gid << 16;
+ 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. */
+ /* This is a really primitive check; environment gets 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)
==== //depot/maint-5.8/perl/perl.h#35 (text) ====
Index: perl/perl.h
--- perl/perl.h#34~19855~ Wed Jun 25 22:36:41 2003
+++ perl/perl.h Mon Jun 30 02:39:29 2003
@@ -517,9 +517,8 @@
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)) { \
+ if (PL_earlytaint) { \
MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
}} STMT_END;
#else /* MYMALLOC */
@@ -1979,6 +1978,23 @@
# endif
#endif
+/* The PL_earlytaint is to be used instead PL_tainting before
+ * perl_parse() has had the chance to set up PL_tainting. */
+
+#ifndef EARLY_INIT3
+# define EARLY_INIT3(argcp,argvp,envp) \
+ STMT_START { \
+ PL_earlytaint = doing_taint(argcp, argvp, envp); \
+ } STMT_END;
+#endif
+
+#ifndef EARLY_INIT2
+# define EARLY_INIT2(argcp,argvp) \
+ STMT_START { \
+ PL_earlytaint = doing_taint(argcp, argvp, 0); \
+ } STMT_END;
+#endif
+
#ifndef PERL_SYS_INIT3
# define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp)
#endif
@@ -2678,6 +2694,13 @@
# define DEBUG_R(a)
# define DEBUG_v(a)
#endif /* DEBUGGING */
+
+
+#define DEBUG_SCOPE(where) \
+ DEBUG_l(WITH_THR(Perl_deb(aTHX_ "%s scope %ld at %s:%d\n", \
+ where, PL_scopestack_ix, __FILE__, __LINE__)));
+
+
/* These constants should be used in preference to raw characters
==== //depot/maint-5.8/perl/perlapi.h#19 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#18~19855~ Wed Jun 25 22:36:41 2003
+++ perl/perlapi.h Mon Jun 30 02:39:29 2003
@@ -992,6 +992,8 @@
#define PL_do_undump (*Perl_Gdo_undump_ptr(NULL))
#undef PL_dollarzero_mutex
#define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL))
+#undef PL_earlytaint
+#define PL_earlytaint (*Perl_Gearlytaint_ptr(NULL))
#undef PL_hexdigit
#define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL))
#undef PL_malloc_mutex
==== //depot/maint-5.8/perl/perlvars.h#9 (text) ====
Index: perl/perlvars.h
--- perl/perlvars.h#8~19515~ Tue May 13 10:51:05 2003
+++ perl/perlvars.h Mon Jun 30 02:39:29 2003
@@ -55,3 +55,5 @@
/* This is constant on most architectures, a global on OS/2 */
PERLVARI(Gsh_path, char *, SH_PATH)/* full path of shell */
+PERLVAR(Gearlytaint, bool) /* Early warning for taint, before PL_tainting is set
*/
+
==== //depot/maint-5.8/perl/plan9/plan9ish.h#4 (text) ====
Index: perl/plan9/plan9ish.h
--- perl/plan9/plan9ish.h#3~19844~ Sun Jun 22 12:38:58 2003
+++ perl/plan9/plan9ish.h Mon Jun 30 02:39:29 2003
@@ -106,7 +106,7 @@
#define ABORT() kill(PerlProc_getpid(),SIGABRT);
#define BIT_BUCKET "/dev/null"
-#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) MALLOC_INIT
+#define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
MALLOC_INIT
#define dXSUB_SYS
#define PERL_SYS_TERM() MALLOC_TERM
==== //depot/maint-5.8/perl/pod/perlhack.pod#5 (text) ====
Index: perl/pod/perlhack.pod
--- perl/pod/perlhack.pod#4~19256~ Thu Apr 17 11:26:24 2003
+++ perl/pod/perlhack.pod Mon Jun 30 02:39:29 2003
@@ -1216,6 +1216,14 @@
to L<perlguts/Background and PERL_IMPLICIT_CONTEXT> for information on
the C<[pad]THX_?> macros.
+=head2 The .i Targets
+
+You can expand the macros in a F<foo.c> file by saying
+
+ make foo.i
+
+which will expand the macros using cpp. Don't be scared by the results.
+
=head2 Poking at Perl
To really poke around with Perl, you'll probably want to build Perl for
@@ -1309,8 +1317,11 @@
=item print
Execute the given C code and print its results. B<WARNING>: Perl makes
-heavy use of macros, and F<gdb> is not aware of macros. You'll have to
-substitute them yourself. So, for instance, you can't say
+heavy use of macros, and F<gdb> does not necessarily support macros
+(see later L</"gdb macro support">). You'll have to substitute them
+yourself, or to invoke cpp on the source code files
+(see L</"The .i Targets">)
+So, for instance, you can't say
print SvPV_nolen(sv)
@@ -1320,7 +1331,15 @@
You may find it helpful to have a "macro dictionary", which you can
produce by saying C<cpp -dM perl.c | sort>. Even then, F<cpp> won't
-recursively apply the macros for you.
+recursively apply those macros for you.
+
+=head2 gdb macro support
+
+Recent versions of F<gdb> have fairly good macro support, but
+in order to use it you'll need to compile perl with macro definitions
+included in the debugging information. Using F<gcc> version 3.1, this
+means configuring with C<-Doptimize=-g3>. Other compilers might use a
+different switch (if they support debugging macros at all).
=back
==== //depot/maint-5.8/perl/pod/perlmod.pod#5 (text) ====
Index: perl/pod/perlmod.pod
--- perl/pod/perlmod.pod#4~19439~ Wed May 7 10:11:48 2003
+++ perl/pod/perlmod.pod Mon Jun 30 02:39:29 2003
@@ -283,15 +283,17 @@
value of the program. Beware of changing C<$?> by accident (e.g. by
running something via C<system>).
-Similar to C<BEGIN> blocks, C<INIT> blocks are run just before the
-Perl runtime begins execution, in "first in, first out" (FIFO) order.
-For example, the code generators documented in L<perlcc> make use of
-C<INIT> blocks to initialize and resolve pointers to XSUBs.
+C<CHECK> and C<INIT> blocks are useful to catch the transition between
+the compilation phase and the execution phase of the main program.
-Similar to C<END> blocks, C<CHECK> blocks are run just after the
-Perl compile phase ends and before the run time begins, in
-LIFO order. C<CHECK> blocks are again useful in the Perl compiler
-suite to save the compiled state of the program.
+C<CHECK> blocks are run just after the Perl compile phase ends and before
+the run time begins, in LIFO order. C<CHECK> blocks are used in
+the Perl compiler suite to save the compiled state of the program.
+
+C<INIT> blocks are run just before the Perl runtime begins execution, in
+"first in, first out" (FIFO) order. For example, the code generators
+documented in L<perlcc> make use of C<INIT> blocks to initialize and
+resolve pointers to XSUBs.
When you use the B<-n> and B<-p> switches to Perl, C<BEGIN> and
C<END> work just as they do in B<awk>, as a degenerate case.
==== //depot/maint-5.8/perl/pod/perlretut.pod#3 (text) ====
Index: perl/pod/perlretut.pod
--- perl/pod/perlretut.pod#2~18293~ Thu Dec 12 05:57:56 2002
+++ perl/pod/perlretut.pod Mon Jun 30 02:39:29 2003
@@ -689,10 +689,11 @@
used just as ordinary variables:
# extract hours, minutes, seconds
- $time =~ /(\d\d):(\d\d):(\d\d)/; # match hh:mm:ss format
- $hours = $1;
- $minutes = $2;
- $seconds = $3;
+ if ($time =~ /(\d\d):(\d\d):(\d\d)/) { # match hh:mm:ss format
+ $hours = $1;
+ $minutes = $2;
+ $seconds = $3;
+ }
Now, we know that in scalar context,
S<C<$time =~ /(\d\d):(\d\d):(\d\d)/> > returns a true or false
==== //depot/maint-5.8/perl/pod/perlrun.pod#22 (text) ====
Index: perl/pod/perlrun.pod
--- perl/pod/perlrun.pod#21~19855~ Wed Jun 25 22:36:41 2003
+++ perl/pod/perlrun.pod Mon Jun 30 02:39:29 2003
@@ -1109,15 +1109,19 @@
keys will be ordered the same between different runs of Perl.
The default behaviour is to randomise unless the PERL_HASH_SEED is set.
-If Perl has been compiled with the -DUSE_HASH_SEED_EXPLICIT the default
+If Perl has been compiled with C<-DUSE_HASH_SEED_EXPLICIT>, the default
behaviour is B<not> to randomise unless the PERL_HASH_SEED is set.
If PERL_HASH_SEED is unset or set to a non-numeric string, Perl uses
the pseudorandom seed supplied by the operating system and libraries.
If unset, each different run of Perl will have different ordering of
-the outputs of keys(), values, and each().
+the outputs of keys(), values(), and each().
See L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+
+=item PERL_HASH_SEED_DEBUG
+
+Set to (anything) to display the value of the hash seed.
=item PERL_ROOT (specific to the VMS port)
==== //depot/maint-5.8/perl/pod/perlsec.pod#5 (text) ====
Index: perl/pod/perlsec.pod
--- perl/pod/perlsec.pod#4~19855~ Wed Jun 25 22:36:41 2003
+++ perl/pod/perlsec.pod Mon Jun 30 02:39:29 2003
@@ -417,6 +417,19 @@
confuse some applications (like Data::Dumper: the outputs of two
different runs are no more identical).
+B<Perl has never guaranteed any ordering of the hash keys>, and the
+ordering has already changed several times during the lifetime of
+Perl 5. Also, the ordering of hash keys has always been, and
+continues to be, affected by the insertion order.
+
+Also note that while the order of the hash elements might be
+randomised, this "pseudoordering" should B<not> be used for
+applications like shuffling a list randomly (use List::Util::shuffle()
+for that, see L<List::Util>, a standard core module since Perl 5.8.0;
+or the CPAN module Algorithm::Numerical::Shuffle), or for generating
+permutations (use e.g. the CPAN modules Algorithm::Permute or
+Algorithm::FastPermute), or for any cryptographic applications.
+
=item *
Regular expressions - Perl's regular expression engine is so called
==== //depot/maint-5.8/perl/pod/perlvar.pod#15 (text) ====
Index: perl/pod/perlvar.pod
--- perl/pod/perlvar.pod#14~19360~ Mon Apr 28 02:10:08 2003
+++ perl/pod/perlvar.pod Mon Jun 30 02:39:29 2003
@@ -858,16 +858,21 @@
=item $0
-Contains the name of the program being executed. On some operating
-systems assigning to C<$0> modifies the argument area that the B<ps>
-program sees. This is more useful as a way of indicating the current
+Contains the name of the program being executed. On some (read: not
+all) operating systems assigning to C<$0> modifies the argument area
+that the C<ps> program sees. On some platforms you may have to use
+special C<ps> options or a different C<ps> to see the changes.
+Modifying the $0 is more useful as a way of indicating thecurrent
program state than it is for hiding the program you're running.
(Mnemonic: same as B<sh> and B<ksh>.)
+Note that there are platform specific limitations on the the maximum
+length of C<$0>. In the most extreme case it may be limited to the
+space occupied by the original C<$0>.
+
Note for BSD users: setting C<$0> does not completely remove "perl"
from the ps(1) output. For example, setting C<$0> to C<"foobar"> will
-result in C<"perl: foobar (perl)">. This is an operating system
-feature.
+result in C<"perl: foobar (perl)">. This is an operating system feature.
In multithreaded scripts Perl coordinates the threads so that any
thread may modify its copy of the C<$0> and the change becomes visible
@@ -922,7 +927,8 @@
=item $^D
The current value of the debugging flags. (Mnemonic: value of B<-D>
-switch.)
+switch.) May be read or set. Like its command-line equivalent, you can use
+numeric or symbolic values, eg C<$^D = 10> or C<$^D = "st">.
=item $SYSTEM_FD_MAX
==== //depot/maint-5.8/perl/proto.h#30 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#29~19844~ Sun Jun 22 12:38:58 2003
+++ perl/proto.h Mon Jun 30 02:39:29 2003
@@ -26,6 +26,7 @@
PERL_CALLCONV void perl_free(PerlInterpreter* interp);
PERL_CALLCONV int perl_run(PerlInterpreter* interp);
PERL_CALLCONV int perl_parse(PerlInterpreter* interp, XSINIT_t xsinit, int argc,
char** argv, char** env);
+PERL_CALLCONV bool Perl_doing_taint(int argc, char** argv, char** env);
#if defined(USE_ITHREADS)
PERL_CALLCONV PerlInterpreter* perl_clone(PerlInterpreter* interp, UV flags);
# if defined(PERL_IMPLICIT_SYS)
@@ -1343,6 +1344,9 @@
#endif
PERL_CALLCONV CV* Perl_find_runcv(pTHX_ U32 *db_seqp);
PERL_CALLCONV void Perl_free_tied_hv_pool(pTHX);
+#if defined(DEBUGGING)
+PERL_CALLCONV int Perl_get_debug_opts(pTHX_ char **s);
+#endif
==== //depot/maint-5.8/perl/scope.h#8 (text) ====
Index: perl/scope.h
--- perl/scope.h#7~19439~ Wed May 7 10:11:48 2003
+++ perl/scope.h Mon Jun 30 02:39:29 2003
@@ -96,13 +96,11 @@
#define ENTER \
STMT_START { \
push_scope(); \
- DEBUG_l(WITH_THR(Perl_deb(aTHX_ "ENTER scope %ld at %s:%d\n", \
- PL_scopestack_ix, __FILE__, __LINE__))); \
+ DEBUG_SCOPE("ENTER") \
} STMT_END
#define LEAVE \
STMT_START { \
- DEBUG_l(WITH_THR(Perl_deb(aTHX_ "LEAVE scope %ld at %s:%d\n", \
- PL_scopestack_ix, __FILE__, __LINE__))); \
+ DEBUG_SCOPE("LEAVE") \
pop_scope(); \
} STMT_END
#else
==== //depot/maint-5.8/perl/t/comp/require.t#5 (xtext) ====
Index: perl/t/comp/require.t
--- perl/t/comp/require.t#4~19855~ Wed Jun 25 22:36:41 2003
+++ perl/t/comp/require.t Mon Jun 30 02:39:29 2003
@@ -12,7 +12,7 @@
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
my $total_tests = 30;
-if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 26; }
+if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 27; }
print "1..$total_tests\n";
sub do_require {
==== //depot/maint-5.8/perl/t/op/magic.t#12 (xtext) ====
Index: perl/t/op/magic.t
--- perl/t/op/magic.t#11~19515~ Tue May 13 10:51:05 2003
+++ perl/t/op/magic.t Mon Jun 30 02:39:29 2003
@@ -36,7 +36,7 @@
return 1;
}
-print "1..52\n";
+print "1..53\n";
$Is_MSWin32 = $^O eq 'MSWin32';
$Is_NetWare = $^O eq 'NetWare';
@@ -286,10 +286,23 @@
open CMDLINE, "/proc/$$/cmdline") {
chomp(my $line = scalar <CMDLINE>);
my $me = (split /\0/, $line)[0];
- ok($me eq $0, 'altering $0 is effective');
+ ok($me eq $0, 'altering $0 is effective (testing with /proc/)');
close CMDLINE;
+ # perlbug #22811
+ my $mydollarzero = sub {
+ my($arg) = shift;
+ $0 = $arg if defined $arg;
+ my $ps = `ps -o command= -p $$`;
+ return if $?;
+ chomp $ps;
+ printf "# 0[%s]ps[%s]\n", $0, $ps;
+ $ps;
+ };
+ my $ps = $mydollarzero->("x");
+ ok(!$ps || # we allow that something goes wrong with the ps command
+ $ps eq "x", 'altering $0 is effective (testing with `ps`)');
} else {
- skip("\$0 check only on Linux and FreeBSD with /proc");
+ skip("\$0 check only on Linux and FreeBSD") for 0,1;
}
}
==== //depot/maint-5.8/perl/unixish.h#7 (text) ====
Index: perl/unixish.h
--- perl/unixish.h#6~19844~ Sun Jun 22 12:38:58 2003
+++ perl/unixish.h Mon Jun 30 02:39:29 2003
@@ -129,7 +129,7 @@
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT MALLOC_INIT
+# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/vms/vmsish.h#5 (text) ====
Index: perl/vms/vmsish.h
--- perl/vms/vmsish.h#4~19844~ Sun Jun 22 12:38:58 2003
+++ perl/vms/vmsish.h Mon Jun 30 02:39:29 2003
@@ -331,7 +331,7 @@
#endif
#define BIT_BUCKET "_NLA0:"
-#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v));
MALLOC_INIT
+#define PERL_SYS_INIT(c,v) EARLY_INIT2(*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.
