t/testutil.pm

   1 #!/usr/bin/perl
   2
   3 #
   4 # Utilities shared by test scripts
   5 #
   6
   7 package testutil;
   8
   9 use strict;
  10 use warnings;
  11
  12 use Stow;
  13 use Stow::Util qw(parent canon_path);
  14
  15 use base qw(Exporter);
  16 our @EXPORT = qw(
  17     $OUT_DIR
  18     init_test_dirs
  19     cd
  20     new_Stow new_compat_Stow
  21     make_dir make_link make_file
  22     remove_dir remove_link
  23 );
  24
  25 our $OUT_DIR = 'tmp-testing-trees';
  26
  27 sub init_test_dirs {
  28     for my $dir ("$OUT_DIR/target", "$OUT_DIR/stow") {
  29         -d $dir and remove_dir($dir);
  30         make_dir($dir);
  31     }
  32
  33     # Don't let user's ~/.stow-global-ignore affect test results
  34     $ENV{HOME} = '/tmp/fake/home';
  35 }
  36
  37 sub new_Stow {
  38     my %opts = @_;
  39     $opts{dir}    ||= '../stow';
  40     $opts{target} ||= '.';
  41     $opts{test_mode} = 1;
  42     return new Stow(%opts);
  43 }
  44
  45 sub new_compat_Stow {
  46     my %opts = @_;
  47     $opts{compat} = 1;
  48     return new_Stow(%opts);
  49 }
  50
  51 #===== SUBROUTINE ===========================================================
  52 # Name      : make_link()
  53 # Purpose   : safely create a link
  54 # Parameters: $target => path to the link
  55 #           : $source => where the new link should point
  56 # Returns   : n/a
  57 # Throws    : fatal error if the link can not be safely created
  58 # Comments  : checks for existing nodes
  59 #============================================================================
  60 sub make_link {
  61     my ($target, $source) = @_;
  62
  63     if (-l $target) {
  64         my $old_source = readlink join('/', parent($target), $source)
  65             or die "could not read link $target/$source";
  66         if ($old_source ne $source) {
  67             die "$target already exists but points elsewhere\n";
  68         }
  69     }
  70     elsif (-e $target) {
  71         die "$target already exists and is not a link\n";
  72     }
  73     else {
  74         symlink $source, $target
  75             or die "could not create link $target => $source ($!)\n";
  76     }
  77     return;
  78 }
  79
  80 #===== SUBROUTINE ===========================================================
  81 # Name      : make_dir()
  82 # Purpose   : create a directory and any requisite parents
  83 # Parameters: $dir => path to the new directory
  84 # Returns   : n/a
  85 # Throws    : fatal error if the directory or any of its parents cannot be
  86 #           : created
  87 # Comments  : none
  88 #============================================================================
  89 sub make_dir {
  90     my ($dir) = @_;
  91
  92     my @parents = ();
  93     for my $part (split '/', $dir) {
  94         my $path = join '/', @parents, $part;
  95         if (not -d $path and not mkdir $path) {
  96             die "could not create directory: $path ($!)\n";
  97         }
  98         push @parents, $part;
  99     }
 100     return;
 101 }
 102
 103 #===== SUBROUTINE ===========================================================
 104 # Name      : create_file()
 105 # Purpose   : create an empty file
 106 # Parameters: $path => proposed path to the file
 107 #           : $contents => (optional) contents to write to file
 108 # Returns   : n/a
 109 # Throws    : fatal error if the file could not be created
 110 # Comments  : detects clash with an existing non-file
 111 #============================================================================
 112 sub make_file {
 113     my ($path, $contents) =@_;
 114
 115     if (-e $path and ! -f $path) {
 116         die "a non-file already exists at $path\n";
 117     }
 118
 119     open my $FILE ,'>', $path
 120         or die "could not create file: $path ($!)\n";
 121     print $FILE $contents if defined $contents;
 122     close $FILE;
 123 }
 124
 125 #===== SUBROUTINE ===========================================================
 126 # Name      : remove_link()
 127 # Purpose   : remove an esiting symbolic link
 128 # Parameters: $path => path to the symbolic link
 129 # Returns   : n/a
 130 # Throws    : fatal error if the operation fails or if passed the path to a
 131 #           : non-link
 132 # Comments  : none
 133 #============================================================================
 134 sub remove_link {
 135     my ($path) = @_;
 136     if (not -l $path) {
 137         die qq(remove_link() called with a non-link: $path);
 138     }
 139     unlink $path or die "could not remove link: $path ($!)\n";
 140     return;
 141 }
 142
 143 #===== SUBROUTINE ===========================================================
 144 # Name      : remove_file()
 145 # Purpose   : remove an existing empty file
 146 # Parameters: $path => the path to the empty file
 147 # Returns   : n/a
 148 # Throws    : fatal error if given file is non-empty or the operation fails
 149 # Comments  : none
 150 #============================================================================
 151 sub remove_file {
 152     my ($path) = @_;
 153     if (-z $path) {
 154         die "file at $path is non-empty\n";
 155     }
 156     unlink $path or die "could not remove empty file: $path ($!)\n";
 157     return;
 158 }
 159
 160 #===== SUBROUTINE ===========================================================
 161 # Name      : remove_dir()
 162 # Purpose   : safely remove a tree of test files
 163 # Parameters: $dir => path to the top of the tree
 164 # Returns   : n/a
 165 # Throws    : fatal error if the tree contains a non-link or non-empty file
 166 # Comments  : recursively removes directories containing softlinks empty files
 167 #============================================================================
 168 sub remove_dir {
 169     my ($dir) = @_;
 170
 171     if (not -d $dir) {
 172         die "$dir is not a directory";
 173     }
 174
 175     opendir my $DIR, $dir or die "cannot read directory: $dir ($!)\n";
 176     my @listing = readdir $DIR;
 177     closedir $DIR;
 178
 179     NODE:
 180     for my $node (@listing) {
 181         next NODE if $node eq '.';
 182         next NODE if $node eq '..';
 183
 184         my $path = "$dir/$node";
 185         if (-l $path or -z $path or $node eq $Stow::LOCAL_IGNORE_FILE) {
 186             unlink $path or die "cannot unlink $path ($!)\n";
 187         }
 188         elsif (-d "$path") {
 189             remove_dir($path);
 190         }
 191         else {
 192             die "$path is not a link, directory, or empty file\n";
 193         }
 194     }
 195     rmdir $dir or die "cannot rmdir $dir ($!)\n";
 196
 197     return;
 198 }
 199
 200 #===== SUBROUTINE ===========================================================
 201 # Name      : cd()
 202 # Purpose   : wrapper around chdir
 203 # Parameters: $dir => path to chdir to
 204 # Returns   : n/a
 205 # Throws    : fatal error if the chdir fails
 206 # Comments  : none
 207 #============================================================================
 208 sub cd {
 209     my ($dir) = @_;
 210     chdir $dir or die "Failed to chdir($dir): $!\n";
 211 }
 212
 213 1;
 214
 215 # Local variables:
 216 # mode: perl
 217 # cperl-indent-level: 4
 218 # end:
 219 # vim: ft=perl