rpms/perl
7
0
Fork 0
Code Issues Pull Requests Releases Activity

*** empty log message ***

Browse Source
This commit is contained in:
jvdias 2006-06-02 04:35:38 +00:00
parent 06b5dcf4a1
commit 083302770e
10 changed files with 2340 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
perl-5.8.8-R-switch.patch Normal file
View File

@ -0,0 +1,135 @@
--- perl-5.8.8/pod/perlrun.pod.-R-switch 2006-01-13 11:29:17.000000000 -0500
+++ perl-5.8.8/pod/perlrun.pod 2006-06-02 00:29:17.000000000 -0400
@@ -11,6 +11,7 @@
S<[ B<-I>I<dir> ] [ B<-m>[B<->]I<module> ] [ B<-M>[B<->]I<'module...'> ] [ B<-f> ]>
S<[ B<-C [I<number/list>] >]>
S<[ B<-P> ]>
+ S<[ B<-R> ]>
S<[ B<-S> ]>
S<[ B<-x>[I<dir>] ]>
S<[ B<-i>[I<extension>] ]>
@@ -813,6 +814,26 @@
before being searched for on the PATH. On Unix platforms, the
program will be searched for strictly on the PATH.
+=item B<-R>
+X<-R>
+
+Disables the Red Hat module compatibility default search path.
+
+By default, the Red Hat perl distribution will prepend to the default
+search path (@INC) the -V:archname subdirectory of each member of
+the -V:inc_version_list under the perl vendor and site installation
+directories.
+i.e. in shell notation:
+ {-V:vendorlib_stem,-V:sitelib_stem}/{-V:inc_version_list}/-V:archname
+where inc_version_list includes every previous perl version shipped
+by Red Hat, to provide compatibility for binary modules installed under
+previous perl versions. This can be quite a long list of directories
+to search, which can slow down module loading. You can disable searching
+these previous perl version architecture specific directories by specifying
+the -R switch - then the default search path will be as for the default
+upstream perl release.
+
+
=item B<-t>
X<-t>
--- perl-5.8.8/proto.h.-R-switch 2006-06-01 19:13:32.000000000 -0400
+++ perl-5.8.8/proto.h 2006-06-01 23:15:04.000000000 -0400
@@ -1620,7 +1620,7 @@
STATIC void S_init_ids(pTHX);
STATIC void S_init_lexer(pTHX);
STATIC void S_init_main_stash(pTHX);
-STATIC void S_init_perllib(pTHX);
+STATIC void S_init_perllib(pTHX,bool rhi);
STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env);
STATIC void S_init_predump_symbols(pTHX);
STATIC void S_my_exit_jump(pTHX)
--- perl-5.8.8/embed.fnc.-R-switch 2006-06-01 19:13:32.000000000 -0400
+++ perl-5.8.8/embed.fnc 2006-06-01 23:21:25.000000000 -0400
@@ -1080,7 +1080,7 @@
s |void |init_ids
s |void |init_lexer
s |void |init_main_stash
-s |void |init_perllib
+s |void |init_perllib |bool redhat_incpush
s |void |init_postdump_symbols|int argc|NN char **argv|NULLOK char **env
s |void |init_predump_symbols
rs |void |my_exit_jump
--- perl-5.8.8/embed.h.-R-switch 2006-06-01 19:13:32.000000000 -0400
+++ perl-5.8.8/embed.h 2006-06-01 23:13:11.000000000 -0400
@@ -3170,7 +3170,7 @@
#define init_ids() S_init_ids(aTHX)
#define init_lexer() S_init_lexer(aTHX)
#define init_main_stash() S_init_main_stash(aTHX)
-#define init_perllib() S_init_perllib(aTHX)
+#define init_perllib(rhi) S_init_perllib(aTHX,rhi)
#define init_postdump_symbols(a,b,c) S_init_postdump_symbols(aTHX_ a,b,c)
#define init_predump_symbols() S_init_predump_symbols(aTHX)
#define my_exit_jump() S_my_exit_jump(aTHX)
--- perl-5.8.8/perl.c.-R-switch 2006-06-01 23:08:08.000000000 -0400
+++ perl-5.8.8/perl.c 2006-06-02 00:00:23.000000000 -0400
@@ -1649,6 +1649,7 @@
#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
#endif
+ bool redhat_incpush = TRUE;
PL_fdscript = -1;
PL_suidscript = -1;
@@ -1770,11 +1771,15 @@
PL_preprocess = TRUE;
s++;
goto reswitch;
+ case 'R':
+ redhat_incpush = FALSE;
+ s++;
+ goto reswitch;
case 'S':
forbid_setid("-S");
dosearch = TRUE;
s++;
- goto reswitch;
+ goto reswitch;
case 'V':
{
SV *opts_prog;
@@ -2062,7 +2067,7 @@
scriptname = "-";
}
- init_perllib();
+ init_perllib(redhat_incpush);
open_script(scriptname,dosearch,sv);
@@ -4736,7 +4741,7 @@
}
STATIC void
-S_init_perllib(pTHX)
+S_init_perllib(pTHX, bool redhat_incpush)
{
char *s;
if (!PL_tainting) {
@@ -4803,7 +4808,8 @@
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
incpush(SITEARCH_EXP, FALSE, FALSE, TRUE);
- incpush_oldversion(aTHX_ SITEARCH_EXP);
+ if ( redhat_incpush )
+ incpush_oldversion(aTHX_ SITEARCH_EXP);
# endif
#endif
@@ -4825,7 +4831,8 @@
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE);
- incpush_oldversion(aTHX_ PERL_VENDORARCH_EXP);
+ if ( redhat_incpush )
+ incpush_oldversion(aTHX_ PERL_VENDORARCH_EXP);
# endif
#endif

44
perl-5.8.8-U27116.patch Normal file
View File

@ -0,0 +1,44 @@
--- perl-5.8.8/t/op/index.t.U27116 2005-10-31 09:11:17.000000000 -0500
+++ perl-5.8.8/t/op/index.t 2006-06-01 18:20:53.000000000 -0400
@@ -7,7 +7,7 @@
use strict;
require './test.pl';
-plan( tests => 58 );
+plan( tests => 66 );
my $foo = 'Now is the time for all good men to come to the aid of their country.';
@@ -121,3 +121,15 @@
is (index($text, $search_octets), -1);
is (rindex($text, $search_octets), -1);
}
+
+foreach my $utf8 ('', ', utf-8') {
+ foreach my $arraybase (0, 1, -1, -2) {
+ my $expect_pos = 2 + $arraybase;
+
+ my $prog = "\$[ = $arraybase; \$big = \"N\\xabN\\xab\"; ";
+ $prog .= '$big .= chr 256; chop $big; ' if $utf8;
+ $prog .= 'print rindex $big, "N", 2 + $[';
+
+ fresh_perl_is($prog, $expect_pos, {}, "\$[ = $arraybase$utf8");
+ }
+}
--- perl-5.8.8/pp.c.U27116 2006-06-01 17:04:25.000000000 -0400
+++ perl-5.8.8/pp.c 2006-06-01 18:19:16.000000000 -0400
@@ -3258,9 +3258,13 @@
if (MAXARG < 3)
offset = blen;
else {
+ /* arybase is in characters, like offset, so combine prior to the
+ UTF-8 to bytes calculation. */
+ offset -= arybase;
if (offset > 0 && big_utf8)
sv_pos_u2b(big, &offset, 0);
- offset = offset - arybase + llen;
+ /* llen is in bytes. */
+ offset += llen;
}
if (offset < 0)
offset = 0;

112
perl-5.8.8-U27329.patch Normal file
View File

@ -0,0 +1,112 @@
--- perl-5.8.8/t/op/lc.t.U27329 2005-11-07 09:22:36.000000000 -0500
+++ perl-5.8.8/t/op/lc.t 2006-06-01 22:02:13.000000000 -0400
@@ -6,7 +6,7 @@
require './test.pl';
}
-plan tests => 59;
+plan tests => 77;
$a = "HELLO.* world";
$b = "hello.* WORLD";
@@ -163,3 +163,38 @@
is($a, v10, "[perl #18857]");
}
}
+
+
+# [perl #38619] Bug in lc and uc (interaction between UTF-8, substr, and lc/uc)
+
+for ("a\x{100}", "xyz\x{100}") {
+ is(substr(uc($_), 0), uc($_), "[perl #38619] uc");
+}
+for ("A\x{100}", "XYZ\x{100}") {
+ is(substr(lc($_), 0), lc($_), "[perl #38619] lc");
+}
+for ("a\x{100}", "ßyz\x{100}") { # ß to Ss (different length)
+ is(substr(ucfirst($_), 0), ucfirst($_), "[perl #38619] ucfirst");
+}
+
+# Related to [perl #38619]
+# the original report concerns PERL_MAGIC_utf8.
+# these cases concern PERL_MAGIC_regex_global.
+
+for (map { $_ } "a\x{100}", "abc\x{100}", "\x{100}") {
+ chop; # get ("a", "abc", "") in utf8
+ my $return = uc($_) =~ /\G(.?)/g;
+ my $result = $return ? $1 : "not";
+ my $expect = (uc($_) =~ /(.?)/g)[0];
+ is($return, 1, "[perl #38619]");
+ is($result, $expect, "[perl #38619]");
+}
+
+for (map { $_ } "A\x{100}", "ABC\x{100}", "\x{100}") {
+ chop; # get ("A", "ABC", "") in utf8
+ my $return = lc($_) =~ /\G(.?)/g;
+ my $result = $return ? $1 : "not";
+ my $expect = (lc($_) =~ /(.?)/g)[0];
+ is($return, 1, "[perl #38619]");
+ is($result, $expect, "[perl #38619]");
+}
--- perl-5.8.8/pp.c.U27329 2006-06-01 21:30:14.000000000 -0400
+++ perl-5.8.8/pp.c 2006-06-01 21:53:37.000000000 -0400
@@ -3447,7 +3447,8 @@
if (slen > ulen)
sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
s = (U8*)SvPV_force_nomg(sv, slen);
@@ -3502,7 +3503,8 @@
if (slen > ulen)
sv_catpvn(TARG, (char*)(s + ulen), slen - ulen);
SvUTF8_on(TARG);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
s = (U8*)SvPV_force_nomg(sv, slen);
@@ -3552,7 +3554,8 @@
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
STRLEN min = len + 1;
@@ -3585,7 +3588,8 @@
*d = '\0';
SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
}
else {
@@ -3636,7 +3640,8 @@
if (!len) {
SvUTF8_off(TARG); /* decontaminate */
sv_setpvn(TARG, "", 0);
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
else {
STRLEN min = len + 1;
@@ -3688,7 +3693,8 @@
*d = '\0';
SvUTF8_on(TARG);
SvCUR_set(TARG, d - (U8*)SvPVX_const(TARG));
- SETs(TARG);
+ sv = TARG;
+ SETs(sv);
}
}
else {

495
perl-5.8.8-U27391.patch Normal file
View File

@ -0,0 +1,495 @@
--- perl-5.8.8/t/op/bop.t.U27391 2006-01-06 17:44:14.000000000 -0500
+++ perl-5.8.8/t/op/bop.t 2006-06-01 18:43:20.000000000 -0400
@@ -15,7 +15,7 @@
# If you find tests are failing, please try adding names to tests to track
# down where the failure is, and supply your new names as a patch.
# (Just-in-time test naming)
-plan tests => 49;
+plan tests => 148;
# numerics
ok ((0xdead & 0xbeef) == 0x9ead);
@@ -197,3 +197,149 @@
$b &= "b";
ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated');
}
+
+require "./test.pl";
+curr_test(50);
+
+# double magic tests
+
+sub TIESCALAR { bless { value => $_[1], orig => $_[1] } }
+sub STORE { $_[0]{store}++; $_[0]{value} = $_[1] }
+sub FETCH { $_[0]{fetch}++; $_[0]{value} }
+sub stores { tied($_[0])->{value} = tied($_[0])->{orig};
+ delete(tied($_[0])->{store}) || 0 }
+sub fetches { delete(tied($_[0])->{fetch}) || 0 }
+
+# numeric double magic tests
+
+tie $x, "main", 1;
+tie $y, "main", 3;
+
+is(($x | $y), 3);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x & $y), 1);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x ^ $y), 2);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x |= $y), 3);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x &= $y), 1);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x ^= $y), 2);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(~~$y, 3);
+is(fetches($y), 1);
+is(stores($y), 0);
+
+{ use integer;
+
+is(($x | $y), 3);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x & $y), 1);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x ^ $y), 2);
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x |= $y), 3);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x &= $y), 1);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x ^= $y), 2);
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(~$y, -4);
+is(fetches($y), 1);
+is(stores($y), 0);
+
+} # end of use integer;
+
+# stringwise double magic tests
+
+tie $x, "main", "a";
+tie $y, "main", "c";
+
+is(($x | $y), ("a" | "c"));
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x & $y), ("a" & "c"));
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x ^ $y), ("a" ^ "c"));
+is(fetches($x), 1);
+is(fetches($y), 1);
+is(stores($x), 0);
+is(stores($y), 0);
+
+is(($x |= $y), ("a" | "c"));
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x &= $y), ("a" & "c"));
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(($x ^= $y), ("a" ^ "c"));
+is(fetches($x), 2);
+is(fetches($y), 1);
+is(stores($x), 1);
+is(stores($y), 0);
+
+is(~~$y, "c");
+is(fetches($y), 1);
+is(stores($y), 0);
--- perl-5.8.8/pp.c.U27391 2006-06-01 18:19:16.000000000 -0400
+++ perl-5.8.8/pp.c 2006-06-01 18:43:19.000000000 -0400
@@ -2229,13 +2229,15 @@
dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = SvIV(left) & SvIV(right);
+ const IV i = SvIV_nomg(left) & SvIV_nomg(right);
SETi(i);
}
else {
- const UV u = SvUV(left) & SvUV(right);
+ const UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
}
@@ -2252,13 +2254,15 @@
dSP; dATARGET; tryAMAGICbin(bxor,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV(left) : 0) ^ SvIV(right);
+ const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) ^ SvIV_nomg(right);
SETi(i);
}
else {
- const UV u = (USE_LEFT(left) ? SvUV(left) : 0) ^ SvUV(right);
+ const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) ^ SvUV_nomg(right);
SETu(u);
}
}
@@ -2275,13 +2279,15 @@
dSP; dATARGET; tryAMAGICbin(bor,opASSIGN);
{
dPOPTOPssrl;
+ if (SvGMAGICAL(left)) mg_get(left);
+ if (SvGMAGICAL(right)) mg_get(right);
if (SvNIOKp(left) || SvNIOKp(right)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = (USE_LEFT(left) ? SvIV(left) : 0) | SvIV(right);
+ const IV i = (USE_LEFT(left) ? SvIV_nomg(left) : 0) | SvIV_nomg(right);
SETi(i);
}
else {
- const UV u = (USE_LEFT(left) ? SvUV(left) : 0) | SvUV(right);
+ const UV u = (USE_LEFT(left) ? SvUV_nomg(left) : 0) | SvUV_nomg(right);
SETu(u);
}
}
@@ -2376,13 +2382,15 @@
dSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (SvNIOKp(sv)) {
if (PL_op->op_private & HINT_INTEGER) {
- const IV i = ~SvIV(sv);
+ const IV i = ~SvIV_nomg(sv);
SETi(i);
}
else {
- const UV u = ~SvUV(sv);
+ const UV u = ~SvUV_nomg(sv);
SETu(u);
}
}
@@ -2392,7 +2400,7 @@
STRLEN len;
(void)SvPV_nomg_const(sv,len); /* force check for uninit var */
- SvSetSV(TARG, sv);
+ sv_setsv_nomg(TARG, sv);
tmps = (U8*)SvPV_force(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
--- perl-5.8.8/global.sym.U27391 2006-01-31 10:50:34.000000000 -0500
+++ perl-5.8.8/global.sym 2006-06-01 18:43:19.000000000 -0400
@@ -432,6 +432,7 @@
Perl_sv_2cv
Perl_sv_2io
Perl_sv_2iv
+Perl_sv_2iv_flags
Perl_sv_2mortal
Perl_sv_2nv
Perl_sv_2pv
@@ -439,6 +440,7 @@
Perl_sv_2pvbyte
Perl_sv_pvn_nomg
Perl_sv_2uv
+Perl_sv_2uv_flags
Perl_sv_iv
Perl_sv_uv
Perl_sv_nv
--- perl-5.8.8/proto.h.U27391 2006-01-31 10:50:34.000000000 -0500
+++ perl-5.8.8/proto.h 2006-06-01 18:43:19.000000000 -0400
@@ -1139,14 +1139,16 @@
PERL_CALLCONV bool Perl_sv_2bool(pTHX_ SV* sv);
PERL_CALLCONV CV* Perl_sv_2cv(pTHX_ SV* sv, HV** st, GV** gvp, I32 lref);
PERL_CALLCONV IO* Perl_sv_2io(pTHX_ SV* sv);
-PERL_CALLCONV IV Perl_sv_2iv(pTHX_ SV* sv);
+/* PERL_CALLCONV IV sv_2iv(pTHX_ SV* sv); */
+PERL_CALLCONV IV Perl_sv_2iv_flags(pTHX_ SV* sv, I32 flags);
PERL_CALLCONV SV* Perl_sv_2mortal(pTHX_ SV* sv);
PERL_CALLCONV NV Perl_sv_2nv(pTHX_ SV* sv);
/* PERL_CALLCONV char* sv_2pv(pTHX_ SV* sv, STRLEN* lp); */
PERL_CALLCONV char* Perl_sv_2pvutf8(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_2pvbyte(pTHX_ SV* sv, STRLEN* lp);
PERL_CALLCONV char* Perl_sv_pvn_nomg(pTHX_ SV* sv, STRLEN* lp);
-PERL_CALLCONV UV Perl_sv_2uv(pTHX_ SV* sv);
+/* PERL_CALLCONV UV sv_2uv(pTHX_ SV* sv); */
+PERL_CALLCONV UV Perl_sv_2uv_flags(pTHX_ SV* sv, I32 flags);
PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv);
PERL_CALLCONV UV Perl_sv_uv(pTHX_ SV* sv);
PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv);
--- perl-5.8.8/embed.fnc.U27391 2006-01-31 09:40:27.000000000 -0500
+++ perl-5.8.8/embed.fnc 2006-06-01 18:43:19.000000000 -0400
@@ -727,14 +727,16 @@
Apd |bool |sv_2bool |NN SV* sv
Apd |CV* |sv_2cv |NULLOK SV* sv|NN HV** st|NN GV** gvp|I32 lref
Apd |IO* |sv_2io |NN SV* sv
-Apd |IV |sv_2iv |NN SV* sv
+Amb |IV |sv_2iv |NN SV* sv
+Apd |IV |sv_2iv_flags |NN SV* sv|I32 flags
Apd |SV* |sv_2mortal |NULLOK SV* sv
Apd |NV |sv_2nv |NN SV* sv
Amb |char* |sv_2pv |NN SV* sv|NULLOK STRLEN* lp
Apd |char* |sv_2pvutf8 |NN SV* sv|NULLOK STRLEN* lp
Apd |char* |sv_2pvbyte |NN SV* sv|NULLOK STRLEN* lp
Ap |char* |sv_pvn_nomg |NN SV* sv|NULLOK STRLEN* lp
-Apd |UV |sv_2uv |NN SV* sv
+Amb |UV |sv_2uv |NN SV* sv
+Apd |UV |sv_2uv_flags |NN SV* sv|I32 flags
Apd |IV |sv_iv |NN SV* sv
Apd |UV |sv_uv |NN SV* sv
Apd |NV |sv_nv |NN SV* sv
--- perl-5.8.8/embed.h.U27391 2006-01-31 10:50:34.000000000 -0500
+++ perl-5.8.8/embed.h 2006-06-01 18:43:19.000000000 -0400
@@ -780,13 +780,13 @@
#define sv_2bool Perl_sv_2bool
#define sv_2cv Perl_sv_2cv
#define sv_2io Perl_sv_2io
-#define sv_2iv Perl_sv_2iv
+#define sv_2iv_flags Perl_sv_2iv_flags
#define sv_2mortal Perl_sv_2mortal
#define sv_2nv Perl_sv_2nv
#define sv_2pvutf8 Perl_sv_2pvutf8
#define sv_2pvbyte Perl_sv_2pvbyte
#define sv_pvn_nomg Perl_sv_pvn_nomg
-#define sv_2uv Perl_sv_2uv
+#define sv_2uv_flags Perl_sv_2uv_flags
#define sv_iv Perl_sv_iv
#define sv_uv Perl_sv_uv
#define sv_nv Perl_sv_nv
@@ -2831,13 +2831,13 @@
#define sv_2bool(a) Perl_sv_2bool(aTHX_ a)
#define sv_2cv(a,b,c,d) Perl_sv_2cv(aTHX_ a,b,c,d)
#define sv_2io(a) Perl_sv_2io(aTHX_ a)
-#define sv_2iv(a) Perl_sv_2iv(aTHX_ a)
+#define sv_2iv_flags(a,b) Perl_sv_2iv_flags(aTHX_ a,b)
#define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a)
#define sv_2nv(a) Perl_sv_2nv(aTHX_ a)
#define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b)
#define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b)
#define sv_pvn_nomg(a,b) Perl_sv_pvn_nomg(aTHX_ a,b)
-#define sv_2uv(a) Perl_sv_2uv(aTHX_ a)
+#define sv_2uv_flags(a,b) Perl_sv_2uv_flags(aTHX_ a,b)
#define sv_iv(a) Perl_sv_iv(aTHX_ a)
#define sv_uv(a) Perl_sv_uv(aTHX_ a)
#define sv_nv(a) Perl_sv_nv(aTHX_ a)
--- perl-5.8.8/sv.h.U27391 2006-01-02 09:51:46.000000000 -0500
+++ perl-5.8.8/sv.h 2006-06-01 18:43:20.000000000 -0400
@@ -953,6 +953,9 @@
=for apidoc Am|char*|SvPVx|SV* sv|STRLEN len
A version of C<SvPV> which guarantees to evaluate sv only once.
+=for apidoc Am|char*|SvPV_nomg|SV* sv|STRLEN len
+Like C<SvPV> but doesn't process magic.
+
=for apidoc Am|char*|SvPV_nolen|SV* sv
Returns a pointer to the string in the SV, or a stringified form of
the SV if the SV does not contain a string. The SV may cache the
@@ -962,6 +965,9 @@
Coerces the given SV to an integer and returns it. See C<SvIVx> for a
version which guarantees to evaluate sv only once.
+=for apidoc Am|IV|SvIV_nomg|SV* sv
+Like C<SvIV> but doesn't process magic.
+
=for apidoc Am|IV|SvIVx|SV* sv
Coerces the given SV to an integer and returns it. Guarantees to evaluate
sv only once. Use the more efficient C<SvIV> otherwise.
@@ -978,6 +984,9 @@
Coerces the given SV to an unsigned integer and returns it. See C<SvUVx>
for a version which guarantees to evaluate sv only once.
+=for apidoc Am|UV|SvUV_nomg|SV* sv
+Like C<SvUV> but doesn't process magic.
+
=for apidoc Am|UV|SvUVx|SV* sv
Coerces the given SV to an unsigned integer and returns it. Guarantees to
evaluate sv only once. Use the more efficient C<SvUV> otherwise.
@@ -1050,6 +1059,9 @@
#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
+#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
+
/* ----*/
#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
@@ -1251,6 +1263,8 @@
#define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0)
#define sv_pvn_force(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC)
#define sv_utf8_upgrade(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC)
+#define sv_2iv(sv) sv_2iv_flags(sv, SV_GMAGIC)
+#define sv_2uv(sv) sv_2uv_flags(sv, SV_GMAGIC)
/* Should be named SvCatPVN_utf8_upgrade? */
#define sv_catpvn_utf8_upgrade(dsv, sstr, slen, nsv) \
--- perl-5.8.8/sv.c.U27391 2006-01-16 07:22:21.000000000 -0500
+++ perl-5.8.8/sv.c 2006-06-01 18:43:19.000000000 -0400
@@ -2062,22 +2062,34 @@
}
#endif /* !NV_PRESERVES_UV*/
+/* sv_2iv() is now a macro using Perl_sv_2iv_flags();
+ * this function provided for binary compatibility only
+ */
+
+IV
+Perl_sv_2iv(pTHX_ register SV *sv)
+{
+ return sv_2iv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2iv
+=for apidoc sv_2iv_flags
-Return the integer value of an SV, doing any necessary string conversion,
-magic etc. Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
+Return the integer value of an SV, doing any necessary string
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvIV(sv)> and C<SvIVx(sv)> macros.
=cut
*/
IV
-Perl_sv_2iv(pTHX_ register SV *sv)
+Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
if (SvNOKp(sv)) {
@@ -2361,23 +2373,34 @@
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
+/* sv_2uv() is now a macro using Perl_sv_2uv_flags();
+ * this function provided for binary compatibility only
+ */
+
+UV
+Perl_sv_2uv(pTHX_ register SV *sv)
+{
+ return sv_2uv_flags(sv, SV_GMAGIC);
+}
+
/*
-=for apidoc sv_2uv
+=for apidoc sv_2uv_flags
Return the unsigned integer value of an SV, doing any necessary string
-conversion, magic etc. Normally used via the C<SvUV(sv)> and C<SvUVx(sv)>
-macros.
+conversion. If flags includes SV_GMAGIC, does an mg_get() first.
+Normally used via the C<SvUV(sv)> and C<SvUVx(sv)> macros.
=cut
*/
UV
-Perl_sv_2uv(pTHX_ register SV *sv)
+Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags)
{
if (!sv)
return 0;
if (SvGMAGICAL(sv)) {
- mg_get(sv);
+ if (flags & SV_GMAGIC)
+ mg_get(sv);
if (SvIOKp(sv))
return SvUVX(sv);
if (SvNOKp(sv))
--- perl-5.8.8/doop.c.U27391 2006-01-08 15:58:53.000000000 -0500
+++ perl-5.8.8/doop.c 2006-06-01 18:43:19.000000000 -0400
@@ -1171,8 +1171,8 @@
if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
sv_setpvn(sv, "", 0); /* avoid undef warning on |= and ^= */
- lsave = lc = SvPV_const(left, leftlen);
- rsave = rc = SvPV_const(right, rightlen);
+ lsave = lc = SvPV_nomg_const(left, leftlen);
+ rsave = rc = SvPV_nomg_const(right, rightlen);
len = leftlen < rightlen ? leftlen : rightlen;
lensave = len;
if ((left_utf || right_utf) && (sv == left || sv == right)) {
@@ -1180,9 +1180,7 @@
Newxz(dc, needlen + 1, char);
}
else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
- /* Fix this to nong when change 22613 is integrated.
- (Which in turn awaits merging sv_2iv and sv_2uv) */
- dc = SvPV_force_nolen(sv);
+ dc = SvPV_force_nomg_nolen(sv);
if (SvLEN(sv) < (STRLEN)(len + 1)) {
dc = SvGROW(sv, (STRLEN)(len + 1));
(void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);

12
perl-5.8.8-U27426.patch Normal file
View File

@ -0,0 +1,12 @@
--- perl-5.8.8/perl.c.U27426 2006-06-01 17:04:25.000000000 -0400
+++ perl-5.8.8/perl.c 2006-06-01 19:00:57.000000000 -0400
@@ -3076,8 +3076,7 @@
PL_minus_F = TRUE;
PL_splitstr = ++s;
while (*s && !isSPACE(*s)) ++s;
- *s = '\0';
- PL_splitstr = savepv(PL_splitstr);
+ PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;

1109
perl-5.8.8-U27509.patch Normal file
View File

File diff suppressed because it is too large Load Diff

203
perl-5.8.8-U27512.patch Normal file
View File

@ -0,0 +1,203 @@
--- perl-5.8.8/sv.c.U27512 2006-06-01 18:43:19.000000000 -0400
+++ perl-5.8.8/sv.c 2006-06-01 19:13:32.000000000 -0400
@@ -7993,6 +7993,52 @@
return rv;
}
+/* This is a hack to cope with reblessing from class with overloading magic to
+ one without (or the other way). Search for every reference pointing to the
+ object. Can't use S_visit() because we would need to pass a parameter to
+ our function. */
+static void
+S_reset_amagic(pTHX_ SV *rv, const bool on) {
+ /* It is assumed that you've already turned magic on/off on rv */
+ SV* sva;
+ SV *const target = SvRV(rv);
+ /* Less 1 for the reference we've already dealt with. */
+ U32 how_many = SvREFCNT(target) - 1;
+ MAGIC *mg;
+
+ if (SvMAGICAL(target) && (mg = mg_find(target, PERL_MAGIC_backref))) {
+ /* Back referneces also need to be found, but aren't part of the
+ target's reference count. */
+ how_many += 1 + av_len((AV*)mg->mg_obj);
+ }
+
+ if (!how_many) {
+ /* There was only 1 reference to this object. */
+ return;
+ }
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ register const SV * const svend = &sva[SvREFCNT(sva)];
+ register SV* sv;
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK
+ && (sv->sv_flags & SVf_ROK) == SVf_ROK
+ && SvREFCNT(sv)
+ && SvRV(sv) == target
+ && sv != rv) {
+ if (on)
+ SvAMAGIC_on(sv);
+ else
+ SvAMAGIC_off(sv);
+ if (--how_many == 0) {
+ /* We have found them all. */
+ return;
+ }
+ }
+ }
+ }
+}
+
/*
=for apidoc sv_bless
@@ -8025,10 +8071,17 @@
(void)SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc(stash));
- if (Gv_AMG(stash))
- SvAMAGIC_on(sv);
- else
- SvAMAGIC_off(sv);
+ if (Gv_AMG(stash)) {
+ if (!SvAMAGIC(sv)) {
+ SvAMAGIC_on(sv);
+ S_reset_amagic(aTHX_ sv, TRUE);
+ }
+ } else {
+ if (SvAMAGIC(sv)) {
+ SvAMAGIC_off(sv);
+ S_reset_amagic(aTHX_ sv, FALSE);
+ }
+ }
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
--- perl-5.8.8/proto.h.U27512 2006-06-01 18:43:19.000000000 -0400
+++ perl-5.8.8/proto.h 2006-06-01 19:13:32.000000000 -0400
@@ -1875,6 +1875,7 @@
#
STATIC bool S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send);
STATIC bool S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 offsetp, const U8 *s, const U8 *start);
+STATIC void S_reset_amagic(pTHX_ SV *rv, const bool on);
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
--- perl-5.8.8/embed.h.U27512 2006-06-01 18:43:19.000000000 -0400
+++ perl-5.8.8/embed.h 2006-06-01 19:13:32.000000000 -0400
@@ -1348,6 +1348,7 @@
#ifdef PERL_CORE
#define utf8_mg_pos S_utf8_mg_pos
#define utf8_mg_pos_init S_utf8_mg_pos_init
+#define reset_amagic S_reset_amagic
#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
@@ -3390,6 +3391,7 @@
#ifdef PERL_CORE
#define utf8_mg_pos(a,b,c,d,e,f,g,h,i) S_utf8_mg_pos(aTHX_ a,b,c,d,e,f,g,h,i)
#define utf8_mg_pos_init(a,b,c,d,e,f,g) S_utf8_mg_pos_init(aTHX_ a,b,c,d,e,f,g)
+#define reset_amagic(a,b) S_reset_amagic(aTHX_ a,b)
#endif
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
--- perl-5.8.8/embed.fnc.U27512 2006-06-01 18:43:19.000000000 -0400
+++ perl-5.8.8/embed.fnc 2006-06-01 19:13:32.000000000 -0400
@@ -1276,6 +1276,7 @@
s |bool |utf8_mg_pos_init |NN SV *sv|NN MAGIC **mgp \
|NN STRLEN **cachep|I32 i|I32 offsetp \
|NN const U8 *s|NN const U8 *start
+s |void |reset_amagic |NN SV *rv|const bool on
#endif
#if defined(PERL_IN_TOKE_C) || defined(PERL_DECL_PROT)
--- perl-5.8.8/lib/overload.t.U27512 2006-06-01 19:13:06.000000000 -0400
+++ perl-5.8.8/lib/overload.t 2006-06-01 19:13:32.000000000 -0400
@@ -47,7 +47,7 @@
package main;
$| = 1;
-use Test::More tests=>496;
+use Test::More tests => 508;
$a = new Oscalar "087";
@@ -1173,3 +1173,76 @@
like('x:a:a:=', qr/x$a$a=$/);
}
+
+{
+ package Sklorsh;
+ use overload
+ bool => sub { shift->is_cool };
+
+ sub is_cool {
+ $_[0]->{name} eq 'cool';
+ }
+
+ sub delete {
+ undef %{$_[0]};
+ bless $_[0], 'Brap';
+ return 1;
+ }
+
+ sub delete_with_self {
+ my $self = shift;
+ undef %$self;
+ bless $self, 'Brap';
+ return 1;
+ }
+
+ package Brap;
+
+ 1;
+
+ package main;
+
+ my $obj;
+ $obj = bless {name => 'cool'}, 'Sklorsh';
+ $obj->delete;
+ ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexist namespace');
+
+ $obj = bless {name => 'cool'}, 'Sklorsh';
+ $obj->delete_with_self;
+ ok (eval {if ($obj) {1}; 1}, $@);
+
+ my $a = $b = {name => 'hot'};
+ bless $b, 'Sklorsh';
+ is(ref $a, 'Sklorsh');
+ is(ref $b, 'Sklorsh');
+ ok(!$b, "Expect overloaded boolean");
+ ok(!$a, "Expect overloaded boolean");
+}
+{
+ use Scalar::Util 'weaken';
+
+ package Shklitza;
+ use overload '""' => sub {"CLiK KLAK"};
+
+ package Ksshfwoom;
+
+ package main;
+
+ my ($obj, $ref);
+ $obj = bless do {my $a; \$a}, 'Shklitza';
+ $ref = $obj;
+
+ is ($obj, "CLiK KLAK");
+ is ($ref, "CLiK KLAK");
+
+ weaken $ref;
+ is ($ref, "CLiK KLAK");
+
+ bless $obj, 'Ksshfwoom';
+
+ like ($obj, qr/^Ksshfwoom=/);
+ like ($ref, qr/^Ksshfwoom=/);
+
+ undef $obj;
+ is ($ref, undef);
+}

128
perl-5.8.8-U27604.patch Normal file
View File

@ -0,0 +1,128 @@
--- /dev/null 2006-06-01 12:59:27.771303750 -0400
+++ perl-5.8.8/t/op/regexp_qr.t 2006-06-01 19:24:53.000000000 -0400
@@ -0,0 +1,10 @@
+#!./perl
+
+$qr = 1;
+for $file ('./op/regexp.t', './t/op/regexp.t', ':op:regexp.t') {
+ if (-r $file) {
+ do $file;
+ exit;
+ }
+}
+die "Cannot find ./op/regexp.t or ./t/op/regexp.t\n";
--- perl-5.8.8/t/op/regexp.t.U27604 2001-10-27 14:09:24.000000000 -0400
+++ perl-5.8.8/t/op/regexp.t 2006-06-01 19:24:53.000000000 -0400
@@ -49,6 +49,7 @@
$bang = sprintf "\\%03o", ord "!"; # \41 would not be portable.
$ffff = chr(0xff) x 2;
$nulnul = "\0" x 2;
+$OP = $qr ? 'qr' : 'm';
$| = 1;
print "1..$numtests\n# $iters iterations\n";
@@ -73,7 +74,7 @@
$result =~ s/B//i unless $skip;
for $study ('', 'study \$subject') {
$c = $iters;
- eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
+ eval "$study; \$match = (\$subject =~ $OP$pat) while \$c--; \$got = \"$repl\";";
chomp( $err = $@ );
if ($result eq 'c') {
if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
--- perl-5.8.8/regexec.c.U27604 2006-01-08 15:59:30.000000000 -0500
+++ perl-5.8.8/regexec.c 2006-06-01 19:24:53.000000000 -0400
@@ -412,6 +412,7 @@
I32 ml_anch;
register char *other_last = Nullch; /* other substr checked before this */
char *check_at = Nullch; /* check substr found at this pos */
+ const I32 multiline = PL_multiline | (prog->reganch & PMf_MULTILINE);
#ifdef DEBUGGING
const char * const i_strpos = strpos;
SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
@@ -473,7 +474,7 @@
if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
|| ( (prog->reganch & ROPT_ANCH_BOL)
- && !PL_multiline ) ); /* Check after \n? */
+ && !multiline ) ); /* Check after \n? */
if (!ml_anch) {
if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
@@ -568,11 +569,11 @@
else if (prog->reganch & ROPT_CANY_SEEN)
s = fbm_instr((U8*)(s + start_shift),
(U8*)(strend - end_shift),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);
else
s = fbm_instr(HOP3(s, start_shift, strend),
HOP3(strend, -end_shift, strbeg),
- check, PL_multiline ? FBMrf_MULTILINE : 0);
+ check, multiline ? FBMrf_MULTILINE : 0);
/* Update the count-of-usability, remove useless subpatterns,
unshift s. */
@@ -643,7 +644,7 @@
HOP3(HOP3(last1, prog->anchored_offset, strend)
+ SvCUR(must), -(SvTAIL(must)!=0), strbeg),
must,
- PL_multiline ? FBMrf_MULTILINE : 0
+ multiline ? FBMrf_MULTILINE : 0
);
DEBUG_r(PerlIO_printf(Perl_debug_log,
"%s anchored substr \"%s%.*s%s\"%s",
@@ -704,7 +705,7 @@
s = fbm_instr((unsigned char*)s,
(unsigned char*)last + SvCUR(must)
- (SvTAIL(must)!=0),
- must, PL_multiline ? FBMrf_MULTILINE : 0);
+ must, multiline ? FBMrf_MULTILINE : 0);
/* FIXME - DEBUG_EXECUTE_r if that is merged to maint */
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
(s ? "Found" : "Contradicts"),
@@ -1639,6 +1640,7 @@
char *scream_olds;
SV* oreplsv = GvSV(PL_replgv);
const bool do_utf8 = DO_UTF8(sv);
+ const I32 multiline = PL_multiline | (prog->reganch & PMf_MULTILINE);
#ifdef DEBUGGING
SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
@@ -1756,7 +1758,7 @@
if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
if (s == startpos && regtry(prog, startpos))
goto got_it;
- else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
+ else if (multiline || (prog->reganch & ROPT_IMPLICIT)
|| (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
{
char *end;
@@ -1889,7 +1891,7 @@
end_shift, &scream_pos, 0))
: (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
(unsigned char*)strend, must,
- PL_multiline ? FBMrf_MULTILINE : 0))) ) {
+ multiline ? FBMrf_MULTILINE : 0))) ) {
/* we may be pointing at the wrong string */
if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX_const(sv));
@@ -1990,7 +1992,7 @@
if (SvTAIL(float_real)) {
if (memEQ(strend - len + 1, little, len - 1))
last = strend - len + 1;
- else if (!PL_multiline)
+ else if (!multiline)
last = memEQ(strend - len, little, len)
? strend - len : Nullch;
else
--- perl-5.8.8/MANIFEST.U27604 2006-01-31 18:27:53.000000000 -0500
+++ perl-5.8.8/MANIFEST 2006-06-01 19:24:52.000000000 -0400
@@ -2802,6 +2802,7 @@
t/op/ref.t See if refs and objects work
t/op/regexp_noamp.t See if regular expressions work with optimizations
t/op/regexp.t See if regular expressions work
+t/op/regexp_qr.t See if regular expressions work as qr//
t/op/regmesg.t See if one can get regular expression errors
t/op/repeat.t See if x operator works
t/op/re_tests Regular expressions for regexp.t

41
perl-5.8.8-U27605.patch Normal file
View File

@ -0,0 +1,41 @@
--- perl-5.8.8/mg.c.U27605 2006-01-27 15:23:21.000000000 -0500
+++ perl-5.8.8/mg.c 2006-06-01 19:37:17.000000000 -0400
@@ -2520,10 +2520,10 @@
#endif
/* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
- if (len >= (STRLEN)PL_origalen) {
- /* Longer than original, will be truncated. */
- Copy(s, PL_origargv[0], PL_origalen, char);
- PL_origargv[0][PL_origalen - 1] = 0;
+ if (len >= (STRLEN)PL_origalen-1) {
+ /* Longer than original, will be truncated. We assume that
+ * PL_origalen bytes are available. */
+ Copy(s, PL_origargv[0], PL_origalen-1, char);
}
else {
/* Shorter than original, will be padded. */
@@ -2536,9 +2536,10 @@
* --jhi */
(int)' ',
PL_origalen - len - 1);
- for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = 0;
}
+ PL_origargv[0][PL_origalen-1] = 0;
+ for (i = 1; i < PL_origargc; i++)
+ PL_origargv[i] = 0;
UNLOCK_DOLLARZERO_MUTEX;
break;
#endif
--- perl-5.8.8/perl.c.U27605 2006-06-01 19:00:57.000000000 -0400
+++ perl-5.8.8/perl.c 2006-06-01 19:37:17.000000000 -0400
@@ -1561,7 +1561,7 @@
}
}
}
- PL_origalen = s - PL_origargv[0];
+ PL_origalen = s - PL_origargv[0] + 1;
}
if (PL_do_undump) {

61
perl-5.8.8-U27914.patch Normal file
View File

@ -0,0 +1,61 @@
--- perl-5.8.8/t/op/local.t.U27914 2006-01-03 10:11:35.000000000 -0500
+++ perl-5.8.8/t/op/local.t 2006-06-01 19:49:54.000000000 -0400
@@ -4,7 +4,7 @@
chdir 't' if -d 't';
require './test.pl';
}
-plan tests => 81;
+plan tests => 85;
my $list_assignment_supported = 1;
@@ -313,3 +313,19 @@
{ local @x{c,d,e}; }
ok(! exists $x{c});
}
+
+# local() and readonly magic variables
+
+eval { local $1 = 1 };
+like($@, qr/Modification of a read-only value attempted/);
+
+eval { for ($1) { local $_ = 1 } };
+like($@, qr/Modification of a read-only value attempted/);
+
+# make sure $1 is still read-only
+eval { for ($1) { local $_ = 1 } };
+is($@, "");
+
+# The s/// adds 'g' magic to $_, but it should remain non-readonly
+eval { for("a") { for $x (1,2) { local $_="b"; s/(.*)/+$1/ } } };
+is($@, "");
--- perl-5.8.8/scope.c.U27914 2005-09-30 09:56:51.000000000 -0400
+++ perl-5.8.8/scope.c 2006-06-01 19:49:54.000000000 -0400
@@ -205,9 +205,9 @@
register SV * const sv = *sptr = NEWSV(0,0);
if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
+ MAGIC *mg;
sv_upgrade(sv, SvTYPE(osv));
if (SvGMAGICAL(osv)) {
- MAGIC* mg;
const bool oldtainted = PL_tainted;
mg_get(osv); /* note, can croak! */
if (PL_tainting && PL_tainted &&
@@ -220,6 +220,16 @@
PL_tainted = oldtainted;
}
SvMAGIC_set(sv, SvMAGIC(osv));
+ /* if it's a special scalar or if it has no 'set' magic,
+ * propagate the SvREADONLY flag. --rgs 20030922 */
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type == '\0'
+ || !(mg->mg_virtual && mg->mg_virtual->svt_set))
+ {
+ SvFLAGS(sv) |= SvREADONLY(osv);
+ break;
+ }
+ }
SvFLAGS(sv) |= SvMAGICAL(osv);
/* XXX SvMAGIC() is *shared* between osv and sv. This can
* lead to coredumps when both SVs are destroyed without one