view release on metacpan or  search on metacpan

sbin/foundry-lib/VCP/TestUtils.pm  view on Meta::CPAN

{
   my @tmp_dirs ;
   END { rmtree \@tmp_dirs unless $ENV{VCPNODELETE} }

   sub mk_tmp_dir {
      confess "undef!!" if grep !defined, @_ ;
      rmtree \@_ ;
      mkpath \@_, 0, 0770 ;
      push @tmp_dirs, @_ ;
   }
}

=item copy_dir_tree

   copy_dir_tree $src, $dest;

Copy source directory tree to a destination directory.  Accepts
absolute or relative directory names, but doesn't do tilde expansion.

=cut


sub copy_dir_tree {
   croak "usage $0 <src-dir> <dest-dir>\n"
      unless @_ == 2;

   my ($src_dir, $dest_dir) = @_;

   $src_dir = File::Spec->rel2abs( $src_dir );
   $dest_dir = File::Spec->rel2abs( $dest_dir );

   croak "destination and source directories are the same\n"
      if $dest_dir eq $src_dir;
   croak "destination directory specified as a subdir of source directory, stopping.\n"
      if $dest_dir =~ /^$src_dir/ ;

   croak "source directory '$src_dir' doesn't exist\n"
      unless -e $src_dir;
   croak "source directory '$src_dir' isn't a directory\n"
      unless -d $src_dir;
   croak "destination '$dest_dir' already exists\n"
      if -e $dest_dir;

   find(
      { 
         no_chdir => 1,
         wanted => sub {  
            my $newname = $_;
            $newname =~ s/^$src_dir/$dest_dir/ ;

            my ( $perms, $uid, $gid ) = (stat)[2,4,5];

            if ( -d ) {          # source was a directory
               mkdir $newname or croak "couldn't create directory '$newname': $!\n";
            }
            else {
               copy $_, $newname or croak "couldn't copy file from '$_' to '$newname'\n";
            }

            chmod $perms, $newname or warn "$!: chmod()ing $newname\n";
            chown $uid, $gid, $newname or warn "$!: chown()ing $newname\n";
         },
      },
      $src_dir 
   );
}


=item rm_dir_tree

    rm_dir_tree $path;

Remove a directory tree.  Does not complain if it's not there to remove.

=cut

sub rm_dir_tree {
   croak "usage $0 <doomed-dir>\n"
      unless @_ == 1;

   my( $doomed_dir ) = @_;

   return unless -e $doomed_dir;

   rmtree [ $doomed_dir ], 0;
}



=item assert_eq

   assert_eq $test_name, $in, $out ;

dies with a useful diff in $@ is $in ne $out.  Returns nothing.

Requires a diff that knows about the -d and -U options.

=cut


sub assert_eq {
   my ( $name, $in, $out ) = @_ ;

   ## Doint this because Test::Differences isn't quite "real" yet...
   croak diff \$in, \$out, { CONTEXT => 10 } if $in ne $out ;
}

=item slurp

   $guts = slurp $filename ;
   @lines = slurp $filename;

   read entire contents of file and return as a scalar, or array in
   array context (splitting on newlines.)

=cut

sub slurp {
   my ( $fn ) = @_ ;
   open F, "<$fn" or croak "$!: $fn" ;
   binmode F ;