"H.Merijn Brand" <[EMAIL PROTECTED]> writes: > I'll just wait for the full patch, which I presume also has several test > cases along with it.
Here you go... diff -ru perl-current/doio.c perl-hack/doio.c --- perl-current/doio.c 2005-07-13 02:49:00.000000000 +0200 +++ perl-hack/doio.c 2005-07-15 08:43:20.000000000 +0200 @@ -1677,10 +1677,33 @@ 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 @@ 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 -ru perl-current/pod/perlfunc.pod perl-hack/pod/perlfunc.pod --- perl-current/pod/perlfunc.pod 2005-07-11 17:46:01.000000000 +0200 +++ perl-hack/pod/perlfunc.pod 2005-07-15 08:06:12.000000000 +0200 @@ -603,6 +603,10 @@ =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 @@ 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 @@ $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 @@ $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 -ru perl-current/pod/perltodo.pod perl-hack/pod/perltodo.pod --- perl-current/pod/perltodo.pod 2005-06-29 23:52:56.000000000 +0200 +++ perl-hack/pod/perltodo.pod 2005-07-15 08:09:32.000000000 +0200 @@ -178,11 +178,6 @@ 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 -ru perl-current/pp_sys.c perl-hack/pp_sys.c --- perl-current/pp_sys.c 2005-07-13 02:49:00.000000000 +0200 +++ perl-hack/pp_sys.c 2005-07-15 07:50:09.000000000 +0200 @@ -3542,15 +3542,24 @@ 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 @@ } 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 -ru perl-current/t/io/fs.t perl-hack/t/io/fs.t --- perl-current/t/io/fs.t 2005-01-24 16:37:42.000000000 +0100 +++ perl-hack/t/io/fs.t 2005-07-15 11:21:33.000000000 +0200 @@ -47,7 +47,7 @@ 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 @@ 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); }; + ok($@ =~ /^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); }; + ok($@ =~ /^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 -ru perl-current/t/op/chdir.t perl-hack/t/op/chdir.t --- perl-current/t/op/chdir.t 2003-05-21 17:31:40.000000000 +0200 +++ perl-hack/t/op/chdir.t 2005-07-15 11:19:53.000000000 +0200 @@ -9,7 +9,7 @@ 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 @@ $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); }; + ok($@ =~ /^The fchdir function is unimplemented at/, "fchdir is unimplemented"); +} + # The environment variables chdir() pays attention to. my @magic_envs = qw(HOME LOGDIR SYS$LOGIN);