From: Gisle Aas <gisle@activestate.com>
Date: Tue, 7 Feb 2006 17:32:50 +0000 (+0000)
Subject: Allow bareword file handle as argument to chdir().
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d4ac975eac140a6fda54f99664f15120fd97e7be;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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");
 }