In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/99a1d0d13934e829126ea4d0e61887470d8138e5?hp=4a74e76e73e572730d22e6798970f5981a893f48>
- Log ----------------------------------------------------------------- commit 99a1d0d13934e829126ea4d0e61887470d8138e5 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 22:19:56 2012 -0700 op.c: op_clear is tempting fate This if() statement can be reached by op types to which the OpTRANS* flags to not apply. They happen at present not to use any flags that conflict with these (except when OPf_KIDS is set, in which case this code is not reached). But we should make sure, via an assertion, that new flags added to goto or last do not conflict with trans utf8 flags, and that trans utf8 flags (1 and 2), if renumbered, do not con- flict with goto/last utf8 flags (128). M op.c commit 06b58b76f31d491371d0ab0c38cec33c1c7ba4ab Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 22:07:12 2012 -0700 Donât let ?: folding affect truncate truncate(${\1} ? foo : bar, 0) and truncate(1 ? foo : bar, 0) should behave the same way, but were treated differently, due to the way ?: is folded in the latter case. Now that foldedness is recorded in the op tree (cc2ebcd7902), we can use the OPpCONST_FOLDED flag to distin- guish truncate(1 ? foo : bar, 0) from truncate(foo, 0). M op.c M t/comp/fold.t commit 42409c4069deb2417b838a49810ecbce306a72b9 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 22:04:02 2012 -0700 Stop truncate(word) from falling back to file name In commit 5e0adc2d66, which was a bug fix, I made the mistake of checking the truth of the return value of gv_fetchsv, which is called when truncateâs argument is a bareword. This meant that truncate FOO, 0; would truncate the file named FOO if the glob happened to have been deleted. M pp_sys.c M t/io/fs.t commit 9a0c99494cbbb7d1253332ab4ce0581e90f707a7 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 20:15:36 2012 -0700 Donât let ?: folding affect stat stat(${\1} ? foo : bar) and stat(1 ? foo : bar) should behave the same way, but were treated differently, due to the way ?: is folded in the latter case. Now that foldedness is recorded in the op tree (cc2ebcd7902), we can use the OPpCONST_FOLDED flag to distinguish stat(1 ? foo : bar) from stat(foo). M op.c M t/comp/fold.t commit 8777c9be0f45ac3c917698c1afb18e1e8507a188 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 18:00:34 2012 -0700 Merge ck_trunc and ck_chdir ck_chdir, added in 2006 (d4ac975e) duplicates ck_trunc, added in 1993 (79072805), except for a null op check which is harmless when applied to chdir. M embed.h M op.c M opcode.h M proto.h M regen/opcodes commit c9df4fdaad9f9103ff3855e035e9eefd94acd65c Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 16:40:37 2012 -0700 op.c: dump LABEL leaks its label ./perl -Ilib -e 'warn $$; eval "sub { dump a }" while 1' Watch the memory usage go up. It didnât have its own case in op_clear. M op.c commit 513f78f74946f885de1f0b5ed65c1cffa85650b3 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 25 16:31:07 2012 -0700 op.c:op_free: Rmv dead code; simplify cop_free logic This reverts c53f1caa and cc93af5f. See the thread starting at http://www.nntp.perl.org/group/perl.perl5.porters/2008/04/msg135885.html Basically, change c53f1caa made a change, but then cc93af5f undid it, but differently. This resulted in dead code left by c53f1caa (type is unused after the assignment). And in the end the code behaved exactly the same way, so the original problem was not fixed. I suspect this was a B::C bug. M op.c ----------------------------------------------------------------------- Summary of changes: embed.h | 1 - op.c | 35 +++++++++-------------------------- opcode.h | 2 +- pp_sys.c | 6 +++--- proto.h | 6 ------ regen/opcodes | 2 +- t/comp/fold.t | 19 ++++++++++++++++++- t/io/fs.t | 12 ++++++++++-- 8 files changed, 42 insertions(+), 41 deletions(-) diff --git a/embed.h b/embed.h index f8be76d..5e9f6eb 100644 --- a/embed.h +++ b/embed.h @@ -1011,7 +1011,6 @@ #define check_utf8_print(a,b) Perl_check_utf8_print(aTHX_ a,b) #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) -#define ck_chdir(a) Perl_ck_chdir(aTHX_ a) #define ck_cmp(a) Perl_ck_cmp(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) #define ck_defined(a) Perl_ck_defined(aTHX_ a) diff --git a/op.c b/op.c index d5c5579..c613290 100644 --- a/op.c +++ b/op.c @@ -695,21 +695,17 @@ Perl_op_free(pTHX_ OP *o) op_free(kid); } } + if (type == OP_NULL) + type = (OPCODE)o->op_targ; Slab_to_rw(o); /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_DBSTATE - || (type == OP_NULL /* the COP might have been null'ed */ - && ((OPCODE)o->op_targ == OP_NEXTSTATE - || (OPCODE)o->op_targ == OP_DBSTATE))) { + if (type == OP_NEXTSTATE || type == OP_DBSTATE) { cop_free((COP*)o); } - if (type == OP_NULL) - type = (OPCODE)o->op_targ; - op_clear(o); FreeOp(o); #ifdef DEBUG_LEAKING_SCALARS @@ -812,6 +808,7 @@ Perl_op_clear(pTHX_ OP *o) } #endif break; + case OP_DUMP: case OP_GOTO: case OP_NEXT: case OP_LAST: @@ -822,6 +819,7 @@ Perl_op_clear(pTHX_ OP *o) case OP_TRANS: case OP_TRANSR: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { + assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { pad_swipe(cPADOPo->op_padix, TRUE); @@ -8133,7 +8131,8 @@ Perl_ck_ftst(pTHX_ OP *o) SVOP * const kid = (SVOP*)cUNOPo->op_first; const OPCODE kidtype = kid->op_type; - if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) { + if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE) + && !(kid->op_private & OPpCONST_FOLDED)) { OP * const newop = newGVOP(type, OPf_REF, gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO)); #ifdef PERL_MAD @@ -10023,23 +10022,6 @@ Perl_ck_svconst(pTHX_ OP *o) } OP * -Perl_ck_chdir(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_CHDIR; - if (o->op_flags & OPf_KIDS) { - SVOP * const kid = (SVOP*)cUNOPo->op_first; - - if (kid && kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) - { - o->op_flags |= OPf_SPECIAL; - kid->op_private &= ~OPpCONST_STRICT; - } - } - return ck_fun(o); -} - -OP * Perl_ck_trunc(pTHX_ OP *o) { PERL_ARGS_ASSERT_CK_TRUNC; @@ -10050,7 +10032,8 @@ Perl_ck_trunc(pTHX_ OP *o) if (kid->op_type == OP_NULL) kid = (SVOP*)kid->op_sibling; if (kid && kid->op_type == OP_CONST && - (kid->op_private & OPpCONST_BARE)) + (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED)) + == OPpCONST_BARE) { o->op_flags |= OPf_SPECIAL; kid->op_private &= ~OPpCONST_STRICT; diff --git a/opcode.h b/opcode.h index 2c7db83..10dc22a 100644 --- a/opcode.h +++ b/opcode.h @@ -1596,7 +1596,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ Perl_ck_ftst, /* fttty */ Perl_ck_ftst, /* fttext */ Perl_ck_ftst, /* ftbinary */ - Perl_ck_chdir, /* chdir */ + Perl_ck_trunc, /* chdir */ Perl_ck_fun, /* chown */ Perl_ck_fun, /* chroot */ Perl_ck_fun, /* unlink */ diff --git a/pp_sys.c b/pp_sys.c index 76bd1ac..a17227d 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2215,9 +2215,9 @@ PP(pp_truncate) GV *tmpgv; IO *io; - if ((tmpgv = PL_op->op_flags & OPf_SPECIAL - ? gv_fetchsv(sv, 0, SVt_PVIO) - : MAYBE_DEREF_GV(sv) )) { + if (PL_op->op_flags & OPf_SPECIAL + ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1) + : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) { io = GvIO(tmpgv); if (!io) result = 0; diff --git a/proto.h b/proto.h index 2c04468..1930ff3 100644 --- a/proto.h +++ b/proto.h @@ -312,12 +312,6 @@ PERL_CALLCONV OP * Perl_ck_bitop(pTHX_ OP *o) #define PERL_ARGS_ASSERT_CK_BITOP \ assert(o) -PERL_CALLCONV OP * Perl_ck_chdir(pTHX_ OP *o) - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_CK_CHDIR \ - assert(o) - PERL_CALLCONV OP * Perl_ck_cmp(pTHX_ OP *o) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); diff --git a/regen/opcodes b/regen/opcodes index da2212a..e249407 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -413,7 +413,7 @@ ftbinary -B ck_ftst isu- F- # File calls. # chdir really behaves as if it had both "S?" and "F?" -chdir chdir ck_chdir isT% S? +chdir chdir ck_trunc isT% S? chown chown ck_fun imsT@ L chroot chroot ck_fun isTu% S? unlink unlink ck_fun imsTu@ L diff --git a/t/comp/fold.t b/t/comp/fold.t index 69d1903..5d6d9bf 100644 --- a/t/comp/fold.t +++ b/t/comp/fold.t @@ -4,7 +4,7 @@ # we've not yet verified that use works. # use strict; -print "1..23\n"; +print "1..26\n"; my $test = 0; # Historically constant folding was performed by evaluating the ops, and if @@ -132,3 +132,20 @@ package other { # hide the "ok" sub print " ", ++$test, " - print followed by const || URSINE\n"; BEGIN { $^W = 1 } } + +# or stat +print "not " unless stat(1 ? INSTALL : 0) eq stat("INSTALL"); +print "ok ", ++$test, " - stat(const ? word : ....)\n"; +# in case we are in t/ +print "not " unless stat(1 ? TEST : 0) eq stat("TEST"); +print "ok ", ++$test, " - stat(const ? word : ....)\n"; + +# or truncate +my $n = "for_fold_dot_t$$"; +open F, ">$n" or die "open: $!"; +print F "bralh blah blah \n"; +close F or die "close $!"; +eval "truncate 1 ? $n : 0, 0;"; +print "not " unless -z $n; +print "ok ", ++$test, " - truncate(const ? word : ...)\n"; +unlink $n; diff --git a/t/io/fs.t b/t/io/fs.t index 1cdddec..26208c1 100644 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -46,7 +46,7 @@ $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95()); my $skip_mode_checks = $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/; -plan tests => 51; +plan tests => 52; my $tmpdir = tempfile(); my $tmpdir1 = tempfile(); @@ -372,7 +372,7 @@ SKIP: { SKIP: { if ($^O eq 'vos') { - skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 5); + skip ("# TODO - hit VOS bug posix-973 - cannot resize an open file below the current file pos.", 6); } is(-s $tmpfile, 200, "fh resize to 200 working (filename check)"); @@ -407,6 +407,14 @@ SKIP: { is(-s $tmpfile, 100, "fh resize by IO slot working"); close FH; + + my $n = "for_fs_dot_t$$"; + open FH, ">$n" or die "open $n: $!"; + print FH "bloh blah bla\n"; + close FH or die "close $n: $!"; + eval "truncate $n, 0; 1" or die; + ok !-z $n, 'truncate(word) does not fall back to file name'; + unlink $n; } } -- Perl5 Master Repository
