diff options
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | op.c | 16 | ||||
| -rw-r--r-- | opcode.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 3 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | pp_sys.c | 5 | ||||
| -rw-r--r-- | t/op/chdir.t | 19 |
8 files changed, 44 insertions, 5 deletions
@@ -1701,6 +1701,7 @@ #endif #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop +#define ck_chdir Perl_ck_chdir #define ck_concat Perl_ck_concat #define ck_defined Perl_ck_defined #define ck_delete Perl_ck_delete @@ -3753,6 +3754,7 @@ #endif #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_concat(a) Perl_ck_concat(aTHX_ a) #define ck_defined(a) Perl_ck_defined(aTHX_ a) #define ck_delete(a) Perl_ck_delete(aTHX_ a) @@ -6760,6 +6760,22 @@ Perl_ck_svconst(pTHX_ OP *o) } OP * +Perl_ck_chdir(pTHX_ OP *o) +{ + if (o->op_flags & OPf_KIDS) { + SVOP *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) { if (o->op_flags & OPf_KIDS) { @@ -1427,7 +1427,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */ MEMBER_TO_FPTR(Perl_ck_ftst), /* fttty */ MEMBER_TO_FPTR(Perl_ck_ftst), /* fttext */ MEMBER_TO_FPTR(Perl_ck_ftst), /* ftbinary */ - MEMBER_TO_FPTR(Perl_ck_fun), /* chdir */ + MEMBER_TO_FPTR(Perl_ck_chdir), /* chdir */ MEMBER_TO_FPTR(Perl_ck_fun), /* chown */ MEMBER_TO_FPTR(Perl_ck_fun), /* chroot */ MEMBER_TO_FPTR(Perl_ck_fun), /* unlink */ @@ -907,7 +907,8 @@ ftbinary -B ck_ftst isu- F- # File calls. -chdir chdir ck_fun isT% S? +# chdir really behaves as if it had both "S?" and "F?" +chdir chdir ck_chdir isT% S? chown chown ck_fun imsT@ L chroot chroot ck_fun isTu% S? unlink unlink ck_fun imsTu@ L @@ -7,6 +7,7 @@ Perl_ck_anoncode Perl_ck_bitop +Perl_ck_chdir Perl_ck_concat Perl_ck_defined Perl_ck_delete diff --git a/pp_proto.h b/pp_proto.h index a64e335f61..1a368cdf5c 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -6,6 +6,7 @@ PERL_CKDEF(Perl_ck_anoncode) PERL_CKDEF(Perl_ck_bitop) +PERL_CKDEF(Perl_ck_chdir) PERL_CKDEF(Perl_ck_concat) PERL_CKDEF(Perl_ck_defined) PERL_CKDEF(Perl_ck_delete) @@ -3293,7 +3293,10 @@ PP(pp_chdir) if( MAXARG == 1 ) { SV * const sv = POPs; - if (SvTYPE(sv) == SVt_PVGV) { + if (PL_op->op_flags & OPf_SPECIAL) { + gv = gv_fetchsv(sv, 0, SVt_PVIO); + } + else if (SvTYPE(sv) == SVt_PVGV) { gv = (GV*)sv; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { diff --git a/t/op/chdir.t b/t/op/chdir.t index cb24da86c6..5b5ca3ff43 100644 --- a/t/op/chdir.t +++ b/t/op/chdir.t @@ -9,7 +9,7 @@ BEGIN { use Config; require "test.pl"; -plan(tests => 38); +plan(tests => 41); my $IsVMS = $^O eq 'VMS'; my $IsMacOS = $^O eq 'MacOS'; @@ -43,7 +43,7 @@ SKIP: { $Cwd = abs_path; SKIP: { - skip("no fchdir", 6) unless ($Config{d_fchdir} || "") eq "define"; + skip("no fchdir", 9) unless ($Config{d_fchdir} || "") eq "define"; ok(opendir(my $dh, "."), "opendir ."); ok(open(my $fh, "<", "op"), "open op"); ok(chdir($fh), "fchdir op"); @@ -56,6 +56,21 @@ SKIP: { like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); chdir ".."; } + + # same with bareword file handles + no warnings 'once'; + *DH = $dh; + *FH = $fh; + ok(chdir FH, "fchdir op bareword"); + ok(-f "chdir.t", "verify that we are in op"); + if (($Config{d_dirfd} || "") eq "define") { + ok(chdir DH, "fchdir back bareword"); + } + else { + eval { chdir(DH); }; + like($@, qr/^The dirfd function is unimplemented at/, "dirfd is unimplemented"); + chdir ".."; + } ok(-d "op", "verify that we are back"); } |