File Coverage

blib/lib/File/Util/Test.pm

Criterion	Covered	Total	%
statement	290	302	96.0
branch	224	278	80.5
condition	124	135	91.8
subroutine	35	35	100.0
pod	30	30	100.0
total	703	780	90.1

## no critic: Subroutines::ProhibitExplicitReturnUndef
package File::Util::Test;

use 5.010001;
use strict;
use warnings;

use Cwd ();
use Exporter 'import';

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-07-17'; # DATE
our $DIST = 'File-Util-Test'; # DIST
our $VERSION = '0.632'; # VERSION

our @EXPORT_OK = qw(
                       file_exists
                       l_abs_path
                       dir_empty
                       dir_not_empty
                       dir_has_entries
                       dir_has_files
                       dir_has_dot_files
                       dir_has_non_dot_files
                       dir_has_subdirs
                       dir_has_non_subdirs
                       dir_has_dot_subdirs
                       dir_has_non_dot_subdirs
                       dir_only_has_files
                       dir_only_has_dot_files
                       dir_only_has_non_dot_files
                       dir_only_has_subdirs
                       dir_only_has_dot_subdirs
                       dir_only_has_non_dot_subdirs

                       get_dir_entries
                       get_dir_dot_entries
                       get_dir_subdirs
                       get_dir_non_subdirs
                       get_dir_dot_subdirs
                       get_dir_non_dot_subdirs
                       get_dir_files
                       get_dir_dot_files
                       get_dir_non_dot_files
                       get_dir_only_file
                       get_dir_only_subdir
                       get_dir_only_symlink
               );

our %SPEC;

sub file_exists {
    my $path = shift;

    !(-l $path) && (-e _) || (-l _);
}

sub l_abs_path {
    my $path = shift;
    return Cwd::abs_path($path) unless (-l $path);

    $path =~ s!/\z!!;
    my ($parent, $leaf);
    if ($path =~ m!(.+)/(.+)!s) {
        $parent = Cwd::abs_path($1);
        return undef unless defined($path);
        $leaf   = $2;
    } else {
        $parent = Cwd::getcwd();
        $leaf   = $path;
    }
    "$parent/$leaf";
}

sub dir_empty {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0;
    }
    1;
}

sub dir_not_empty {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 1;
    }
    0;
}

sub dir_has_entries { goto \&dir_not_empty }

sub dir_has_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next unless -f "$dir/$e";
        return 1;
    }
    0;
}

sub dir_only_has_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_files;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 unless -f "$dir/$e";
        $has_files++;
    }
    $has_files ? 1:0;
}

sub dir_has_dot_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next unless $e =~ /\A\./;
        next unless -f "$dir/$e";
        return 1;
    }
    0;
}

sub dir_only_has_dot_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_dot_files;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 unless $e =~ /\A\./;
        return 0 unless -f "$dir/$e";
        $has_dot_files++;
    }
    $has_dot_files ? 1:0;
}

sub dir_has_non_dot_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next if $e =~ /\A\./;
        next unless -f "$dir/$e";
        return 1;
    }
    0;
}

sub dir_only_has_non_dot_files {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_nondot_files;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 if $e =~ /\A\./;
        return 0 unless -f "$dir/$e";
        $has_nondot_files++;
    }
    $has_nondot_files ? 1:0;
}

sub dir_has_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next if -l "$dir/$e";
        next unless -d _;
        return 1;
    }
    0;
}

sub dir_only_has_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_subdirs;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 unless -d "$dir/$e";
        $has_subdirs++;
    }
    $has_subdirs ? 1:0;
}

sub dir_has_non_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 1 if -l "$dir/$e";
        return 1 if !(-d _);
    }
    0;
}

sub dir_has_dot_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next unless $e =~ /\A\./;
        next if -l "$dir/$e";
        next unless -d _;
        return 1;
    }
    0;
}

sub dir_only_has_dot_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_dot_subdirs;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 unless $e =~ /\A\./;
        return 0 unless -d "$dir/$e";
        $has_dot_subdirs++;
    }
    $has_dot_subdirs ? 1:0;
}

sub dir_has_non_dot_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        next if $e =~ /\A\./;
        next if -l "$dir/$e";
        next unless -d _;
        return 1;
    }
    0;
}

sub dir_only_has_non_dot_subdirs {
    my ($dir) = @_;
    return undef unless (-d $dir);
    return undef unless opendir my($dh), $dir;
    my $has_nondot_subdirs;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        return 0 if $e =~ /\A\./;
        return 0 unless -d "$dir/$e";
        $has_nondot_subdirs++;
    }
    $has_nondot_subdirs ? 1:0;
}

sub get_dir_entries {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_dot_entries {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && /\A\./ } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_files {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && (-f "$dir/$_")} readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_dot_files {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && /\A\./ && (-f "$dir/$_")} readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_non_dot_files {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && !/\A\./ && (-f "$dir/$_")} readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_subdirs {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && !(-l "$dir/$_") && (-d _) } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_non_subdirs {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && ((-l "$dir/$_") || !(-d _)) } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_dot_subdirs {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && /\A\./ && !(-l "$dir/$_") && (-d _) } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_non_dot_subdirs {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my @res = grep { $_ ne '.' && $_ ne '..' && !/\A\./ && !(-l "$dir/$_") && (-d _) } readdir $dh;
    closedir $dh; # we're so nice
    @res;
}

sub get_dir_only_file {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    my $opt_ignore_dir = delete $opts->{ignore_dir};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my $res;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        my @st = stat "$dir/$e";
        next if -d _ && $opt_ignore_dir;
        return unless -f _;
        return if defined $res;
        $res = $e;
    }
    return unless defined $res;
    $res;
}

sub get_dir_only_subdir {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    my $opt_ignore_file = delete $opts->{ignore_file};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my $res;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        my @st = stat "$dir/$e";
        next if -f _ && $opt_ignore_file;
        return unless -d _;
        return if defined $res;
        $res = $e;
    }
    return unless defined $res;
    $res;
}

sub get_dir_only_symlink {
    my $opts = ref $_[0] eq 'HASH' ? {%{shift()}} : {};
    die "Unknown option(s): ".join(", ", keys %$opts) if keys %$opts;

    my ($dir) = @_;
    $dir //= ".";

    opendir my($dh), $dir or die "Can't opendir $dir: $!";
    my $res;
    while (defined(my $e = readdir $dh)) {
        next if $e eq '.' || $e eq '..';
        my @st = lstat "$dir/$e";
        return unless -l _;
        return if defined $res;
        $res = $e;
    }
    return unless defined $res;
    $res;
}

1;
# ABSTRACT: Utilities related mostly to testing/checking for files in directories

__END__