diff options
| -rw-r--r-- | doio.c | 62 | ||||
| -rw-r--r-- | pod/perlfunc.pod | 20 | ||||
| -rw-r--r-- | pod/perltodo.pod | 5 | ||||
| -rw-r--r-- | pp_sys.c | 49 | ||||
| -rwxr-xr-x | t/io/fs.t | 33 | ||||
| -rw-r--r-- | t/op/chdir.t | 19 |
6 files changed, 166 insertions, 22 deletions
@@ -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 447dad3fb1..b399298e74 100644 --- 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 5571970fc4..09ed1ff1e2 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 @@ -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. */ @@ -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 8929069f00..14024a6f25 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); |