Directory-Scratch-0.14/000075500000000000000000000000001143472721200147705ustar00rootroot00000000000000Directory-Scratch-0.14/.gitignore000064400000000000000000000001031143472721200167520ustar00rootroot00000000000000META.yml Makefile Directory-Scratch-* blib inc pm_to_blib cover_db Directory-Scratch-0.14/Changes000064400000000000000000000035111143472721200162630ustar00rootroot00000000000000Revision history for Directory-Scratch 0.14 8 June 2008 * remove auto_install and update Module::Install 0.13 19 October 2007 * add "chmod" and "stat" commands 0.12 25 January 2007 * fix non-hard-coded '/' for Win32 users CORRECTLY; it really works now, I promise! * add create_tree for quickly creating directory trees 0.11 27 December 2006 * add environment variable to suppress auto-cleanup * fix hard-coded '/' for Win32 users 0.10 9 December 2006 * up File::Slurp dependency to 9999.12, required for AS/Win32 * increase test coverage * fix bug where a platform argument to new() is ignored 0.09 14 Septemeber 2006 * decided to go back to File::Slurp * decided to croak if String::Random isn't installed * using Path::Class internally * added option to make UNIX paths Just Work on non-UNIX systems (perl has this already, but this converts to the right format internally, so that debugging messags make sense also) * actually works on Win32 now 0.08 3 September 2006 More cleanups: * clone => child * binmode * stringify doc fixes 0.06 22 August 2006 Applied a patch (#21120) from TOBEYA. API has changed a bit, but it's for the better. 0.05 7 August 2006 Removed some debugging code that shouldn't have been pushed to CPAN :) 0.04 7 August 2006 Added list, exists, read, write, append, and link; and lots more tests. 0.03 17 July 2006 Fixed an even sillier bug: touch(@lines) didn't work because the touch looked like my @lines, not my @lines = @_; !!! Added a test for this 0.02 3 July 2006 Fixed a silly bug: mkdir('a'); mkdir('a/b'); would fail because a already existed. 0.01 2 July 2006 First version, released on an unsuspecting world. Directory-Scratch-0.14/MANIFEST000064400000000000000000000023051143472721200161210ustar00rootroot00000000000000.gitignore Changes examples/basic.pl inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/PAR.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Directory/Scratch.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00-load.t t/developer/boilerplate.t t/developer/pod-coverage.t t/developer/pod.t t/integration/01-parents_too.t t/integration/01-scratch.t t/integration/02-nesting.t t/integration/03-list.t t/integration/04-links.t t/integration/05-readwrite.t t/integration/06-append-prepend.t t/integration/07-delete.t t/integration/08-exists.t t/integration/09-clone_object.t t/integration/10-new-with-arguments.t t/integration/11-cleanup.t t/integration/11-stringify.t t/integration/12-randfile.t t/integration/other_output_seperator.t t/os/mac.t t/os/win32.t t/unit/append.t t/unit/chmod.t t/unit/cleanup.t t/unit/create_tree.t t/unit/delete.t t/unit/invalid_clone.t t/unit/invalid_directory.t t/unit/link.t t/unit/ls.t t/unit/mkdir.t t/unit/openfile.t t/unit/randfile.t t/unit/read.t t/unit/stat.t t/unit/tempfile.t t/unit/touch.t t/unit/write.t Directory-Scratch-0.14/MANIFEST.SKIP000064400000000000000000000001231143472721200166620ustar00rootroot00000000000000.git/ blib pm_to_blib MANIFEST.bak MANIFEST.SKIP~ cover_db Makefile$ Makefile.old$ Directory-Scratch-0.14/Makefile.PL000064400000000000000000000007431143472721200167460ustar00rootroot00000000000000use strict; use warnings; use inc::Module::Install; name 'Directory-Scratch'; all_from 'lib/Directory/Scratch.pm'; requires 'File::Temp' => 0, 'File::Path' => 0, 'File::Slurp' => '9999.12', 'Path::Class' => 0, 'File::Copy' => 0, 'File::Spec' => 0, 'File::stat' => 0, # core 'Carp' => 0; build_requires 'Test::More' => 0; features 'String::Random for random files' => ['String::Random' => 0]; par_base 'JROCKWAY'; tests 't/*/*.t'; WriteAll; Directory-Scratch-0.14/README000064400000000000000000000020671143472721200156550ustar00rootroot00000000000000Directory-Scratch Directory::Scratch creates a scratch space for your application to (portably) manipulate files. Designed for testing File::* modules, but may be useful elsewhere. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install If make test fails, don't install the module. File a bug report instead. SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Directory::Scratch You can also look for information at: Search CPAN http://search.cpan.org/dist/Directory-Scratch CPAN Request Tracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Directory-Scratch AnnoCPAN, annotated CPAN documentation: http://annocpan.org/dist/Directory-Scratch CPAN Ratings: http://cpanratings.perl.org/d/Directory-Scratch COPYRIGHT AND LICENCE Copyright (C) 2006 Jonathan Rockway This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Directory-Scratch-0.14/examples/000075500000000000000000000000001143472721200166065ustar00rootroot00000000000000Directory-Scratch-0.14/examples/basic.pl000064400000000000000000000014171143472721200202270ustar00rootroot00000000000000#!/usr/bin/perl # basic.pl # Copyright (c) 2006 Jonathan Rockway use strict; use warnings; use Directory::Scratch; =pod Guided tour of Directory::Scratch. First, create a Directory::Scratch object =cut my $tmp = Directory::Scratch->new; =pod Then create a file. =cut print "Hello reader! Welcome to this Knuth-like journey!\n"; my $file = $tmp->touch('foo'); print "foo was created as $file\n"; =pod We dont't have to remember $file, we can get the full path later: =cut my $path = $tmp->exists('foo'); print "$file and $path are the same\n"; =pod C also checks for existence, of course. =cut print "No file called fake!\n" if(!$tmp->exists('fake')); =pod That's all for now. =cut print "Goodbye. I'm cleaning up $tmp for you!"; Directory-Scratch-0.14/lib/000075500000000000000000000000001143472721200155365ustar00rootroot00000000000000Directory-Scratch-0.14/lib/Directory/000075500000000000000000000000001143472721200175025ustar00rootroot00000000000000Directory-Scratch-0.14/lib/Directory/Scratch.pm000064400000000000000000000476761143472721200214530ustar00rootroot00000000000000package Directory::Scratch; # see POD after __END__. use warnings; use strict; use Carp; use File::Temp; use File::Copy; use Path::Class qw(dir file); use File::Slurp qw(read_file write_file); 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"; our $VERSION = '0.14'; # 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 = read_file($file->stringify); chomp @lines; return @lines; } else { my $scalar = read_file($file->stringify); 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'){ $args->{append} = 1; write_file($path->stringify, $args, map { $_. ($, || "\n") } @_) or croak "Error writing file: $!"; } else { # (cut'n'paste)++ write_file($path->stringify, map { $_. ($, || "\n") } @_) 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; $name = file($name); my $rand = String::Random->new(); write_file($fh, $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__ =head1 NAME Directory::Scratch - Easy-to-use self-cleaning scratch space. =head1 SYNOPSIS When writing test suites for modules that operate on files, it's often inconvenient to correctly create a platform-independent temporary storage space, manipulate files inside it, then clean it up when the test exits. The inconvenience usually results in tests that don't work everwhere, or worse, no tests at all. This module aims to eliminate that problem by making it easy to do things right. Example: use Directory::Scratch; my $temp = Directory::Scratch->new(); my $dir = $temp->mkdir('foo/bar'); my @lines= qw(This is a file with lots of lines); my $file = $temp->touch('foo/bar/baz', @lines); my $fh = openfile($file); print {$fh} "Here is another line.\n"; close $fh; $temp->delete('foo/bar/baz'); undef $temp; # everything else is removed # Directory::Scratch objects stringify to base $temp->touch('foo'); ok(-e "$temp/foo"); # /tmp/xYz837/foo should exist =head1 EXPORT The first argument to the module is optional, but if specified, it's interperted as the name of the OS whose file naming semantics you want to use with Directory::Scratch. For example, if you choose "Unix", then you can provide paths to Directory::Scratch in UNIX-form ('foo/bar/baz') on any platform. Unix is the default if you don't choose anything explicitly. If you want to use the local platform's flavor (not recommended), specify an empty import list: use Directory::Scratch ''; # use local path flavor Recognized platforms (from L): =over 4 =item Mac =item UNIX =item Win32 =item VMS =item OS2 =back The names are case sensitive, since they simply specify which C module to use when splitting the path. =head2 EXAMPLE use Directory::Scratch 'Win32'; my $tmp = Directory::Scratch->new(); $tmp->touch("foo\\bar\\baz"); # and so on =head1 METHODS The file arguments to these methods are always relative to the temporary directory. If you specify C, then a file called C will be created instead. This means that the program's PWD is ignored (for these methods), and that a leading C on the filename is meaningless (and will cause portability problems). Finally, whenever a filename or path is returned, it is a L object rather than a string containing the filename. Usually, this object will act just like the string, but to be extra-safe, call C<< $path->stringify >> to ensure that you're really getting a string. (Some clever modules try to determine whether a variable is a filename or a filehandle; these modules usually guess wrong when confronted with a C object.) =head2 new Creates a new temporary directory (via File::Temp and its defaults). When the object returned by this method goes out of scope, the directory and its contents are removed. my $temp = Directory::Scratch->new; my $another = $temp->new(); # will be under $temp # some File::Temp arguments get passed through (may be less portable) my $temp = Directory::Scratch->new( DIR => '/var/tmp', # be specific about where your files go CLEANUP => 0, # turn off automatic cleanup TEMPLATE => 'ScratchDirXXXX', # specify a template for the dirname ); If C, C, or C