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(confess croak);
  28 use File::Basename;
  29 use File::Path qw(make_path remove_tree);
  30 use File::Spec;
  31 use Test::More;
  32
  33 use Stow;
  34 use Stow::Util qw(parent canon_path join_paths);
  35
  36 use base qw(Exporter);
  37 our @EXPORT = qw(
  38     $ABS_TEST_DIR
  39     $TEST_DIR
  40     init_test_dirs
  41     cd
  42     new_Stow new_compat_Stow
  43     make_path make_link make_invalid_link make_file
  44     setup_global_ignore setup_package_ignore
  45     remove_dir remove_file remove_link
  46     cat_file
  47     is_link is_dir_not_symlink is_nonexistent_path
  48 );
  49
  50 our $TEST_DIR = 'tmp-testing-trees';
  51 our $ABS_TEST_DIR = File::Spec->rel2abs('tmp-testing-trees');
  52
  53 sub init_test_dirs {
  54     my $test_dir = shift || $TEST_DIR;
  55     my $abs_test_dir = File::Spec->rel2abs($test_dir);
  56
  57     # Create a run_from/ subdirectory for tests which want to run
  58     # from a separate directory outside the Stow directory or
  59     # target directory.
  60     for my $dir ("target", "stow", "run_from", "stow directory") {
  61         my $path = "$test_dir/$dir";
  62         -d $path and remove_tree($path);
  63         make_path($path);
  64     }
  65
  66     # Don't let user's ~/.stow-global-ignore affect test results
  67     $ENV{HOME} = $abs_test_dir;
  68     return $abs_test_dir;
  69 }
  70
  71 sub new_Stow {
  72     my %opts = @_;
  73     # These default paths assume that execution will be triggered from
  74     # within the target directory.
  75     $opts{dir}    ||= '../stow';
  76     $opts{target} ||= '.';
  77     $opts{test_mode} = 1;
  78     my $stow = eval { new Stow(%opts) };
  79     if ($@) {
  80         confess "Error while trying to instantiate new Stow(%opts): $@";
  81     }
  82     return $stow;
  83 }
  84
  85 sub new_compat_Stow {
  86     my %opts = @_;
  87     $opts{compat} = 1;
  88     return new_Stow(%opts);
  89 }
  90
  91 #===== SUBROUTINE ===========================================================
  92 # Name      : make_link()
  93 # Purpose   : safely create a link
  94 # Parameters: $link_src => path to the link
  95 #           : $link_dest => where the new link should point
  96 #           : $invalid => true iff $link_dest refers to non-existent file
  97 # Returns   : n/a
  98 # Throws    : fatal error if the link can not be safely created
  99 # Comments  : checks for existing nodes
 100 #============================================================================
 101 sub make_link {
 102     my ($link_src, $link_dest, $invalid) = @_;
 103
 104     if (-l $link_src) {
 105         my $old_source = readlink join('/', parent($link_src), $link_dest)
 106             or croak "$link_src is already a link but could not read link $link_src/$link_dest";
 107         if ($old_source ne $link_dest) {
 108             croak "$link_src already exists but points elsewhere\n";
 109         }
 110     }
 111     croak "$link_src already exists and is not a link\n" if -e $link_src;
 112     my $abs_target = File::Spec->rel2abs($link_src);
 113     my $link_src_container = dirname($abs_target);
 114     my $abs_source = File::Spec->rel2abs($link_dest, $link_src_container);
 115     #warn "t $link_src c $link_src_container as $abs_source";
 116     if (-e $abs_source) {
 117         croak "Won't make invalid link pointing to existing $abs_target"
 118             if $invalid;
 119     }
 120     else {
 121         croak "Won't make link pointing to non-existent $abs_target"
 122             unless $invalid;
 123     }
 124     symlink $link_dest, $link_src
 125         or croak "could not create link $link_src => $link_dest ($!)\n";
 126 }
 127
 128 #===== SUBROUTINE ===========================================================
 129 # Name      : make_invalid_link()
 130 # Purpose   : safely create an invalid link
 131 # Parameters: $target => path to the link
 132 #           : $source => the non-existent source where the new link should point
 133 # Returns   : n/a
 134 # Throws    : fatal error if the link can not be safely created
 135 # Comments  : checks for existing nodes
 136 #============================================================================
 137 sub make_invalid_link {
 138     my ($target, $source, $allow_invalid) = @_;
 139     make_link($target, $source, 1);
 140 }
 141
 142 #===== SUBROUTINE ===========================================================
 143 # Name      : create_file()
 144 # Purpose   : create an empty file
 145 # Parameters: $path => proposed path to the file
 146 #           : $contents => (optional) contents to write to file
 147 # Returns   : n/a
 148 # Throws    : fatal error if the file could not be created
 149 # Comments  : detects clash with an existing non-file
 150 #============================================================================
 151 sub make_file {
 152     my ($path, $contents) = @_;
 153
 154     if (-e $path and ! -f $path) {
 155         croak "a non-file already exists at $path\n";
 156     }
 157
 158     open my $FILE ,'>', $path
 159         or croak "could not create file: $path ($!)\n";
 160     print $FILE $contents if defined $contents;
 161     close $FILE;
 162 }
 163
 164 sub setup_global_ignore {
 165     my ($contents) = @_;
 166     my $global_ignore_file = join_paths($ENV{HOME}, $Stow::GLOBAL_IGNORE_FILE);
 167     make_file($global_ignore_file, $contents);
 168     return $global_ignore_file;
 169 }
 170
 171 sub setup_package_ignore {
 172     my ($package_path, $contents) = @_;
 173     my $package_ignore_file = join_paths($package_path, $Stow::LOCAL_IGNORE_FILE);
 174     make_file($package_ignore_file, $contents);
 175     return $package_ignore_file;
 176 }
 177
 178 #===== SUBROUTINE ===========================================================
 179 # Name      : remove_link()
 180 # Purpose   : remove an esiting symbolic link
 181 # Parameters: $path => path to the symbolic link
 182 # Returns   : n/a
 183 # Throws    : fatal error if the operation fails or if passed the path to a
 184 #           : non-link
 185 # Comments  : none
 186 #============================================================================
 187 sub remove_link {
 188     my ($path) = @_;
 189     if (not -l $path) {
 190         croak qq(remove_link() called with a non-link: $path);
 191     }
 192     unlink $path or croak "could not remove link: $path ($!)\n";
 193     return;
 194 }
 195
 196 #===== SUBROUTINE ===========================================================
 197 # Name      : remove_file()
 198 # Purpose   : remove an existing empty file
 199 # Parameters: $path => the path to the empty file
 200 # Returns   : n/a
 201 # Throws    : fatal error if given file is non-empty or the operation fails
 202 # Comments  : none
 203 #============================================================================
 204 sub remove_file {
 205     my ($path) = @_;
 206     if (-z $path) {
 207         croak "file at $path is non-empty\n";
 208     }
 209     unlink $path or croak "could not remove empty file: $path ($!)\n";
 210     return;
 211 }
 212
 213 #===== SUBROUTINE ===========================================================
 214 # Name      : remove_dir()
 215 # Purpose   : safely remove a tree of test files
 216 # Parameters: $dir => path to the top of the tree
 217 # Returns   : n/a
 218 # Throws    : fatal error if the tree contains a non-link or non-empty file
 219 # Comments  : recursively removes directories containing softlinks empty files
 220 #============================================================================
 221 sub remove_dir {
 222     my ($dir) = @_;
 223
 224     if (not -d $dir) {
 225         croak "$dir is not a directory";
 226     }
 227
 228     opendir my $DIR, $dir or croak "cannot read directory: $dir ($!)\n";
 229     my @listing = readdir $DIR;
 230     closedir $DIR;
 231
 232     NODE:
 233     for my $node (@listing) {
 234         next NODE if $node eq '.';
 235         next NODE if $node eq '..';
 236
 237         my $path = "$dir/$node";
 238         if (-l $path or (-f $path and -z $path) or $node eq $Stow::LOCAL_IGNORE_FILE) {
 239             unlink $path or croak "cannot unlink $path ($!)\n";
 240         }
 241         elsif (-d "$path") {
 242             remove_dir($path);
 243         }
 244         else {
 245             croak "$path is not a link, directory, or empty file\n";
 246         }
 247     }
 248     rmdir $dir or croak "cannot rmdir $dir ($!)\n";
 249
 250     return;
 251 }
 252
 253 #===== SUBROUTINE ===========================================================
 254 # Name      : cd()
 255 # Purpose   : wrapper around chdir
 256 # Parameters: $dir => path to chdir to
 257 # Returns   : n/a
 258 # Throws    : fatal error if the chdir fails
 259 # Comments  : none
 260 #============================================================================
 261 sub cd {
 262     my ($dir) = @_;
 263     chdir $dir or croak "Failed to chdir($dir): $!\n";
 264 }
 265
 266 #===== SUBROUTINE ===========================================================
 267 # Name      : cat_file()
 268 # Purpose   : return file contents
 269 # Parameters: $file => file to read
 270 # Returns   : n/a
 271 # Throws    : fatal error if the open fails
 272 # Comments  : none
 273 #============================================================================
 274 sub cat_file {
 275     my ($file) = @_;
 276     open F, $file or croak "Failed to open($file): $!\n";
 277     my $contents = join '', <F>;
 278     close(F);
 279     return $contents;
 280 }
 281
 282 #===== SUBROUTINE ===========================================================
 283 # Name      : is_link()
 284 # Purpose   : assert path is a symlink
 285 # Parameters: $path => path to check
 286 #           : $dest => target symlink should point to
 287 #============================================================================
 288 sub is_link {
 289     my ($path, $dest) = @_;
 290     ok(-l $path => "$path should be symlink");
 291     is(readlink $path, $dest => "$path symlinks to $dest");
 292 }
 293
 294 #===== SUBROUTINE ===========================================================
 295 # Name      : is_dir_not_symlink()
 296 # Purpose   : assert path is a directory not a symlink
 297 # Parameters: $path => path to check
 298 #============================================================================
 299 sub is_dir_not_symlink {
 300     my ($path) = @_;
 301     ok(! -l $path => "$path should not be symlink");
 302     ok(-d _       => "$path should be a directory");
 303 }
 304
 305 #===== SUBROUTINE ===========================================================
 306 # Name      : is_nonexistent_path()
 307 # Purpose   : assert path does not exist
 308 # Parameters: $path => path to check
 309 #============================================================================
 310 sub is_nonexistent_path {
 311     my ($path) = @_;
 312     ok(! -l $path => "$path should not be symlink");
 313     ok(! -e _     => "$path should not exist");
 314 }
 315
 316
 317 1;
 318
 319 # Local variables:
 320 # mode: perl
 321 # end:
 322 # vim: ft=perl