This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: fchmod, fchown, fchdir
authorGisle Aas <gisle@aas.no>
Fri, 15 Jul 2005 02:32:50 +0000 (19:32 -0700)
committerH.Merijn Brand <h.m.brand@xs4all.nl>
Sat, 16 Jul 2005 08:07:44 +0000 (08:07 +0000)
Message-ID: <lrwtnse7nh.fsf@caliper.activestate.com>

+ Schwern's ok -> like changes

p4raw-id: //depot/perl@25157

doio.c
pod/perlfunc.pod
pod/perltodo.pod
pp_sys.c
t/io/fs.t
t/op/chdir.t

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) {
            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;
            }
        }
        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) {
            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;
            }
        }
        break;
index 447dad3..b399298 100644 (file)
@@ -603,6 +603,10 @@ previous time C<caller> was called.
 
 =item chdir EXPR
 
 
 =item chdir EXPR
 
+=item chdir FILEHANDLE
+
+=item chdir DIRHANDLE
+
 =item chdir
 
 Changes the working directory to EXPR, if possible. If EXPR is omitted,
 =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>.
 
 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
 =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
 
     $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:
 
 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;
 
     $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: ";
 Here's an example that looks up nonnumeric uids in the passwd file:
 
     print "User: ";
index 5571970..09ed1ff 100644 (file)
@@ -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?
 
 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
 =head2 Constant folding
 
 The peephole optimiser should trap errors during constant folding, and give
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;
 PP(pp_chdir)
 {
     dSP; dTARGET;
-    const char *tmps;
+    const char *tmps = 0;
+    GV *gv = 0;
     SV **svp;
 
     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
         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");
     }
 
     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. */
 #ifdef VMS
     /* Clear the DEFAULT element of ENV so we'll get the new value
      * in the future. */
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/;
 
 my $skip_mode_checks =
     $^O eq 'cygwin' && $ENV{CYGWIN} !~ /ntsec/;
 
-plan tests => 34;
+plan tests => 42;
 
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
 
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
@@ -166,6 +166,37 @@ SKIP: {
     is($ino, undef, "ino of removed file x should be undef");
 }
 
     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,
 is(rename('a','b'), 1, "rename a b");
 
 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
index 8929069..14024a6 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
 
 use Config;
 require "test.pl";
 
 use Config;
 require "test.pl";
-plan(tests => 31);
+plan(tests => 38);
 
 my $IsVMS   = $^O eq 'VMS';
 my $IsMacOS = $^O eq 'MacOS';
 
 my $IsVMS   = $^O eq 'VMS';
 my $IsMacOS = $^O eq 'MacOS';
@@ -42,6 +42,23 @@ SKIP: {
 
 $Cwd = abs_path;
 
 
 $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);
 
 # The environment variables chdir() pays attention to.
 my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);