File Coverage

blib/lib/Test2/Harness/Util.pm

Criterion	Covered	Total	%
statement	65	66	98.4
branch	20	26	76.9
condition	8	12	66.6
subroutine	15	15	100.0
pod	0	9	0.0
total	108	128	84.3

package Test2::Harness::Util;
use strict;
use warnings;

our $VERSION = '0.001007';

use Carp qw/confess/;
use Importer Importer => 'import';

use Test2::Util qw/try_sig_mask do_rename/;

our @EXPORT_OK = qw{
    close_file
    fqmod
    local_env
    maybe_open_file
    maybe_read_file
    open_file
    read_file
    write_file
    write_file_atomic
};

sub fqmod {
    my ($prefix, $input) = @_;
    return $1 if $input =~ m/^\+(.*)$/;
    return "$prefix\::$input";
}

sub maybe_read_file {
    my ($file) = @_;
    return undef unless -f $file;
    return read_file($file);
}

sub read_file {
    my ($file) = @_;

    my $fh = open_file($file);
    local $/;
    my $out = <$fh>;
    close_file($fh, $file);

    return $out;
}

sub write_file {
    my ($file, @content) = @_;

    my $fh = open_file($file, '>');
    print $fh @content;
    close_file($fh, $file);

    return @content;
};

sub open_file {
    my ($file, $mode) = @_;
    $mode ||= '<';

    open(my $fh, $mode, $file) or confess "Could not open file '$file' ($mode): $!";
    return $fh;
}

sub maybe_open_file {
    my ($file, $mode) = @_;
    return undef unless -f $file;
    return open_file($file, $mode);
}

sub close_file {
    my ($fh, $name) = @_;
    return if close($fh);
    confess "Could not close file: $!" unless $name;
    confess "Could not close file '$name': $!";
}

sub write_file_atomic {
    my ($file, @content) = @_;

    my $pend = "$file.pend";

    my ($ok, $err) = try_sig_mask {
        write_file($pend, @content);
        my ($ren_ok, $ren_err) = do_rename($pend, $file);
        die $ren_err unless $ren_ok;
    };

    die $err unless $ok;

    return @content;
}

sub local_env {
    my ($env, $sub) = @_;

    my $old;
    for my $key (keys %$env) {
        $old->{$key} = $ENV{$key} if exists $ENV{$key};
        $ENV{$key} = $env->{$key};
    }

    my $ok = eval { $sub->(); 1 };
    my $err = $@;

    for my $key (keys %$env) {
        # If something set an env var inside than we do not want to squash it.
        next if !defined($ENV{$key}) xor !defined($env->{$key});
        next if defined($ENV{$key}) && defined($env->{$key}) && $ENV{$key} ne $env->{$key};

        exists $old->{$key} ? $ENV{$key} = $old->{$key} : delete $ENV{$key};
    }

    die $err unless $ok;

    return $ok;
}

1;

__END__