In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c22c99bc35171a7072ba6278b8a0fdbbaa86236a?hp=a3342be368647e67883bc6ba3bea07bb06880b80>
- Log ----------------------------------------------------------------- commit c22c99bc35171a7072ba6278b8a0fdbbaa86236a Author: Father Chrysostomos <[email protected]> Date: Fri Sep 16 16:15:53 2011 -0700 Merge postinc and postdec They were nearly identical. M opcode.h M pp.c M pp_proto.h M regen/opcode.pl commit 17058fe0299db92774e157ee0067d1b500324e4f Author: Father Chrysostomos <[email protected]> Date: Fri Sep 16 16:10:57 2011 -0700 Merge preinc and postinc They are almost identical. This gives the compiler less code to digest. M opcode.h M pp.c M pp_hot.c M pp_proto.h M regen/opcode.pl commit 60092ce4854ea5801a4711d82d0e2c57a7edcaca Author: Father Chrysostomos <[email protected]> Date: Fri Sep 16 15:48:46 2011 -0700 Make ++ and -- work on glob copies These ops considered typeglobs read-only, even if they werenât. M pod/perldelta.pod M pp.c M pp_hot.c M sv.c M t/op/auto.t ----------------------------------------------------------------------- Summary of changes: opcode.h | 14 ++++++++------ pod/perldelta.pod | 4 ++++ pp.c | 51 ++++++++------------------------------------------- pp_hot.c | 11 +++++++---- pp_proto.h | 2 -- regen/opcode.pl | 6 ++---- sv.c | 4 ++-- t/op/auto.t | 12 ++++++++++-- 8 files changed, 41 insertions(+), 63 deletions(-) diff --git a/opcode.h b/opcode.h index de1a42d..0d0990e 100644 --- a/opcode.h +++ b/opcode.h @@ -22,9 +22,11 @@ #define Perl_pp_chomp Perl_pp_chop #define Perl_pp_schomp Perl_pp_schop #define Perl_pp_i_preinc Perl_pp_preinc -#define Perl_pp_i_predec Perl_pp_predec +#define Perl_pp_predec Perl_pp_preinc +#define Perl_pp_i_predec Perl_pp_preinc #define Perl_pp_i_postinc Perl_pp_postinc -#define Perl_pp_i_postdec Perl_pp_postdec +#define Perl_pp_postdec Perl_pp_postinc +#define Perl_pp_i_postdec Perl_pp_postinc #define Perl_pp_slt Perl_pp_sle #define Perl_pp_sgt Perl_pp_sle #define Perl_pp_sge Perl_pp_sle @@ -967,12 +969,12 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */ Perl_pp_pos, Perl_pp_preinc, Perl_pp_i_preinc, /* implemented by Perl_pp_preinc */ - Perl_pp_predec, - Perl_pp_i_predec, /* implemented by Perl_pp_predec */ + Perl_pp_predec, /* implemented by Perl_pp_preinc */ + Perl_pp_i_predec, /* implemented by Perl_pp_preinc */ Perl_pp_postinc, Perl_pp_i_postinc, /* implemented by Perl_pp_postinc */ - Perl_pp_postdec, - Perl_pp_i_postdec, /* implemented by Perl_pp_postdec */ + Perl_pp_postdec, /* implemented by Perl_pp_postinc */ + Perl_pp_i_postdec, /* implemented by Perl_pp_postinc */ Perl_pp_pow, Perl_pp_multiply, Perl_pp_i_multiply, diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 37a4d5d..8b09500 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -805,6 +805,10 @@ C<glob> now clears %ENV before calling csh, since the latter croaks on some systems if it does not like the contents of the LS_COLORS enviroment variable [perl #98662]. +=item * + +C<++> and C<--> now work on copies of globs, instead of dying. + =back =head1 Known Problems diff --git a/pp.c b/pp.c index 84c68e6..48774bd 100644 --- a/pp.c +++ b/pp.c @@ -1051,68 +1051,33 @@ PP(pp_undef) RETPUSHUNDEF; } -PP(pp_predec) -{ - dVAR; dSP; - if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) - Perl_croak_no_modify(aTHX); - if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != IV_MIN) - { - SvIV_set(TOPs, SvIVX(TOPs) - 1); - SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); - } - else - sv_dec(TOPs); - SvSETMAGIC(TOPs); - return NORMAL; -} - PP(pp_postinc) { dVAR; dSP; dTARGET; - if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) + const bool inc = + PL_op->op_type == OP_POSTINC || PL_op->op_type == OP_I_POSTINC; + if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) Perl_croak_no_modify(aTHX); if (SvROK(TOPs)) TARG = sv_newmortal(); sv_setsv(TARG, TOPs); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != IV_MAX) + && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) { - SvIV_set(TOPs, SvIVX(TOPs) + 1); + SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } - else + else if (inc) sv_inc_nomg(TOPs); + else sv_dec_nomg(TOPs); SvSETMAGIC(TOPs); /* special case for undef: see thread at 2003-03/msg00536.html in archive */ - if (!SvOK(TARG)) + if (inc && !SvOK(TARG)) sv_setiv(TARG, 0); SETs(TARG); return NORMAL; } -PP(pp_postdec) -{ - dVAR; dSP; dTARGET; - if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) - Perl_croak_no_modify(aTHX); - if (SvROK(TOPs)) - TARG = sv_newmortal(); - sv_setsv(TARG, TOPs); - if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != IV_MIN) - { - SvIV_set(TOPs, SvIVX(TOPs) - 1); - SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); - } - else - sv_dec_nomg(TOPs); - SvSETMAGIC(TOPs); - SETs(TARG); - return NORMAL; -} - /* Ordinary operators. */ PP(pp_pow) diff --git a/pp_hot.c b/pp_hot.c index ca6b195..59fc443 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -362,16 +362,19 @@ PP(pp_eq) PP(pp_preinc) { dVAR; dSP; - if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs)) + const bool inc = + PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC; + if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))) Perl_croak_no_modify(aTHX); if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) - && SvIVX(TOPs) != IV_MAX) + && SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN)) { - SvIV_set(TOPs, SvIVX(TOPs) + 1); + SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1)); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); } else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */ - sv_inc(TOPs); + if (inc) sv_inc(TOPs); + else sv_dec(TOPs); SvSETMAGIC(TOPs); return NORMAL; } diff --git a/pp_proto.h b/pp_proto.h index 5e19fc3..bc4622b 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -167,10 +167,8 @@ PERL_CALLCONV OP *Perl_pp_padhv(pTHX); PERL_CALLCONV OP *Perl_pp_padsv(pTHX); PERL_CALLCONV OP *Perl_pp_pipe_op(pTHX); PERL_CALLCONV OP *Perl_pp_pos(pTHX); -PERL_CALLCONV OP *Perl_pp_postdec(pTHX); PERL_CALLCONV OP *Perl_pp_postinc(pTHX); PERL_CALLCONV OP *Perl_pp_pow(pTHX); -PERL_CALLCONV OP *Perl_pp_predec(pTHX); PERL_CALLCONV OP *Perl_pp_preinc(pTHX); PERL_CALLCONV OP *Perl_pp_print(pTHX); PERL_CALLCONV OP *Perl_pp_prototype(pTHX); diff --git a/regen/opcode.pl b/regen/opcode.pl index b4576da..d8186cd 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -116,10 +116,8 @@ my @raw_alias = ( Perl_pp_chop => [qw(chop chomp)], Perl_pp_schop => [qw(schop schomp)], Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'}, - Perl_pp_preinc => ['i_preinc'], - Perl_pp_predec => ['i_predec'], - Perl_pp_postinc => ['i_postinc'], - Perl_pp_postdec => ['i_postdec'], + Perl_pp_preinc => ['i_preinc', 'predec', 'i_predec'], + Perl_pp_postinc => ['i_postinc', 'postdec', 'i_postdec'], Perl_pp_ehostent => [qw(enetent eprotoent eservent spwent epwent sgrent egrent)], Perl_pp_shostent => [qw(snetent sprotoent sservent)], diff --git a/sv.c b/sv.c index d6d32e7..6ab04da 100644 --- a/sv.c +++ b/sv.c @@ -7848,7 +7848,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv) if (!sv) return; if (SvTHINKFIRST(sv)) { - if (SvIsCOW(sv)) + if (SvIsCOW(sv) || isGV_with_GP(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) @@ -8029,7 +8029,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv) if (!sv) return; if (SvTHINKFIRST(sv)) { - if (SvIsCOW(sv)) + if (SvIsCOW(sv) || isGV_with_GP(sv)) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) diff --git a/t/op/auto.t b/t/op/auto.t index ecfe48b..00f7caa 100644 --- a/t/op/auto.t +++ b/t/op/auto.t @@ -3,10 +3,10 @@ BEGIN { chdir 't' if -d 't'; @INC = qw(. ../lib); + require "test.pl"; } -require "test.pl"; -plan( tests => 39 ); +plan( tests => 47 ); $x = 10000; cmp_ok(0 + ++$x - 1,'==',10000,'scalar ++x - 1'); @@ -55,3 +55,11 @@ cmp_ok(++($foo = 'zz'), 'eq','aaa','zzz incr aaa'); cmp_ok(++($foo = 'A99'),'eq','B00','A99 incr B00'); cmp_ok(++($foo = 'zi'), 'eq','zj','zi incr zj (EBCDIC i,j non-contiguous check)'); cmp_ok(++($foo = 'zr'), 'eq','zs','zr incr zs (EBCDIC r,s non-contiguous check)'); + +# test with glob copies + +for(qw '$x++ ++$x $x-- --$x') { + my $x = *foo; + ok eval "$_; 1", "$_ does not die on a glob copy"; + is $x, /-/ ? -1 : 1, "result of $_ on a glob copy"; +} -- Perl5 Master Repository
