cpan/File-Path/t/Path_root.t

   1 use strict;
   2 use Test::More;
   3 use Config;
   4 use lib './t';
   5 use FilePathTest qw(
   6     _run_for_warning
   7 );
   8 use File::Path qw(rmtree mkpath make_path remove_tree);
   9 use File::Spec::Functions;
  10
  11
  12 my $prereq = prereq();
  13 plan skip_all  => $prereq if defined $prereq;
  14 plan tests     => 11;
  15
  16 my $pwent = max_u();
  17 my $grent = max_g();
  18 my ( $max_uid, $max_user ) = @{ $pwent };
  19 my ( $max_gid, $max_group ) = @{ $grent };
  20
  21 my $tmp_base = catdir(
  22     curdir(),
  23     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
  24 );
  25
  26 # invent some names
  27 my @dir = (
  28     catdir($tmp_base, qw(a b)),
  29     catdir($tmp_base, qw(a c)),
  30     catdir($tmp_base, qw(z b)),
  31     catdir($tmp_base, qw(z c)),
  32 );
  33
  34 # create them
  35 my @created = mkpath([@dir]);
  36
  37 my $dir;
  38 my $dir2;
  39
  40 my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
  41
  42 $dir = catdir($dir_stem, 'aaa');
  43 @created = make_path($dir, {owner => $max_user});
  44 is(scalar(@created), 2, "created a directory owned by $max_user...");
  45
  46 my $dir_uid = (stat $created[0])[4];
  47 is($dir_uid, $max_uid, "... owned by $max_uid");
  48
  49 $dir = catdir($dir_stem, 'aab');
  50 @created = make_path($dir, {group => $max_group});
  51 is(scalar(@created), 1, "created a directory owned by group $max_group...");
  52
  53 my $dir_gid = (stat $created[0])[5];
  54 is($dir_gid, $max_gid, "... owned by group $max_gid");
  55
  56 $dir = catdir($dir_stem, 'aac');
  57 @created = make_path( $dir, { user => $max_user,
  58                               group => $max_group});
  59 is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
  60
  61 ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
  62 is($dir_uid, $max_uid, "... owned by $max_uid");
  63 is($dir_gid, $max_gid, "... owned by group $max_gid");
  64
  65 {
  66   # invent a user and group that don't exist
  67   my $phony_user = get_phony_user();
  68   my $phony_group = get_phony_group();
  69
  70   $dir = catdir($dir_stem, 'aad');
  71   my $rv = _run_for_warning( sub {
  72       make_path(
  73           $dir,
  74           { user => $phony_user, group => $phony_group }
  75       )
  76   } );
  77   like( $rv,
  78     qr{unable to map $phony_user to a uid, ownership not changed:}s,
  79     "created a directory not owned by $phony_user:$phony_group...",
  80   );
  81   like( $rv,
  82     qr{unable to map $phony_group to a gid, group ownership not changed:}s,
  83     "created a directory not owned by $phony_user:$phony_group...",
  84   );
  85 }
  86
  87 {
  88     # cleanup
  89     my $x;
  90     my $opts = { error => \$x };
  91     remove_tree($tmp_base, $opts);
  92     ok(! -d $tmp_base, "directory '$tmp_base' removed, as expected");
  93     is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts");
  94 }
  95
  96 sub max_u {
  97   # find the highest uid ('nobody' or similar)
  98   my $max_uid   = 0;
  99   my $max_user = undef;
 100   while (my @u = getpwent()) {
 101     if ($max_uid < $u[2]) {
 102       $max_uid  = $u[2];
 103       $max_user = $u[0];
 104     }
 105   }
 106   setpwent(); # in case we want to run again later
 107   return [ $max_uid, $max_user ];
 108 }
 109
 110 sub max_g {
 111   # find the highest gid ('nogroup' or similar)
 112   my $max_gid   = 0;
 113   my $max_group = undef;
 114   while ( my @g = getgrent() ) {
 115     print Dumper @g;
 116     if ($max_gid < $g[2]) {
 117       $max_gid = $g[2];
 118       $max_group = $g[0];
 119     }
 120   }
 121   setgrent(); # in case we want to run again later
 122   return [ $max_gid, $max_group ];
 123 }
 124
 125 sub prereq {
 126   return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
 127   return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
 128   return "not running as root" unless $< == 0;
 129   return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin';
 130
 131   my $pwent = max_u();
 132   my $grent = max_g();
 133   my ( $max_uid, $max_user ) = @{ $pwent };
 134   my ( $max_gid, $max_group ) = @{ $grent };
 135
 136   return "getpwent() appears to be insane" unless $max_uid > 0;
 137   return "getgrent() appears to be insane" unless $max_gid > 0;
 138   return undef;
 139 }
 140
 141 sub get_phony_user {
 142     return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
 143     return "not running as root" unless $< == 0;
 144     my %real_users = ();
 145     while(my @a=getpwent()) {
 146         $real_users{$a[0]}++;
 147     }
 148     my $phony_stem = 'phonyuser';
 149     my $phony = '';
 150     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_users{$phony});
 151     return $phony;
 152 }
 153
 154 sub get_phony_group {
 155     return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
 156     return "not running as root" unless $< == 0;
 157     my %real_groups = ();
 158     while(my @a=getgrent()) {
 159         $real_groups{$a[0]}++;
 160     }
 161     my $phony_stem = 'phonygroup';
 162     my $phony = '';
 163     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_groups{$phony});
 164     return $phony;
 165 }
 166