Allow bareword file handle as argument to chdir().

This copies the mechanism used by truncate().
Fixes bug #38457.

p4raw-id: //depot/perl@27125

diff --git a/embed.h b/embed.h
index d5c4f20..e586939 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -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)

diff --git a/op.c b/op.c
index 54c56c4..32927d3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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) {

diff --git a/opcode.h b/opcode.h
index 9551014..849b7d2 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -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 */

diff --git a/opcode.pl b/opcode.pl
index fdf07c1..61ab824 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -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

diff --git a/pp.sym b/pp.sym
index 1d1b876..2ca789f 100644 (file)
--- a/pp.sym
+++ b/pp.sym
@@ -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 a64e335..1a368cd 100644 (file)
--- 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)

diff --git a/pp_sys.c b/pp_sys.c
index fdda730..1659888 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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 cb24da8..5b5ca3f 100644 (file)
--- 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");
 }