Re: fchmod, fchown, fchdir

Message-ID: <lrwtnse7nh.fsf@caliper.activestate.com>

+ Schwern's ok -> like changes

p4raw-id: //depot/perl@25157

diff --git a/doio.c b/doio.c
index 4d7d19b..61a5371 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1677,10 +1677,33 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
            APPLY_TAINT_PROPER();
            tot = sp - mark;
            while (++mark <= sp) {
-               const char *name = SvPV_nolen_const(*mark);
-               APPLY_TAINT_PROPER();
-               if (PerlLIO_chmod(name, val))
-                   tot--;
+                GV* gv;
+                if (SvTYPE(*mark) == SVt_PVGV) {
+                    gv = (GV*)*mark;
+               do_fchmod:
+                   if (GvIO(gv) && IoIFP(GvIOp(gv))) {
+#ifdef HAS_FCHMOD
+                       APPLY_TAINT_PROPER();
+                       if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
+                           tot--;
+#else
+                       DIE(aTHX_ PL_no_func, "fchmod");
+#endif
+                   }
+                   else {
+                       tot--;
+                   }
+               }
+               else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) {
+                   gv = (GV*)SvRV(*mark);
+                   goto do_fchmod;
+               }
+               else {
+                   const char *name = SvPV_nolen_const(*mark);
+                   APPLY_TAINT_PROPER();
+                   if (PerlLIO_chmod(name, val))
+                       tot--;
+               }
            }
        }
        break;
@@ -1695,10 +1718,33 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
            APPLY_TAINT_PROPER();
            tot = sp - mark;
            while (++mark <= sp) {
-               const char *name = SvPV_nolen_const(*mark);
-               APPLY_TAINT_PROPER();
-               if (PerlLIO_chown(name, val, val2))
-                   tot--;
+                GV* gv;
+                if (SvTYPE(*mark) == SVt_PVGV) {
+                    gv = (GV*)*mark;
+               do_fchown:
+                   if (GvIO(gv) && IoIFP(GvIOp(gv))) {
+#ifdef HAS_FCHOWN
+                       APPLY_TAINT_PROPER();
+                       if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                           tot--;
+#else
+                       DIE(aTHX_ PL_no_func, "fchown");
+#endif
+                   }
+                   else {
+                       tot--;
+                   }
+               }
+               else if (SvROK(*mark) && SvTYPE(SvRV(*mark)) == SVt_PVGV) {
+                   gv = (GV*)SvRV(*mark);
+                   goto do_fchown;
+               }
+               else {
+                   const char *name = SvPV_nolen_const(*mark);
+                   APPLY_TAINT_PROPER();
+                   if (PerlLIO_chown(name, val, val2))
+                       tot--;
+               }
            }
        }
        break;

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 447dad3..b399298 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -603,6 +603,10 @@ previous time C<caller> was called.
 
 =item chdir EXPR
 
+=item chdir FILEHANDLE
+
+=item chdir DIRHANDLE
+
 =item chdir
 
 Changes the working directory to EXPR, if possible. If EXPR is omitted,
@@ -612,6 +616,10 @@ variable C<$ENV{SYS$LOGIN}> is also checked, and used if it is set.) If
 neither is set, C<chdir> does nothing. It returns true upon success,
 false otherwise. See the example under C<die>.
 
+On systems that support fchdir, you might pass a file handle or
+directory handle as argument.  On systems that don't support fchdir,
+passing handles produces a fatal error at run time.
+
 =item chmod LIST
 
 Changes the permissions of a list of files.  The first element of the
@@ -627,6 +635,14 @@ successfully changed.  See also L</oct>, if all you have is a string.
     $mode = '0644'; chmod oct($mode), 'foo'; # this is better
     $mode = 0644;   chmod $mode, 'foo';      # this is best
 
+On systems that support fchmod, you might pass file handles among the
+files.  On systems that don't support fchmod, passing file handles
+produces a fatal error at run time.
+
+    open(my $fh, "<", "foo");
+    my $perm = (stat $fh)[2] & 07777;
+    chmod($perm | 0600, $fh);
+
 You can also import the symbolic C<S_I*> constants from the Fcntl
 module:
 
@@ -712,6 +728,10 @@ successfully changed.
     $cnt = chown $uid, $gid, 'foo', 'bar';
     chown $uid, $gid, @filenames;
 
+On systems that support fchown, you might pass file handles among the
+files.  On systems that don't support fchown, passing file handles
+produces a fatal error at run time.
+
 Here's an example that looks up nonnumeric uids in the passwd file:
 
     print "User: ";

diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index 5571970..09ed1ff 100644 (file)
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -178,11 +178,6 @@ documented. It should be changed to use Filter::Simple, tested and documented.
 There are lots of functions which are retained for binary compatibility.
 Clean these up. Move them to mathom.c, and don't compile for blead?
 
-=head2 Use fchown/fchmod internally
-
-The old perltodo notes "This has been done in places, but needs a thorough
-code review. Also fchdir is available in some platforms."
-
 =head2 Constant folding
 
 The peephole optimiser should trap errors during constant folding, and give

diff --git a/pp_sys.c b/pp_sys.c
index 2d1752b..4430789 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3542,15 +3542,24 @@ PP(pp_ftbinary)
 PP(pp_chdir)
 {
     dSP; dTARGET;
-    const char *tmps;
+    const char *tmps = 0;
+    GV *gv = 0;
     SV **svp;
 
-    if( MAXARG == 1 )
-        tmps = POPpconstx;
-    else
-        tmps = 0;
+    if( MAXARG == 1 ) {
+       SV *sv = POPs;
+        if (SvTYPE(sv) == SVt_PVGV) {
+           gv = (GV*)sv;
+        }
+       else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
+            gv = (GV*)SvRV(sv);
+        }
+        else {
+           tmps = SvPVx_nolen_const(sv);
+       }
+    }
 
-    if( !tmps || !*tmps ) {
+    if( !gv && (!tmps || !*tmps) ) {
         if (    (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
              || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
 #ifdef VMS
@@ -3570,7 +3579,33 @@ PP(pp_chdir)
     }
 
     TAINT_PROPER("chdir");
-    PUSHi( PerlDir_chdir(tmps) >= 0 );
+    if (gv) {
+#ifdef HAS_FCHDIR
+       IO* io = GvIO(gv);
+       if (io) {
+           if (IoIFP(io)) {
+               PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+           }
+           else if (IoDIRP(io)) {
+#ifdef HAS_DIRFD
+               PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
+#else
+               DIE(aTHX PL_no_func, "dirfd");
+#endif
+           }
+           else {
+               PUSHi(0);
+           }
+        }
+       else {
+           PUSHi(0);
+       }
+#else
+       DIE(aTHX_ PL_no_func, "fchdir");
+#endif
+    }
+    else 
+        PUSHi( PerlDir_chdir(tmps) >= 0 );
 #ifdef VMS
     /* Clear the DEFAULT element of ENV so we'll get the new value
      * in the future. */

diff --git a/t/io/fs.t b/t/io/fs.t
index 30423f1..f1d5fc4 100755 (executable)
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -47,7 +47,7 @@ $needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
 my $skip_mode_checks =
     $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
 
-plan tests => 34;
+plan tests => 42;
 
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
@@ -166,6 +166,37 @@ SKIP: {
     is($ino, undef, "ino of removed file x should be undef");
 }
 
+SKIP: {
+    skip "no fchmod", 5 unless ($Config{d_fchmod} || "") eq "define";
+    ok(open(my $fh, "<", "a"), "open a");
+    is(chmod(0, $fh), 1, "fchmod");
+    $mode = (stat "a")[2];
+    is($mode & 0777, 0, "perm reset");
+    is(chmod($newmode, "a"), 1, "fchmod");
+    $mode = (stat $fh)[2];
+    is($mode & 0777, $newmode, "perm restored");
+}
+
+SKIP: {
+    skip "no fchown", 1 unless ($Config{d_fchown} || "") eq "define";
+    open(my $fh, "<", "a");
+    is(chown(-1, -1, $fh), 1, "fchown");
+}
+
+SKIP: {
+    skip "has fchmod", 1 if ($Config{d_fchmod} || "") eq "define";
+    open(my $fh, "<", "a");
+    eval { chmod(0777, $fh); };
+    like($@, qr/^The fchmod function is unimplemented at/, "fchmod is unimplemented");
+}
+
+SKIP: {
+    skip "has fchown", 1 if ($Config{d_fchown} || "") eq "define";
+    open(my $fh, "<", "a");
+    eval { chown(0, 0, $fh); };
+    like($@, qr/^The fchown function is unimplemented at/, "fchown is unimplemented");
+}
+
 is(rename('a','b'), 1, "rename a b");
 
 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,

diff --git a/t/op/chdir.t b/t/op/chdir.t
index 8929069..14024a6 100644 (file)
--- a/t/op/chdir.t
+++ b/t/op/chdir.t
@@ -9,7 +9,7 @@ BEGIN {
 
 use Config;
 require "test.pl";
-plan(tests => 31);
+plan(tests => 38);
 
 my $IsVMS   = $^O eq 'VMS';
 my $IsMacOS = $^O eq 'MacOS';
@@ -42,6 +42,23 @@ SKIP: {
 
 $Cwd = abs_path;
 
+SKIP: {
+    skip("no fchdir", 6) unless ($Config{d_fchdir} || "") eq "define";
+    ok(opendir(my $dh, "."), "opendir .");
+    ok(open(my $fh, "<", "op"), "open op");
+    ok(chdir($fh), "fchdir op");
+    ok(-f "chdir.t", "verify that we are in op");
+    ok(chdir($dh), "fchdir back");
+    ok(-d "op", "verify that we are back");
+}
+
+SKIP: {
+    skip("has fchdir", 1) if ($Config{d_fchdir} || "") eq "define";
+    opendir(my $dh, "op");
+    eval { chdir($dh); };
+    like($@, qr/^The fchdir function is unimplemented at/, "fchdir is unimplemented");
+}
+
 # The environment variables chdir() pays attention to.
 my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);