File Coverage

blib/lib/Directory/Scratch.pm

Criterion	Covered	Total	%
statement	232	238	97.4
branch	82	104	78.8
condition	19	25	76.0
subroutine	36	37	97.3
pod	20	20	100.0
total	389	424	91.7

package Directory::Scratch; # git description: v0.17-3-ga9b3e32
$Directory::Scratch::VERSION = '0.18';
# see POD after __END__.

use warnings;
use strict;
use Carp;
use File::Temp;
use File::Copy;
use Path::Class qw(dir file);
use Path::Tiny 0.060;
use File::Spec;
use File::stat (); # no imports

my ($OUR_PLATFORM) = $File::Spec::ISA[0] =~ /::(\w+)$/;
my $PLATFORM = 'Unix';
use Scalar::Util qw(blessed);

use overload q{""} => \&base,
  fallback => "yes, fallback";

# allow the user to specify which OS's semantics he wants to use
# if platform is undef, then we won't do any translation at all
sub import {
    my $class = shift;
    return unless @_;
    $PLATFORM = shift;
    eval("require File::Spec::$PLATFORM");
    croak "Don't know how to deal with platform '$PLATFORM'" if $@;
    return $PLATFORM;
}

# create an instance
sub new {
    my $class = shift;
    my $self  = {};
    my %args;

    eval { %args = @_ };
    croak 'Invalid number of arguments to Directory::Scratch->new' if $@;
    my $platform = $PLATFORM;
    $platform = $args{platform} if defined $args{platform};

    # explicitly default CLEANUP to 1
    $args{CLEANUP} = 1 unless exists $args{CLEANUP};

    # don't clean up if environment variable is set
    $args{CLEANUP} = 0
    if(defined $ENV{PERL_DIRECTORYSCRATCH_CLEANUP} &&
       $ENV{PERL_DIRECTORYSCRATCH_CLEANUP} == 0);

    # TEMPLATE is a special case, since it's positional in File::Temp
    my @file_temp_args;

    # convert DIR from their format to a Path::Class
    $args{DIR} = Path::Class::foreign_dir($platform, $args{DIR}) if $args{DIR};

    # change our arg format to one that File::Temp::tempdir understands
    for(qw(CLEANUP DIR)){
	push @file_temp_args, ($_ => $args{$_}) if $args{$_};
    }

    # this is a positional argument, not a named argument
    unshift @file_temp_args, $args{TEMPLATE} if $args{TEMPLATE};

    # fix TEMPLATE to do what we mean; if TEMPLATE is set then TMPDIR
    # needs to be set also
    push @file_temp_args, (TMPDIR => 1) if($args{TEMPLATE} && !$args{DIR});

    # keep this around for C
    $self->{args} = \%args;

    # create the directory!
    my $base = dir(File::Temp::tempdir(@file_temp_args));
    croak "Couldn't create a tempdir: $!" unless -d $base;
    $self->{base} = $base;

    bless $self, $class;
    $self->platform($platform); # set platform for this instance
    return $self;
}

sub child {
    my $self = shift;
    my %args;

    croak 'Invalid reference passed to Directory::Scratch->child'
      if !blessed $self || !$self->isa(__PACKAGE__);

    # copy args from parent object
    %args = %{$self->{_args}} if exists $self->{_args};

    # force the directory end up as a child of the parent, though
    $args{DIR} = $self->base->stringify;

    return Directory::Scratch->new(%args);
}

sub base {
    my $self = shift;
    return $self->{base};#->stringify;
}

sub platform {
    my $self = shift;
    my $desired = shift;

    if($desired){
	eval "require File::Spec::$desired";
	croak "Unknown platform '$desired'" if $@;
	$self->{platform} = $desired;
    }

    return $self->{platform};
}

# make Path::Class's foreign_* respect the instance's desired platform
sub _foreign_file {
    my $self = shift;
    my $platform = $self->platform;

    if($platform){
	my $file = Path::Class::foreign_file($platform, @_);
	return $file->as_foreign($OUR_PLATFORM);
    }
    else {
	return Path::Class::file(@_);
    }
}

sub _foreign_dir {
    my $self = shift;
    my $platform = $self->platform;

    if($platform){
	my $dir = Path::Class::foreign_dir($platform, @_);
	return $dir->as_foreign($OUR_PLATFORM);
    }
    else {
	return Path::Class::dir(@_);
    }
}

sub exists {
    my $self = shift;
    my $file = shift;
    my $base = $self->base;
    my $path = $self->_foreign_file($base, $file);
    return dir($path) if -d $path;
    return $path if -e $path;
    return; # undef otherwise
}

sub stat {
    my $self = shift;
    my $file = shift;
    my $path = $self->_foreign_file($self->base, $file);

    if(wantarray){
        return stat $path; # core stat, returns a list
    }

    return File::stat::stat($path); # returns an object
}

sub mkdir {
    my $self = shift;
    my $dir  = shift;
    my $base = $self->base;
    $dir = $self->_foreign_dir($base, $dir);
    $dir->mkpath;
    return $dir if (-e $dir && -d $dir);
    croak "Error creating $dir: $!";
}

sub link {
    my $self = shift;
    my $from = shift;
    my $to   = shift;
    my $base = $self->base;

    croak "Symlinks are not supported on MSWin32"
      if $^O eq 'MSWin32';

    $from = $self->_foreign_file($base, $from);
    $to   = $self->_foreign_file($base, $to);

    symlink($from, $to)
      or croak "Couldn't link $from to $to: $!";

    return $to;
}

sub chmod {
    my $self  = shift;
    my $mode  = shift;
    my @paths = @_;

    my @translated = map { $self->_foreign_file($self->base, $_) } @paths;
    return chmod $mode, @translated;
}

sub read {
    my $self = shift;
    my $file = shift;
    my $base = $self->base;

    $file = $self->_foreign_file($base, $file);

    croak "Cannot read $file: is a directory" if -d $file;

    if(wantarray){
	my @lines = path($file->stringify)->lines;
	chomp @lines;
	return @lines;
    }
    else {
	my $scalar = path($file->stringify)->slurp;
	chomp $scalar;
	return $scalar;
    }
}

sub write {
    my $self = shift;
    my $file = shift;
    my $base = $self->base;

    my $path = $self->_foreign_file($base, $file);
    $path->parent->mkpath;
    croak "Couldn't create parent dir ". $path->parent. ": $!"
      unless -e $path->parent;

    # figure out if we're "write" or "append"
    my (undef, undef, undef, $method) = caller(1);

    my $args;
    if(defined $method && $method eq 'Directory::Scratch::append'){
	local $, = $, || "\n";
	path($path->stringify)->append(@_, '')
	  or croak "Error writing file: $!";
    }
    else { # (cut'n'paste)++
	local $, = $, || "\n";
	path($path->stringify)->append({ truncate => 1 }, @_, '')
	  or croak "Error writing file: $!";
    }
    return 1;
}

sub append {
    return &write(@_); # magic!
}

sub tempfile {
    my $self = shift;
    my $path = shift;

    if(!defined $path){
	$path = $self->base;
    }
    else {
	$path = $self->_foreign_dir($self->base, $path);
    }

    my ($fh, $filename) =  File::Temp::tempfile( DIR => $path );
    $filename = file($filename); # "class"ify the file
    if(wantarray){
	return ($fh, $filename);
    }

    # XXX: I don't know why you would want to do this...
    return $fh;
}

sub openfile {
    my $self = shift;
    my $file = shift;
    my $base = $self->base;

    my $path = $self->_foreign_file($base, $file);
    $path->dir->mkpath;
    croak 'Parent directory '. $path->dir.
      ' does not exist, and could not be created'
	unless -d $path->dir;
    open(my $fh, '+>', $path) or croak "Failed to open $path: $!";
    return ($fh, $path) if(wantarray);
    return $fh;
}

sub touch {
    my $self = shift;
    my $file = shift;
    my ($fh, $path) = $self->openfile($file);

    $self->write($file, @_) || croak 'failed to write file: $!';
    return $path;
}


sub ls {
    my $self = shift;
    my $dir = shift;
    my $base = $self->base;
    my $path = dir($base);
    my @result;

    if($dir){
	$dir = $self->_foreign_dir($dir);
	$path = $self->exists($dir);
	croak "No path `$dir' in temporary directory"  if !$path;

	return (file($dir)) if !-d $path;
	$path = dir($base, $dir);
    }

    $path->recurse( callback =>
		    sub {
			my $file = shift;
			return if $file eq $path;

			push @result, $file->relative($base);
		    }
		  );

    return @result;
}

sub create_tree {
    my $self = shift;
    my %tree = %{shift()||{}};

    foreach my $element (keys %tree){
	my $value = $tree{$element};
	if('SCALAR' eq ref $value){
	    $self->mkdir($element);
	}
	else {
	    my @lines = ($value);
	    @lines = @$value if 'ARRAY' eq ref $value;
	    $self->touch($element, @lines);
	}
    }
}

sub delete {
    my $self = shift;
    my $path = shift;
    my $base = $self->base;

    $path = $self->_foreign_file($base, $path);

    croak "No such file or directory '$path'" if !-e $path;

    if(-d _){ # reuse stat() from -e test
	return (scalar rmdir $path or croak "Couldn't remove directory $path: $!");
    }
    else {
	return (scalar unlink $path or croak "Couldn't unlink $path: $!");
    }

}

sub cleanup {
    my $self = shift;
    my $base = $self->base;

    # capture warnings
    my @errors;
    local $SIG{__WARN__} = sub {
        push @errors, @_;
    };

    File::Path::rmtree( $base->stringify );

    if ( @errors > 0 ) {
        croak "cleanup() method failed: $!\n@errors";
    }

    $self->{args}->{CLEANUP} = 1; # it happened, so update this
    return 1;
}

sub randfile {
    my $self = shift;

    # make sure we can do this
    eval {
	require String::Random;
    };
    croak 'randfile: String::Random is required' if $@;

    # setup some defaults
    my( $min, $max ) = ( 1024, 131072 );

    if ( @_ == 2 ) {
	($min, $max) = @_;
    }
    elsif ( @_ == 1 ) {
        $max = $_[0];
        $min = int(rand($max)) if ( $min > $max );
    }
    confess "randfile: Cannot request a maximum length < 1"
      if ( $max < 1 );

    my ($fh, $name) = $self->tempfile;
    croak "Could not open $name: $!" if !$fh;
    close $fh;

    my $rand = String::Random->new();
    path($name)->append({ truncate => 1 }, $rand->randregex(".{$min,$max}"));

    return file($name);
}

# throw a warning if CLEANUP is off and cleanup hasn't been called
sub DESTROY {
    my $self = shift;
    carp "Warning: not cleaning up files in ". $self->base
      if !$self->{args}->{CLEANUP};
}

1;

__END__