From: Nicholas Clark Date: Mon, 3 Dec 2001 16:37:16 +0000 (+0000) Subject: shared hash keys and ++/-- X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3510b4a1c70ec95b37a6a1ef86c5555610f0dc75;p=p5sagit%2Fp5-mst-13.2.git shared hash keys and ++/-- Message-ID: <20011203163716.C21702@plum.flirble.org> p4raw-id: //depot/perl@13442 --- diff --git a/pp.c b/pp.c index 3ab629e..ff85c37 100644 --- a/pp.c +++ b/pp.c @@ -815,10 +815,10 @@ PP(pp_undef) PP(pp_predec) { dSP; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MIN) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -832,11 +832,11 @@ PP(pp_predec) PP(pp_postinc) { dSP; dTARGET; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MAX) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -853,11 +853,11 @@ PP(pp_postinc) PP(pp_postdec) { dSP; dTARGET; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); sv_setsv(TARG, TOPs); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MIN) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MIN) { --SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); diff --git a/pp_hot.c b/pp_hot.c index 8781b6c..29ec96b 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -302,10 +302,10 @@ PP(pp_eq) PP(pp_preinc) { dSP; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MAX) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); diff --git a/sv.c b/sv.c index b1da4a8..fcabd8e 100644 --- a/sv.c +++ b/sv.c @@ -5846,6 +5846,8 @@ Perl_sv_inc(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -6000,6 +6002,8 @@ Perl_sv_dec(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); diff --git a/t/op/inc.t b/t/op/inc.t index f59115e..f360c03 100755 --- a/t/op/inc.t +++ b/t/op/inc.t @@ -1,97 +1,153 @@ -#!./perl +#!./perl -w -print "1..12\n"; +# use strict; + +print "1..24\n"; + +my $test = 1; + +sub ok { + my ($pass, $wrong, $err) = @_; + if ($pass) { + print "ok $test\n"; + $test = $test + 1; # Would be doubleplusbad to use ++ in the ++ test. + return 1; + } else { + if ($err) { + chomp $err; + print "not ok $test # $err\n"; + } else { + if (defined $wrong) { + $wrong = ", got $wrong"; + } else { + $wrong = ''; + } + printf "not ok $test # line %d$wrong\n", (caller)[2]; + } + } + $test = $test + 1; + return; +} # Verify that addition/subtraction properly upgrade to doubles. # These tests are only significant on machines with 32 bit longs, # and two's complement negation, but shouldn't fail anywhere. -$a = 2147483647; -$c=$a++; -if ($a == 2147483648) - {print "ok 1\n"} -else - {print "not ok 1\n";} +my $a = 2147483647; +my $c=$a++; +ok ($a == 2147483648, $a); $a = 2147483647; $c=++$a; -if ($a == 2147483648) - {print "ok 2\n"} -else - {print "not ok 2\n";} +ok ($a == 2147483648, $a); $a = 2147483647; $a=$a+1; -if ($a == 2147483648) - {print "ok 3\n"} -else - {print "not ok 3\n";} +ok ($a == 2147483648, $a); $a = -2147483648; $c=$a--; -if ($a == -2147483649) - {print "ok 4\n"} -else - {print "not ok 4\n";} +ok ($a == -2147483649, $a); $a = -2147483648; $c=--$a; -if ($a == -2147483649) - {print "ok 5\n"} -else - {print "not ok 5\n";} +ok ($a == -2147483649, $a); $a = -2147483648; $a=$a-1; -if ($a == -2147483649) - {print "ok 6\n"} -else - {print "not ok 6\n";} +ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $c=$a--; -if ($a == -2147483649) - {print "ok 7\n"} -else - {print "not ok 7\n";} +ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $c=--$a; -if ($a == -2147483649) - {print "ok 8\n"} -else - {print "not ok 8\n";} +ok ($a == -2147483649, $a); $a = 2147483648; $a = -$a; $a=$a-1; -if ($a == -2147483649) - {print "ok 9\n"} -else - {print "not ok 9\n";} +ok ($a == -2147483649, $a); $a = 2147483648; $b = -$a; $c=$b--; -if ($b == -$a-1) - {print "ok 10\n"} -else - {print "not ok 10\n";} +ok ($b == -$a-1, $a); $a = 2147483648; $b = -$a; $c=--$b; -if ($b == -$a-1) - {print "ok 11\n"} -else - {print "not ok 11\n";} +ok ($b == -$a-1, $a); $a = 2147483648; $b = -$a; $b=$b-1; -if ($b == -(++$a)) - {print "ok 12\n"} -else - {print "not ok 12\n";} +ok ($b == -(++$a), $a); + +# Verify that shared hash keys become unshared. + +sub check_same { + my ($orig, $suspect) = @_; + my $fail; + while (my ($key, $value) = each %$suspect) { + if (exists $orig->{$key}) { + if ($orig->{$key} ne $value) { + print "# key '$key' was '$orig->{$key}' now '$value'\n"; + $fail = 1; + } + } else { + print "# key '$key' is '$orig->{$key}', unexpect.\n"; + $fail = 1; + } + } + foreach (keys %$orig) { + next if (exists $suspect->{$_}); + print "# key '$_' was '$orig->{$_}' now missing\n"; + $fail = 1; + } + ok (!$fail); +} + +my (%orig) = my (%inc) = my (%dec) = my (%postinc) = my (%postdec) + = (1 => 1, ab => "ab"); +my %up = (1=>2, ab => 'ac'); +my %down = (1=>0, ab => -1); + +foreach (keys %inc) { + my $ans = $up{$_}; + my $up; + eval {$up = ++$_}; + ok ((defined $up and $up eq $ans), $up, $@); +} + +check_same (\%orig, \%inc); + +foreach (keys %dec) { + my $ans = $down{$_}; + my $down; + eval {$down = --$_}; + ok ((defined $down and $down eq $ans), $down, $@); +} + +check_same (\%orig, \%dec); + +foreach (keys %postinc) { + my $ans = $postinc{$_}; + my $up; + eval {$up = $_++}; + ok ((defined $up and $up eq $ans), $up, $@); +} + +check_same (\%orig, \%postinc); + +foreach (keys %postdec) { + my $ans = $postdec{$_}; + my $down; + eval {$down = $_--}; + ok ((defined $down and $down eq $ans), $down, $@); +} + +check_same (\%orig, \%postdec);