view release on metacpan or  search on metacpan

xt/setup_tests.pl  view on Meta::CPAN

    if not defined $opt{u};

  my ($uid, $gid) = $opt{u} =~ /\D/
      ? (getpwnam($opt{u}))[2,3]
      : (getpwuid($opt{u}))[2,3]
  ;

  create_dir($d, 0755);

  # directory EXTRA/1 could be deleted by a
  # non-privileged account, including one file belonging to root.
  create_dir ( $d . '/1',   0777, $uid, $gid );
  create_file( $d . '/1/a', 0600, $uid, $gid );
  create_file( $d . '/1/b', 0400, $uid, $gid );

  # contents of EXTRA/2 can be removed by a
  # non-privileged account.
  create_dir ( $d . '/2',   0700, $uid, $gid );
  create_file( $d . '/2/a', 0066, $<,   $(   );
  create_file( $d . '/2/b', 0400, $<,   $(   );
  create_file( $d . '/2/c', 0000, $uid, $gid );

  # directory EXTRA/3 contains sundry files
  create_dir(  $d . '/3',      0700, $uid, $gid );
  create_file( $d . '/3/a',    0400, $<,   $(   );
  create_file( $d . '/3/b',    0400, $uid, $gid );

  # directory EXTRA/4 is a symlink to EXTRA/3
  symlink './3', $d . '/4' or die "symlink: $!";

  create_dir(    $d . '/3/M',    0700, $uid, $gid );
  create_file(   $d . '/3/M/xx', 0400, $uid, $gid );
  create_file(   $d . '/3/M/yy', 0400, $uid, $gid );
  create_dir(    $d . '/3/S',    0000, $<,   $( );
  create_dir(    $d . '/3/T',    0000, $<,   $( );
  create_dir(    $d . '/3/U',    0000, $<,   $( );
  create_dir(    $d . '/3/V',    0700, $uid, $gid );
  symlink './M', $d . '/3/N' or die "symlink: $!";

  # inaccessible child dir
  create_dir (   $d . '/5',    0700, $<,   $( );
  create_file(   $d . '/5/xx', 0700, $<,   $( );
  create_file(   $d . '/5/yy', 0700, $<,   $( );
  chmod( 0200,   $d . '/5' );
}

sub teardown {
  die 'Must be root to teardown test' if $< != 0;
  rmtree($d);
}

sub create_dir {
    my $dir  = shift;
    my $mask = shift;
    my $uid  = shift;
    my $gid  = shift;
    if (!-d $dir) {
        mkdir $dir, $mask or die "mkdir $dir: $!\n";
    }
    if (defined $uid and defined $gid) {
        chown $uid, $gid, $dir
            or die "failed to chown dir $dir to ($uid,$gid)\n"
    }
}

sub create_file {
    my $file = shift;
    my $mask = shift;
    my $uid  = shift;
    my $gid  = shift;
    open OUT, "> $file" or die "Cannot open $file for output: $!\n";
    print OUT <<EOM;
Test file for module File::Path
If you can read this, feel free to delete this file.
EOM
    close OUT;
    if ($uid and defined $gid) {
        chown $uid, $gid, $file
            or die "failed to chown $file to ($uid,$gid)\n"
    }
    if (defined $mask) {
        chmod $mask, $file
            or die "failed to chmod $file to $mask: $!\n";
    }
}