File Coverage

blib/lib/File/MultiTemp.pm

Criterion	Covered	Total	%
statement	76	76	100.0
branch	10	16	62.5
condition	4	9	44.4
subroutine	21	21	100.0
pod	5	6	83.3
total	116	128	90.6

package File::MultiTemp;

# ABSTRACT: manage a hash of temporary files

use v5.14;

use Moo;

use Fcntl qw/ LOCK_EX /;
use List::Util 1.29 qw/ pairs /;
use Path::Tiny qw/ path /;
use PerlX::Maybe qw/ maybe /;
use Scalar::Util qw/ openhandle /;
use Types::Common::String qw/ SimpleStr /;
use Types::Standard       qw/ Bool CodeRef FileHandle HashRef StrMatch /;
use Types::Path::Tiny     qw/ Dir File /;

# RECOMMEND PREREQ: Type::Tiny::XS

use namespace::autoclean;

our $VERSION = 'v0.1.5';


has template => (
    is        => 'ro',
    isa       => StrMatch[ qr/XXXX/ ],
    predicate => 1,
);


has suffix => (
    is        => 'ro',
    isa       => SimpleStr,
    predicate => 1,
);


has dir => (
    is        => 'ro',
    isa       => Dir,
    coerce    => \&path,
    predicate => 1,
);


has unlink => (
    is      => 'ro',
    isa     => Bool,
    default => 1,
);


has init => (
    is        => 'ro',
    isa       => CodeRef,
    predicate => 1,
);

has _files => (
    is      => 'ro',
    isa     => HashRef [ File ],
    builder => sub { return {} },
    init_arg => undef,
);

has _file_handles => (
    is      => 'ro',
    isa     => HashRef [ FileHandle ],
    builder => sub { return {} },
    init_arg => undef,
);

sub _get_tempfile_args {
    my ($self, $key ) = @_;

    my $template;

    if ( $self->has_template ) {
        $template = $self->template =~ s/KEY/${key}/r;
    }

    return (
        maybe TEMPLATE => $template,
        maybe SUFFIX   => $self->has_suffix ? $self->suffix : undef,
        maybe DIR      => $self->has_dir    ? $self->dir->stringify : undef,
              UNLINK   => $self->unlink,
    );

}

sub _get_open_file_handle {
    my ($self, $key, $file, $init) = @_;


   my $fhs = $self->_file_handles;
   if ( my $fh = openhandle( $fhs->{$key} ) ) {
       return $fh;
   }

   # get file only if we do not have it (otherwise recursion)
   $file //= $self->file( $key, $init );

   # filehandle is no longer be open, so overwrite it
   my $fh = ( $fhs->{$key} = $file->opena_raw( { locked => 0 } ) );

   # Path::Tiny locking does not seem to release locks properly, so we need to control locks manually
   flock( $fh, LOCK_EX );
   return $fh;
}


sub file {
    my ($self, $key, $init) = @_;

    my $files = $self->_files;

    if ( my $file = $files->{$key} ) {
        return $file;
    }

    my $file = $files->{$key} //= Path::Tiny->tempfile( $self->_get_tempfile_args($key) );
    my $fh   = $self->_get_open_file_handle( $key, $file, $init );
    if ( $init //= $self->init ) {
        $init->( $key, $file, $fh );
    }
    return $file;
}


sub file_handle {
    my ($self, $key, $init) = @_;
    return $self->_get_open_file_handle( $key, undef, $init );
}


sub keys {
    my ($self) = @_;
    my $files = $self->_files;
    return [ keys %{ $files } ];
}


sub files {
    my ($self) = @_;
    my $files = $self->_files;
    return [ values %{ $files } ];
}


sub close {
    my ($self) = @_;
    my $fhs = $self->_file_handles;
    for my $kv ( pairs %{ $fhs } ) {
        my ( $key, $fh ) = @{ $kv };
        close($fh) if $fh;
        delete $fhs->{$key};
    }
}

sub DEMOLISH {
    my ($self, $is_global) = @_;
    $self->close unless $is_global;
}


1;

__END__