diff options
author | Jarkko Hietaniemi <jhi@iki.fi> | 2003-06-30 09:39:29 +0000 |
---|---|---|
committer | Jarkko Hietaniemi <jhi@iki.fi> | 2003-06-30 09:39:29 +0000 |
commit | 1aa6899ff053e0baf49f50bd5410ea0984993c58 (patch) | |
tree | 4f6d84bc0c92fcb088c5ea187eaca2a655bc747c | |
parent | 6d686c581ff926a22874273b88cec04fcb536a31 (diff) | |
download | perl-1aa6899ff053e0baf49f50bd5410ea0984993c58.tar.gz |
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 <Tim.Bunce@pobox.com>
Date: Thu, 26 Jun 2003 10:53:22 +0100
Message-ID: <20030626095322.GE97463@dansat.data-plan.com>
[ 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 <davem@fdgroup.com>
Date: Fri, 27 Jun 2003 22:26:24 +0100
Message-ID: <20030627212624.GB12887@fdgroup.com>
Subject: [PATCH] make -Dl show more scope info
From: Dave Mitchell <davem@fdgroup.com>
Date: Fri, 27 Jun 2003 23:00:36 +0100
Message-ID: <20030627220036.GC12887@fdgroup.com>
[ 19871]
Subject: [Encode] pre-1.97 patches
From: Dan Kogai <dankogai@dan.co.jp>
Date: Sat, 28 Jun 2003 01:20:59 +0900
Message-Id: <56D5BFEE-A8BB-11D7-9092-000393AE4244@dan.co.jp>
[ 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 <ilya@Math.Berkeley.EDU>
Date: Fri, 27 Jun 2003 06:54:06 -0700
Message-ID: <20030627135406.GA8914@math.berkeley.edu>
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.
p4raw-link: @19890 on //depot/perl: 7d8e7db38dc74a9a7ddcc48566f03f2b6af6f737
p4raw-link: @19889 on //depot/perl: 3cb9023dc910d8a9abbd8d44e501f6e492155eb5
p4raw-link: @19888 on //depot/perl: f9cbb277dec3cb2700132dedd25b05ea72cda45a
p4raw-link: @19887 on //depot/perl: ecce83c2318389c6dd5770c975354bb2411bd50f
p4raw-link: @19886 on //depot/perl: e13efe3ceea1a416bee536860751edb48e6bfcb3
p4raw-link: @19885 on //depot/perl: b9531c19967f04908d6f8236ceb2296ad6358488
p4raw-link: @19884 on //depot/perl: 54bfe034ba642318cf2c7d0b37579f30adef144a
p4raw-link: @19883 on //depot/perl: 52d59bef96c881381bce1bcb84a8c08ce48c2544
p4raw-link: @19882 on //depot/perl: d20fa10417f31b8f4d60b68adce91b91f9d3cd62
p4raw-link: @19881 on //depot/perl: c4b2e1b65d11779e63c2d42d6b840c9078181338
p4raw-link: @19880 on //depot/perl: f98d840496025d33749be7bdcdba70b97bd142b8
p4raw-link: @19879 on //depot/perl: a32c473717aa00461cd55052bb0345aa311e1123
p4raw-link: @19878 on //depot/perl: 1199dd43248b0956628341f2a63939a8378c8016
p4raw-link: @19877 on //depot/perl: 24130e51d52fd22992dd62e432895a9115f3a585
p4raw-link: @19876 on //depot/perl: d0bbed784b85a44e92a8a0e3d4046ce7f236db02
p4raw-link: @19875 on //depot/perl: f3f91eeab5d8feea9ff5606711dfaaa7851308c1
p4raw-link: @19874 on //depot/perl: 3a676441c258924612d07e12c0faa7606e5bbba2
p4raw-link: @19873 on //depot/perl: 2275acdc2a5e9bfc8338ccf52a5a82e52653b1b0
p4raw-link: @19872 on //depot/perl: ca62f0fc957407f48588d44995309a50a80e45ab
p4raw-link: @19871 on //depot/perl: 23f3589e21445e9141901c2894bc97b457493332
p4raw-link: @19870 on //depot/perl: b4ab917c3d812d8e61d365bfa48d9bf7675bc113
p4raw-link: @19869 on //depot/perl: 1d26cd9ec5ffb2d7823fb6941a001dc8e9a6d1c6
p4raw-link: @19868 on //depot/perlio: c9908cac60bbb191807f0d3fafd9567a2304b7e9
p4raw-link: @19867 on //depot/perl: 871661ef06c9321a672dd21cf8e97cec33e2c5ee
p4raw-link: @19866 on //depot/perl: 7b3f70378c41657f3e0c917f322e2cda58f33b5e
p4raw-link: @19865 on //depot/perl: bf1e01904b621fce6a1d1e1bcf187334cf1b1e04
p4raw-link: @19864 on //depot/perl: ed085813cee9c22e7ad548a324c6d8f6d7d726d2
p4raw-link: @19863 on //depot/perl: af419de789419c9e4520d33654a91564094b407a
p4raw-link: @19862 on //depot/perl: a06433151b0f1a3a12ccc4d2629feb511ea9fce6
p4raw-link: @19861 on //depot/perl: d0d2ba8fa784ab4c88f64ef679c2c1ff6203412a
p4raw-link: @19860 on //depot/perl: 3debabd9ba8d62a4b7656b07d06b582de8063b12
p4raw-link: @19859 on //depot/perl: 2191697ea9da49f0c020a5bcb1eb2a2e9d574a4e
p4raw-link: @19858 on //depot/perl: ea031e66439c986384865daf3860bb9bb815a8fa
p4raw-link: @19857 on //depot/maint-5.8/perl: 6d686c581ff926a22874273b88cec04fcb536a31
p4raw-id: //depot/maint-5.8/perl@19891
p4raw-integrated: from //depot/perl@19857 'copy in' pod/perlretut.pod
(@18299..) pod/perlhack.pod (@19211..)
ext/Encode/lib/Encode/Guess.pm (@19325..) pod/perlmod.pod
(@19425..) scope.h (@19431..) t/op/magic.t (@19452..)
ext/Encode/lib/Encode/Alias.pm (@19578..) mpeix/mpeixish.h
(@19602..) ext/threads/t/join.t (@19706..) lib/Test/Harness.pm
(@19766..) ext/Encode/Changes ext/Encode/Encode.pm (@19811..)
epoc/epocish.h plan9/plan9ish.h unixish.h vms/vmsish.h
(@19831..) malloc.c (@19834..) hints/dec_osf.sh (@19842..)
t/comp/require.t (@19851..) INSTALL pod/perlsec.pod (@19854..)
'ignore' miniperlmain.c (@19242..) 'merge in' ext/B/B.pm
(@18856..) cop.h (@19242..) global.sym (@19431..) perlvars.h
(@19499..) hv.c (@19632..) mg.c pod/perlvar.pod (@19769..)
dosish.h os2/os2ish.h (@19831..) embed.fnc embed.h proto.h
(@19843..) embedvar.h perl.c perl.h perlapi.h pod/perlrun.pod
(@19854..)
-rw-r--r-- | INSTALL | 14 | ||||
-rw-r--r-- | cop.h | 4 | ||||
-rw-r--r-- | dosish.h | 8 | ||||
-rw-r--r-- | embed.fnc | 4 | ||||
-rw-r--r-- | embed.h | 12 | ||||
-rw-r--r-- | embedvar.h | 3 | ||||
-rw-r--r-- | epoc/epocish.h | 2 | ||||
-rw-r--r-- | ext/B/B.pm | 4 | ||||
-rw-r--r-- | ext/Encode/Changes | 10 | ||||
-rw-r--r-- | ext/Encode/Encode.pm | 2 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/Alias.pm | 2 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/Guess.pm | 124 | ||||
-rw-r--r-- | ext/threads/t/join.t | 13 | ||||
-rw-r--r-- | global.sym | 1 | ||||
-rw-r--r-- | hints/dec_osf.sh | 9 | ||||
-rw-r--r-- | hv.c | 4 | ||||
-rw-r--r-- | lib/Test/Harness.pm | 2 | ||||
-rw-r--r-- | malloc.c | 101 | ||||
-rw-r--r-- | mg.c | 73 | ||||
-rw-r--r-- | mpeix/mpeixish.h | 2 | ||||
-rw-r--r-- | os2/os2ish.h | 4 | ||||
-rw-r--r-- | perl.c | 140 | ||||
-rw-r--r-- | perl.h | 27 | ||||
-rw-r--r-- | perlapi.h | 2 | ||||
-rw-r--r-- | perlvars.h | 2 | ||||
-rw-r--r-- | plan9/plan9ish.h | 2 | ||||
-rw-r--r-- | pod/perlhack.pod | 25 | ||||
-rw-r--r-- | pod/perlmod.pod | 20 | ||||
-rw-r--r-- | pod/perlretut.pod | 9 | ||||
-rw-r--r-- | pod/perlrun.pod | 8 | ||||
-rw-r--r-- | pod/perlsec.pod | 13 | ||||
-rw-r--r-- | pod/perlvar.pod | 18 | ||||
-rw-r--r-- | proto.h | 4 | ||||
-rw-r--r-- | scope.h | 6 | ||||
-rwxr-xr-x | t/comp/require.t | 2 | ||||
-rwxr-xr-x | t/op/magic.t | 19 | ||||
-rw-r--r-- | unixish.h | 2 | ||||
-rw-r--r-- | vms/vmsish.h | 2 |
38 files changed, 443 insertions, 256 deletions
@@ -840,7 +840,7 @@ your sfio sources and correct iffe's guess about atexit. 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 @@ In Perl 5.8.1 a security feature was introduced to make it harder 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 @@ -340,6 +340,7 @@ struct block { 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 @@ struct block { 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 { @@ -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 @@ -45,6 +45,7 @@ Anod |void |perl_free |PerlInterpreter* interp 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 @@ s |CV* |cv_clone2 |CV *proto|CV *outside #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 @@ -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 @@ -4662,6 +4669,11 @@ #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) #define ck_concat(a) Perl_ck_concat(aTHX_ a) diff --git a/embedvar.h b/embedvar.h index 49a45c6801..603bc63f46 100644 --- a/embedvar.h +++ b/embedvar.h @@ -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 diff --git a/epoc/epocish.h b/epoc/epocish.h index a971a8e6c7..f7d38443d8 100644 --- a/epoc/epocish.h +++ b/epoc/epocish.h @@ -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 diff --git a/ext/B/B.pm b/ext/B/B.pm index 60618ca208..3fbb41e77b 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -370,7 +370,7 @@ which can then be followed with the other access methods. 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 @@ Returns the AV object (i.e. in class B::AV) of the global comppadlist. 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. diff --git a/ext/Encode/Changes b/ext/Encode/Changes index 18f5788e92..7251f5d365 100644 --- a/ext/Encode/Changes +++ b/ext/Encode/Changes @@ -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: <20030626162731.GA2077@not.autrijus.org> +! Encode.pm + Addressed the following; + Subject: [perl #22835] FB_QUIET doesn't work with Encode::encode + Message-Id: <rt-22835-59975.6.8650775354304@rt.perl.org> + +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: <B5AB34D0-A019-11D7-AF03-000393AE4244@dan.co.jp> diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index 57bcc2b0d2..db74b6a194 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -147,7 +147,7 @@ sub encode($$;$) Carp::croak("Unknown encoding '$name'"); } my $octets = $enc->encode($string,$check); - return undef if ($check && length($string)); + $_[1] = $string if $check; return $octets; } diff --git a/ext/Encode/lib/Encode/Alias.pm b/ext/Encode/lib/Encode/Alias.pm index d684ced9ac..70b3dd8714 100644 --- a/ext/Encode/lib/Encode/Alias.pm +++ b/ext/Encode/lib/Encode/Alias.pm @@ -204,7 +204,7 @@ sub init_aliases # 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"' ); diff --git a/ext/Encode/lib/Encode/Guess.pm b/ext/Encode/lib/Encode/Guess.pm index fc8d267d02..5858f819cd 100644 --- a/ext/Encode/lib/Encode/Guess.pm +++ b/ext/Encode/lib/Encode/Guess.pm @@ -18,6 +18,7 @@ sub needs_lines { 1 } 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 @@ sub guess { 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); @@ -189,6 +195,10 @@ canonical names or aliases. # 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 =item Encode::Guess->set_suspects diff --git a/ext/threads/t/join.t b/ext/threads/t/join.t index 3818e49358..0761a5f976 100644 --- a/ext/threads/t/join.t +++ b/ext/threads/t/join.t @@ -91,7 +91,8 @@ ok(1,""); 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 @@ if ($^O eq 'linux') { # We parse ps output so this is OS-dependent. 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 { diff --git a/global.sym b/global.sym index 601af10fc6..005877ca16 100644 --- a/global.sym +++ b/global.sym @@ -21,6 +21,7 @@ perl_destruct perl_free perl_run perl_parse +Perl_doing_taint perl_clone perl_clone_using Perl_malloc diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index db4b147c9e..f08c318b89 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -341,13 +341,8 @@ EOF 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 @@ -1693,11 +1693,11 @@ Perl_hv_clear(pTHX_ HV *hv) 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 */ diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 7534a34663..40232792c8 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -523,7 +523,7 @@ sub _run_all_tests { $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"; @@ -576,6 +576,7 @@ union overhead { 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 @@ union overhead { #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 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = { 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 @@ static u_short buck_size[MAX_BUCKET_BY_TABLE + 1] = #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 @@ static u_short n_blks[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = #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 @@ static u_short blk_shift[LOG_OF_MIN_ARENA * BUCKETS_PER_POW2] = #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 @@ Perl_malloc(register size_t nbytes) (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 @@ Perl_malloc(register size_t nbytes) 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 @@ get_from_bigger_buckets(int bucket, MEM_SIZE size) 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 @@ morecore(register int bucket) * 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 @@ Perl_mfree(void *mp) 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 @@ Perl_realloc(void *mp, size_t nbytes) 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 @@ Perl_realloc(void *mp, size_t nbytes) */ 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 @@ Perl_malloced_size(void *p) 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 @@ Perl_get_mstats(pTHX_ perl_mstats_t *buf, int buflen, int level) 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 @@ Perl_dump_mstats(pTHX_ char *s) "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, @@ -1982,8 +1982,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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; diff --git a/mpeix/mpeixish.h b/mpeix/mpeixish.h index 92c588352d..2ed9faf332 100644 --- a/mpeix/mpeixish.h +++ b/mpeix/mpeixish.h @@ -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 diff --git a/os2/os2ish.h b/os2/os2ish.h index 5011fc73bd..0ce7b0d035 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -220,6 +220,7 @@ void Perl_OS2_term(void **excH, int exitstatus, int flags); # 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 @@ void Perl_OS2_term(void **excH, int exitstatus, int flags); # 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 @@ void Perl_OS2_term(void **excH, int exitstatus, int flags); # 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 @@ -171,7 +171,6 @@ perl_construct(pTHXx) 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 @@ perl_construct(pTHXx) #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 @@ perl_construct(pTHXx) #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 @@ setuid perl scripts securely.\n"); 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 @@ NULL 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 @@ Perl_moreswitches(pTHX_ char *s) { #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 @@ S_init_ids(pTHX) 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) @@ -517,9 +517,8 @@ int usleep(unsigned int); 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 @@ typedef struct clone_params CLONE_PARAMS; # 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 @@ -2680,6 +2696,13 @@ Gid_t getegid (void); #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 * when using magic. Note that some perl guts still assume * certain character properties of these constants, namely that @@ -992,6 +992,8 @@ END_EXTERN_C #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 diff --git a/perlvars.h b/perlvars.h index 09c521ba47..67f9f3b4c1 100644 --- a/perlvars.h +++ b/perlvars.h @@ -55,3 +55,5 @@ PERLVAR(Gdollarzero_mutex, perl_mutex) /* Modifying $0 */ /* 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 */ + diff --git a/plan9/plan9ish.h b/plan9/plan9ish.h index 5c922cf0ba..dd32f69f5a 100644 --- a/plan9/plan9ish.h +++ b/plan9/plan9ish.h @@ -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 diff --git a/pod/perlhack.pod b/pod/perlhack.pod index 4b7e3d2f73..01692806ad 100644 --- a/pod/perlhack.pod +++ b/pod/perlhack.pod @@ -1216,6 +1216,14 @@ important ones are explained in L<perlxs> as well. Pay special attention 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 @@ blessing when stepping through miles of source code. =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 @@ but you have to say 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 diff --git a/pod/perlmod.pod b/pod/perlmod.pod index 6cbdce3f9b..c03862d64d 100644 --- a/pod/perlmod.pod +++ b/pod/perlmod.pod @@ -283,15 +283,17 @@ going to pass to C<exit()>. You can modify C<$?> to change the exit 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. - -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> and C<INIT> blocks are useful to catch the transition between +the compilation phase and the execution phase of the main 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. diff --git a/pod/perlretut.pod b/pod/perlretut.pod index 57fc772df7..6e06f19291 100644 --- a/pod/perlretut.pod +++ b/pod/perlretut.pod @@ -689,10 +689,11 @@ inside goes into the special variables C<$1>, C<$2>, etc. They can be 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 diff --git a/pod/perlrun.pod b/pod/perlrun.pod index 77e15cd4a0..ae83b7752b 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -1109,16 +1109,20 @@ order as 5.8.0). "Pre-5.8.1" means, among other things, that hash 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) A translation concealed rooted logical name that contains perl and the diff --git a/pod/perlsec.pod b/pod/perlsec.pod index 92853dde1c..41f96691ac 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -417,6 +417,19 @@ consecutive runs of Perl will order hash keys differently, which may 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 diff --git a/pod/perlvar.pod b/pod/perlvar.pod index c844ef53af..3415e8650f 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -858,16 +858,21 @@ and C<$)> can be swapped only on machines supporting setregid(). =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 @@ C<$^C = 1> is similar to calling C<B::minus_c>. =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 @@ -26,6 +26,7 @@ PERL_CALLCONV int perl_destruct(PerlInterpreter* interp); 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 @@ STATIC CV* S_cv_clone2(pTHX_ CV *proto, CV *outside); #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 @@ -96,13 +96,11 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>. #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 diff --git a/t/comp/require.t b/t/comp/require.t index 7d1b24010c..c82d535400 100755 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -12,7 +12,7 @@ $i = 1; 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 { diff --git a/t/op/magic.t b/t/op/magic.t index f48422b2e3..611a01b9e1 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -36,7 +36,7 @@ sub skip { return 1; } -print "1..52\n"; +print "1..53\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -286,10 +286,23 @@ else { 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; } } @@ -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 diff --git a/vms/vmsish.h b/vms/vmsish.h index 076a6967f6..1ab2df09e0 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -331,7 +331,7 @@ struct interp_intern { #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 |