stow/t/testutil.pm

#!/usr/bin/perl

#
# Utilities shared by test scripts
#

use strict;
use warnings;

use Stow;
use Stow::Util qw(parent);

sub make_fresh_stow_and_target_dirs {
    die "t/ didn't exist; are you running the tests from the root of the tree?\n"
        unless -d 't';

    for my $dir ('t/target', 't/stow') {
        eval { remove_dir($dir); };
        make_dir($dir);
    }
}

sub new_Stow {
    my %opts = @_;
    $opts{dir}    ||= '../stow';
    $opts{target} ||= '.';
    $opts{test_mode} = 1;
    return new Stow(%opts);
}

sub new_compat_Stow {
    my %opts = @_;
    $opts{compat} = 1;
    return new_Stow(%opts);
}

#===== SUBROUTINE ===========================================================
# Name      : make_link()
# Purpose   : safely create a link
# Parameters: $target => path to the link
#           : $source => where the new link should point
# Returns   : n/a
# Throws    : fatal error if the link can not be safely created
# Comments  : checks for existing nodes
#============================================================================
sub make_link {
    my ($target, $source) = @_;

    if (-l $target) {
        my $old_source = readlink join('/', parent($target), $source) 
            or die "could not read link $target/$source";
        if ($old_source ne $source) {
            die "$target already exists but points elsewhere\n";
        }
    }
    elsif (-e $target) {
        die "$target already exists and is not a link\n";
    }
    else {
        symlink $source, $target
            or die "could not create link $target => $source ($!)\n";
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : make_dir()
# Purpose   : create a directory and any requisite parents
# Parameters: $dir => path to the new directory
# Returns   : n/a
# Throws    : fatal error if the directory or any of its parents cannot be
#           : created
# Comments  : none
#============================================================================
sub make_dir {
    my ($dir) = @_;

    my @parents = ();
    for my $part (split '/', $dir) {
        my $path = join '/', @parents, $part;
        if (not -d $path and not mkdir $path) {
            die "could not create directory: $path ($!)\n";
        }
        push @parents, $part;
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : create_file()
# Purpose   : create an empty file
# Parameters: $path => proposed path to the file
# Returns   : n/a
# Throws    : fatal error if the file could not be created
# Comments  : detects clash with an existing non-file
#============================================================================
sub make_file {
    my ($path) =@_;

    if (not -e $path) {
        open my $FILE ,'>', $path
            or die "could not create file: $path ($!)\n";
        close $FILE;
    }
    elsif (not -f $path) {
        die "a non-file already exists at $path\n";
    }
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : remove_link()
# Purpose   : remove an esiting symbolic link
# Parameters: $path => path to the symbolic link
# Returns   : n/a
# Throws    : fatal error if the operation fails or if passed the path to a
#           : non-link
# Comments  : none
#============================================================================
sub remove_link {
    my ($path) = @_;
    if (not -l $path) {
        die qq(remove_link() called with a non-link: $path);
    }
    unlink $path or die "could not remove link: $path ($!)\n";
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : remove_file()
# Purpose   : remove an existing empty file
# Parameters: $path => the path to the empty file
# Returns   : n/a
# Throws    : fatal error if given file is non-empty or the operation fails
# Comments  : none
#============================================================================
sub remove_file {
    my ($path) = @_;
    if (-z $path) {
        die "file at $path is non-empty\n";
    }
    unlink $path or die "could not remove empty file: $path ($!)\n";
    return;
}

#===== SUBROUTINE ===========================================================
# Name      : remove_dir()
# Purpose   : safely remove a tree of test files
# Parameters: $dir => path to the top of the tree
# Returns   : n/a
# Throws    : fatal error if the tree contains a non-link or non-empty file
# Comments  : recursively removes directories containing softlinks empty files
#============================================================================
sub remove_dir {
    my ($dir) = @_;

    if (not -d $dir) {
        die "$dir is not a directory";
    }

    opendir my $DIR, $dir or die "cannot read directory: $dir ($!)\n";
    my @listing = readdir $DIR;
    closedir $DIR;

    NODE:
    for my $node (@listing) {
        next NODE if $node eq '.';
        next NODE if $node eq '..';

        my $path = "$dir/$node";
        if (-l $path or -z $path) {
            unlink $path or die "cannot unlink $path ($!)\n";
        }
        elsif (-d "$path") {
            remove_dir($path);
        }
        else {
            die "$path is not a link, directory, or empty file\n";
        }
    }
    rmdir $dir or die "cannot rmdir $dir ($!)\n";

    return;
}

#===== SUBROUTINE ===========================================================
# Name      : cd()
# Purpose   : wrapper around chdir
# Parameters: $dir => path to chdir to
# Returns   : n/a
# Throws    : fatal error if the chdir fails
# Comments  : none
#============================================================================
sub cd {
    my ($dir) = @_;
    chdir $dir or die "Failed to chdir($dir): $!\n";
}

1;

# Local variables:
# mode: perl
# cperl-indent-level: 4
# end:
# vim: ft=perl