develooper Front page | perl.perl5.porters | Postings from January 2009

[PATCH] Re: [PATCH] File::Copy & permission bits.

Thread Previous | Thread Next
From:
Charles Bailey
Date:
January 24, 2009 20:11
Subject:
[PATCH] Re: [PATCH] File::Copy & permission bits.
Message ID:
b78749dd0901242011p4a7fc4b9md52c30fb6d9af366@mail.gmail.com
On Sun, Jun 8, 2008 at 9:11 PM, Charles Bailey <bailey.charles@gmail.com> wrote:
>
> If you (or anyone else reading) had a free hand to rewrite
> Flle::Copy::cp(), is there anything besides copying permission bits
> you'd want?  Would it be worth thinking about timestamps, ownership,
> links, something else as options?
>
>
>> I'm also fine with leaving File::Copy not respecting permission bits
>> at all. But then I'd like to see a clear warning in the documentation
>> that File::Copy::copy isn't a replacement for "system cp", but behaves
>> differently. And I'll keep ranting against anyway claiming I should
>> favour File::Copy over "system cp".
>
> Seems like more documentation is worthwhile, regardless of the
> behavior that's finally chosen.

Well, I finally found a couple of tuits, and spent one learning
elementary git-fu, and the other on the attached patch.  It does the
following:

- Moves the permission-changing code to File::Copy::cp(), making it
non-identical to File::Copy::copy().  I think this is a decent
compromise, retaining backwards compatibility in the "primary"
routine, while allowing people who chose cp() to get more POSIXy
semantics.  It does break backwards compatibility of cp() wrt
permissions.  I can find a handful of examples in CPAN, for which I
hope smokers will give some feedback.  As for the DARKpan, who knows .
. .

- Expands the permission changing in cp() a bit to cover the rest of
what cp(1) claims on the local POSIX box.

- Removes Fcntl from the mix, to eliminate some build-time hoops.

- Shifts Abigail's permission tests to cp(), and adds parallel tests for copy().

- Documents the permission-related behavior in more detail.

It DOESN'T do the following:

- Make the permission changes in cp() conditional on an import key or
somesuch.  That'd retain backwards compatibility by default; do we
want to take this approach?

- Test the handling of setid bits.  Doing this properly would required
chown, and hence root, which doesn't strike me as belonging in the
regular test suite.  It looks like we don't test chown itself in this
way, so I figured adding skip-unless-I'm-root tests was overkill.

- Remove Scalar::Util.  It looks possible to replace the blessed() and
overload() checks with something like
    my $ra = ref $a;  "$a" !~ /^$ra\(0x[0-9a-f]+\)$/
  but I need to think it through a bit more and test it.

Review and comments welcome.

-- 
Regards,
Charles Bailey
Lists: bailey _dot_ charles _at_ gmail _dot_ com
Other: bailey _at_ newman _dot_ upenn _dot_ edu

From 059147c7cd7ec1635bbdaf90f3504429dd9e3f0e Mon Sep 17 00:00:00 2001
From: Charles Bailey <bailey.charles@gmail.com>
Date: Fri, 23 Jan 2009 19:11:45 -0500
Subject: [PATCH] Move cp(1)-like permission changes from copy to cp,
and add setid bit handling

---
 lib/File/Copy.pm |   89 ++++++++++++++++++++++++++++++++++++++----------------
 lib/File/Copy.t  |   37 ++++++++++++++++------
 2 files changed, 90 insertions(+), 36 deletions(-)

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index 984ef79..fc37ee6 100644
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -12,9 +12,7 @@ use strict;
 use warnings;
 use File::Spec;
 use Config;
-# During perl build, we need File::Copy but Fcntl might not be built yet
-my $Fcntl_loaded = eval q{ use Fcntl qw [O_CREAT O_WRONLY O_TRUNC]; 1 };
-# Similarly Scalar::Util
+# During perl build, we need File::Copy but Scalar::Util might not be built yet
 # And then we need these games to avoid loading overload, as that will
 # confuse miniperl during the bootstrap of perl.
 my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
@@ -229,7 +227,7 @@ sub copy {
     } else {
        open $from_h, "<", $from or goto fail_open1;
        binmode $from_h or die "($!,$^E)";
-	$closefrom = 1;
+       $closefrom = 1;
     }

     # Seems most logical to do this here, in case future changes would want to
@@ -245,15 +243,8 @@ sub copy {
        $to_h = $to;
     } else {
 	$to = _protect($to) if $to =~ /^\s/s;
-	if ($Fcntl_loaded) {
-	    my $perm = (stat $from_h) [2] & 0xFFF;
-	    sysopen $to_h, $to, O_CREAT() | O_TRUNC() | O_WRONLY(), $perm
-		or goto fail_open2;
-	}
-	else {
-	    $to_h = \do { local *FH };
-	    open $to_h, ">", $to or goto fail_open2;
-	}
+	$to_h = \do { local *FH };
+	open $to_h, ">", $to or goto fail_open2;
 	binmode $to_h or die "($!,$^E)";
 	$closeto = 1;
     }
@@ -295,10 +286,52 @@ sub copy {
     return 0;
 }

-sub move {
-    croak("Usage: move(FROM, TO) ") unless @_ == 2;
-
+sub cp {
     my($from,$to) = @_;
+    my(@fromstat) = stat $from;
+    my(@tostat) = stat $to;
+    my $perm;
+
+    return 0 unless copy(@_) and @fromstat;
+
+    if (@tostat) {
+        $perm = $tostat[2];
+    } else {
+        $perm = $fromstat[2] & ~(umask || 0);
+	@tostat = stat $to;
+    }
+    # Might be more robust to look for S_I* in Fcntl, but we're
+    # trying to avoid dependence on any XS-containing modules,
+    # since File::Copy is used during the Perl build.
+    $perm &= 07777;
+    if ($perm & 06000) {
+	croak("Unable to check setuid/setgid permissions for $to: $!")
+	    unless @tostat;
+
+	if ($perm & 04000 and                     # setuid
+	    $fromstat[4] != $tostat[4]) {         # owner must match
+	    $perm &= ~06000;
+	}
+
+	if ($perm & 02000) {                      # setgid
+	    my $ok = $fromstat[5] == $tostat[5];  # group must match
+	    if ($ok) {                            # and we must be in group
+	        my $uname = (getpwuid($>))[0] || '';
+		my(@members) = split /\s+/, (getgrgid($fromstat[5]))[3];
+		$ok = grep { $_ eq $uname } @members;
+	    }
+	    $perm &= ~06000 unless $ok;
+	}
+    }
+    return 0 unless @tostat;
+    return 1 if $perm == ($tostat[2] & 07777);
+    return eval { chmod $perm, $to; } ? 1 : 0;
+}
+
+sub _move {
+    croak("Usage: move(FROM, TO) ") unless @_ == 3;
+
+    my($from,$to,$fallback) = @_;

     my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);

@@ -371,7 +404,7 @@ sub move {
         local $@;
         eval {
             local $SIG{__DIE__};
-            copy($from,$to) or die;
+            $fallback->($from,$to) or die;
             my($atime, $mtime) = (stat($from))[8,9];
             utime($atime, $mtime, $to);
             unlink($from)   or die;
@@ -386,8 +419,8 @@ sub move {
     return 0;
 }

-*cp = \&copy;
-*mv = \&move;
+sub move { _move(@_,\&copy); }
+sub mv   { _move(@_,\&cp);   }

 # &syscopy is an XSUB under OS/2
 unless (defined &syscopy) {
@@ -483,11 +516,15 @@ being written to the second file. The default
buffer size depends
 upon the file, but will generally be the whole file (up to 2MB), or
 1k for filehandles that do not reference files (eg. sockets).

-You may use the syntax C<use File::Copy "cp"> to get at the
-"cp" alias for this function. The syntax is I<exactly> the same.
-
-As of version 2.14, on UNIX systems, "copy" will preserve permission
-bits like the shell utility C<cp> would do.
+You may use the syntax C<use File::Copy "cp"> to get at the C<cp>
+alias for this function. The syntax is I<exactly> the same.  The
+behavior is nearly the same as well: as of version 2.14, <cp> will
+preserve the source file's permission bits like the shell utility
+C<cp(1)> would do, while C<copy> uses the default permissions for the
+target file (which may depend on the process' C<umask>, file
+ownership, inherited ACLs, etc.).  If an error occurs in setting
+permissions, C<cp> will return 0, regardless of whether the file was
+successfully copied.

 =item move
 X<move> X<mv> X<rename>
@@ -503,8 +540,8 @@ the file to the new location and deletes the
original.  If an error occurs
 during this copy-and-delete process, you may be left with a (possibly partial)
 copy of the file under the destination name.

-You may use the "mv" alias for this function in the same way that
-you may use the "cp" alias for C<copy>.
+You may use the C<mv> alias for this function in the same way that
+you may use the <cp> alias for C<copy>.

 =item syscopy
 X<syscopy>
diff --git a/lib/File/Copy.t b/lib/File/Copy.t
index fc1f860..687e129 100755
--- a/lib/File/Copy.t
+++ b/lib/File/Copy.t
@@ -14,14 +14,14 @@ use Test::More;

 my $TB = Test::More->builder;

-plan tests => 136;
+plan tests => 157;

 # We're going to override rename() later on but Perl has to see an override
 # at compile time to honor it.
 BEGIN { *CORE::GLOBAL::rename = sub { CORE::rename($_[0], $_[1]) }; }


-use File::Copy;
+use File::Copy qw(copy move cp);
 use Config;


@@ -228,8 +228,8 @@ for my $cross_partition_test (0..1) {

 SKIP: {

-    skip "-- Copy preserves RMS defaults, not source file
permissions.", 21 if $^O eq 'VMS';
-    skip "Copy doesn't set file permissions correctly on Win32.", 21
if $^O eq "MSWin32";
+    skip "-- Copy preserves RMS defaults, not POSIX permissions.", 42
if $^O eq 'VMS';
+    skip "Copy doesn't set file permissions correctly on Win32.", 42
if $^O eq "MSWin32";

     # Just a sub to get better failure messages.
     sub __ ($) {
@@ -241,6 +241,9 @@ SKIP: {
     my $copy1 = "copy1-$$";
     my $copy2 = "copy2-$$";
     my $copy3 = "copy3-$$";
+    my $copy4 = "copy4-$$";
+    my $copy5 = "copy5-$$";
+    my $copy6 = "copy6-$$";

     open my $fh => ">", $src   or die $!;
     close   $fh                or die $!;
@@ -248,6 +251,9 @@ SKIP: {
     open    $fh => ">", $copy3 or die $!;
     close   $fh                or die $!;

+    open    $fh => ">", $copy6 or die $!;
+    close   $fh                or die $!;
+
     my @tests = (
         [0000,  0777,  0777,  0777],
         [0000,  0751,  0751,  0644],
@@ -261,32 +267,43 @@ SKIP: {
     foreach my $test (@tests) {
         my ($umask, $s_perm, $c_perm1, $c_perm3) = @$test;
         # Make sure the copies doesn't exist.
-        ! -e $_ or unlink $_ or die $! for $copy1, $copy2;
+        ! -e $_ or unlink $_ or die $! for $copy1, $copy2, $copy4, $copy5;

-       (umask $umask) // die $!;
-        chmod $s_perm  => $src   or die $!;
+	(umask $umask) // die $!;
+        chmod $s_perm  => $src   or die sprintf "$!: $src => %o", $s_perm;
         chmod $c_perm3 => $copy3 or die $!;
+        chmod $c_perm3 => $copy6 or die $!;

         open my $fh => "<", $src or die $!;

         copy ($src, $copy1);
         copy ($fh,  $copy2);
         copy ($src, $copy3);
+        cp   ($src, $copy4);
+        cp   ($fh,  $copy5);
+        cp   ($src, $copy6);

+	my $permdef = 0666 & ~$umask;
         my $perm1 = (stat $copy1) [2] & 0xFFF;
         my $perm2 = (stat $copy2) [2] & 0xFFF;
         my $perm3 = (stat $copy3) [2] & 0xFFF;
-        is (__$perm1, __$c_perm1, "Permission bits set correctly");
-        is (__$perm2, __$c_perm1, "Permission bits set correctly");
+        my $perm4 = (stat $copy4) [2] & 0xFFF;
+        my $perm5 = (stat $copy5) [2] & 0xFFF;
+        my $perm6 = (stat $copy6) [2] & 0xFFF;
+        is (__$perm1, __$permdef, "Permission bits set correctly");
+        is (__$perm2, __$permdef, "Permission bits set correctly");
+        is (__$perm4, __$c_perm1, "Permission bits set correctly");
+        is (__$perm5, __$c_perm1, "Permission bits set correctly");
         TODO: {
             local $TODO = 'Permission bits inconsistent under cygwin'
if $^O eq 'cygwin';
             is (__$perm3, __$c_perm3, "Permission bits not modified");
+            is (__$perm6, __$c_perm3, "Permission bits not modified");
         }
     }
     umask $old_mask or die $!;

     # Clean up.
-    ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3;
+    ! -e $_ or unlink $_ or die $! for $src, $copy1, $copy2, $copy3,
$copy4, $copy5, $copy6;
 }

 {
-- 
1.6.0.6

Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About