t/testutil.pm

   1 #!/usr/bin/perl
   2 #
   3 # This file is part of GNU Stow.
   4 #
   5 # GNU Stow is free software: you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # GNU Stow is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program. If not, see https://www.gnu.org/licenses/.
  17
  18 #
  19 # Utilities shared by test scripts
  20 #
  21
  22 package testutil;
  23
  24 use strict;
  25 use warnings;
  26
  27 use Carp qw(croak);
  28 use File::Basename;
  29 use File::Path qw(make_path remove_tree);
  30 use File::Spec;
  31 use IO::Scalar;
  32 use Test::More;
  33
  34 use Stow;
  35 use Stow::Util qw(parent canon_path);
  36
  37 use base qw(Exporter);
  38 our @EXPORT = qw(
  39     $ABS_TEST_DIR
  40     $TEST_DIR
  41     $stderr
  42     init_test_dirs
  43     cd
  44     new_Stow new_compat_Stow
  45     make_path make_link make_invalid_link make_file
  46     remove_dir remove_file remove_link
  47     cat_file
  48     is_link is_dir_not_symlink is_nonexistent_path
  49     capture_stderr uncapture_stderr
  50 );
  51
  52 our $TEST_DIR = 'tmp-testing-trees';
  53 our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees');
  54
  55 our $stderr;
  56 my $tied_err;
  57
  58 sub capture_stderr {
  59     undef $stderr;
  60     $tied_err = tie *STDERR, 'IO::Scalar', \$stderr;
  61 }
  62
  63 sub uncapture_stderr {
  64     undef $tied_err;
  65     untie *STDERR;
  66 }
  67
  68 sub init_test_dirs {
  69     -d "t" or die "Was expecting tests to be run from root of repo\n";
  70
  71     # Create a run_from/ subdirectory for tests which want to run
  72     # from a separate directory outside the Stow directory or
  73     # target directory.
  74     for my $dir ("target", "stow", "run_from") {
  75         my $path = "$TEST_DIR/$dir";
  76         -d $path and remove_tree($path);
  77         make_path($path);
  78     }
  79
  80     # Don't let user's ~/.stow-global-ignore affect test results
  81     $ENV{HOME} = $ABS_TEST_DIR;
  82 }
  83
  84 sub new_Stow {
  85     my %opts = @_;
  86     # These default paths assume that execution will be triggered from
  87     # within the target directory.
  88     $opts{dir}    ||= '../stow';
  89     $opts{target} ||= '.';
  90     $opts{test_mode} = 1;
  91     return new Stow(%opts);
  92 }
  93
  94 sub new_compat_Stow {
  95     my %opts = @_;
  96     $opts{compat} = 1;
  97     return new_Stow(%opts);
  98 }
  99
 100 #===== SUBROUTINE ===========================================================
 101 # Name      : make_link()
 102 # Purpose   : safely create a link
 103 # Parameters: $target => path to the link
 104 #           : $source => where the new link should point
 105 #           : $invalid => true iff $source refers to non-existent file
 106 # Returns   : n/a
 107 # Throws    : fatal error if the link can not be safely created
 108 # Comments  : checks for existing nodes
 109 #============================================================================
 110 sub make_link {
 111     my ($target, $source, $invalid) = @_;
 112
 113     if (-l $target) {
 114         my $old_source = readlink join('/', parent($target), $source)
 115             or die "$target is already a link but could not read link $target/$source";
 116         if ($old_source ne $source) {
 117             die "$target already exists but points elsewhere\n";
 118         }
 119     }
 120     die "$target already exists and is not a link\n" if -e $target;
 121     my $abs_target = File::Spec->rel2abs($target);
 122     my $target_container = dirname($abs_target);
 123     my $abs_source = File::Spec->rel2abs($source, $target_container);
 124     #warn "t $target c $target_container as $abs_source";
 125     if (-e $abs_source) {
 126         croak "Won't make invalid link pointing to existing $abs_target"
 127             if $invalid;
 128     }
 129     else {
 130         croak "Won't make link pointing to non-existent $abs_target"
 131             unless $invalid;
 132     }
 133     symlink $source, $target
 134         or die "could not create link $target => $source ($!)\n";
 135 }
 136
 137 #===== SUBROUTINE ===========================================================
 138 # Name      : make_invalid_link()
 139 # Purpose   : safely create an invalid link
 140 # Parameters: $target => path to the link
 141 #           : $source => the non-existent source where the new link should point
 142 # Returns   : n/a
 143 # Throws    : fatal error if the link can not be safely created
 144 # Comments  : checks for existing nodes
 145 #============================================================================
 146 sub make_invalid_link {
 147     my ($target, $source, $allow_invalid) = @_;
 148     make_link($target, $source, 1);
 149 }
 150
 151 #===== SUBROUTINE ===========================================================
 152 # Name      : create_file()
 153 # Purpose   : create an empty file
 154 # Parameters: $path => proposed path to the file
 155 #           : $contents => (optional) contents to write to file
 156 # Returns   : n/a
 157 # Throws    : fatal error if the file could not be created
 158 # Comments  : detects clash with an existing non-file
 159 #============================================================================
 160 sub make_file {
 161     my ($path, $contents) = @_;
 162
 163     if (-e $path and ! -f $path) {
 164         die "a non-file already exists at $path\n";
 165     }
 166
 167     open my $FILE ,'>', $path
 168         or die "could not create file: $path ($!)\n";
 169     print $FILE $contents if defined $contents;
 170     close $FILE;
 171 }
 172
 173 #===== SUBROUTINE ===========================================================
 174 # Name      : remove_link()
 175 # Purpose   : remove an esiting symbolic link
 176 # Parameters: $path => path to the symbolic link
 177 # Returns   : n/a
 178 # Throws    : fatal error if the operation fails or if passed the path to a
 179 #           : non-link
 180 # Comments  : none
 181 #============================================================================
 182 sub remove_link {
 183     my ($path) = @_;
 184     if (not -l $path) {
 185         die qq(remove_link() called with a non-link: $path);
 186     }
 187     unlink $path or die "could not remove link: $path ($!)\n";
 188     return;
 189 }
 190
 191 #===== SUBROUTINE ===========================================================
 192 # Name      : remove_file()
 193 # Purpose   : remove an existing empty file
 194 # Parameters: $path => the path to the empty file
 195 # Returns   : n/a
 196 # Throws    : fatal error if given file is non-empty or the operation fails
 197 # Comments  : none
 198 #============================================================================
 199 sub remove_file {
 200     my ($path) = @_;
 201     if (-z $path) {
 202         die "file at $path is non-empty\n";
 203     }
 204     unlink $path or die "could not remove empty file: $path ($!)\n";
 205     return;
 206 }
 207
 208 #===== SUBROUTINE ===========================================================
 209 # Name      : remove_dir()
 210 # Purpose   : safely remove a tree of test files
 211 # Parameters: $dir => path to the top of the tree
 212 # Returns   : n/a
 213 # Throws    : fatal error if the tree contains a non-link or non-empty file
 214 # Comments  : recursively removes directories containing softlinks empty files
 215 #============================================================================
 216 sub remove_dir {
 217     my ($dir) = @_;
 218
 219     if (not -d $dir) {
 220         die "$dir is not a directory";
 221     }
 222
 223     opendir my $DIR, $dir or die "cannot read directory: $dir ($!)\n";
 224     my @listing = readdir $DIR;
 225     closedir $DIR;
 226
 227     NODE:
 228     for my $node (@listing) {
 229         next NODE if $node eq '.';
 230         next NODE if $node eq '..';
 231
 232         my $path = "$dir/$node";
 233         if (-l $path or (-f $path and -z $path) or $node eq $Stow::LOCAL_IGNORE_FILE) {
 234             unlink $path or die "cannot unlink $path ($!)\n";
 235         }
 236         elsif (-d "$path") {
 237             remove_dir($path);
 238         }
 239         else {
 240             die "$path is not a link, directory, or empty file\n";
 241         }
 242     }
 243     rmdir $dir or die "cannot rmdir $dir ($!)\n";
 244
 245     return;
 246 }
 247
 248 #===== SUBROUTINE ===========================================================
 249 # Name      : cd()
 250 # Purpose   : wrapper around chdir
 251 # Parameters: $dir => path to chdir to
 252 # Returns   : n/a
 253 # Throws    : fatal error if the chdir fails
 254 # Comments  : none
 255 #============================================================================
 256 sub cd {
 257     my ($dir) = @_;
 258     chdir $dir or die "Failed to chdir($dir): $!\n";
 259 }
 260
 261 #===== SUBROUTINE ===========================================================
 262 # Name      : cat_file()
 263 # Purpose   : return file contents
 264 # Parameters: $file => file to read
 265 # Returns   : n/a
 266 # Throws    : fatal error if the open fails
 267 # Comments  : none
 268 #============================================================================
 269 sub cat_file {
 270     my ($file) = @_;
 271     open F, $file or die "Failed to open($file): $!\n";
 272     my $contents = join '', <F>;
 273     close(F);
 274     return $contents;
 275 }
 276
 277 #===== SUBROUTINE ===========================================================
 278 # Name      : is_link()
 279 # Purpose   : assert path is a symlink
 280 # Parameters: $path => path to check
 281 #           : $dest => target symlink should point to
 282 #============================================================================
 283 sub is_link {
 284     my ($path, $dest) = @_;
 285     ok(-l $path => "$path should be symlink");
 286     is(readlink $path, $dest => "$path symlinks to $dest");
 287 }
 288
 289 #===== SUBROUTINE ===========================================================
 290 # Name      : is_dir_not_symlink()
 291 # Purpose   : assert path is a directory not a symlink
 292 # Parameters: $path => path to check
 293 #============================================================================
 294 sub is_dir_not_symlink {
 295     my ($path) = @_;
 296     ok(! -l $path => "$path should not be symlink");
 297     ok(-d _       => "$path should be a directory");
 298 }
 299
 300 #===== SUBROUTINE ===========================================================
 301 # Name      : is_nonexistent_path()
 302 # Purpose   : assert path does not exist
 303 # Parameters: $path => path to check
 304 #============================================================================
 305 sub is_nonexistent_path {
 306     my ($path) = @_;
 307     ok(! -l $path => "$path should not be symlink");
 308     ok(! -e _     => "$path should not exist");
 309 }
 310
 311
 312 1;
 313
 314 # Local variables:
 315 # mode: perl
 316 # end:
 317 # vim: ft=perl