From: Gisle Aas Date: Fri, 15 Jul 2005 02:32:50 +0000 (-0700) Subject: Re: fchmod, fchown, fchdir X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c4aca7d03737ddcac23de1ad6d597e98be679214;p=p5sagit%2Fp5-mst-13.2.git Re: fchmod, fchown, fchdir Message-ID: + Schwern's ok -> like changes p4raw-id: //depot/perl@25157 --- diff --git a/doio.c b/doio.c index 4d7d19b..61a5371 100644 --- 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 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -603,6 +603,10 @@ previous time C 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 does nothing. It returns true upon success, false otherwise. See the example under C. +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, 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 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 --- 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 --- 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 --- 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 --- 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);