Directory-Scratch-0.15/000755 000765 000024 00000000000 12132354364 014636 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/.gitignore000644 000765 000024 00000000147 12132354332 016623 0ustar00t0mstaff000000 000000 META.yml Makefile Directory-Scratch-* blib inc pm_to_blib cover_db MANIFEST.bak MYMETA.json MYMETA.yml Directory-Scratch-0.15/Changes000644 000765 000024 00000003630 12132354332 016126 0ustar00t0mstaff000000 000000 Revision history for Directory-Scratch 0.15 13 April 2013 * Remove test for Classic Mac, fixing RT#83318 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.15/examples/000755 000765 000024 00000000000 12132354364 016454 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/inc/000755 000765 000024 00000000000 12132354364 015407 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/lib/000755 000765 000024 00000000000 12132354364 015404 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/Makefile.PL000644 000765 000024 00000001067 12132354012 016602 0ustar00t0mstaff000000 000000 use 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]; authority 'JROCKWAY'; resources( repository => 'git://github.com/bobtfish/directory-scratch.git', ); tests 't/*/*.t'; WriteAll; Directory-Scratch-0.15/MANIFEST000644 000765 000024 00000002300 12132354332 015755 0ustar00t0mstaff000000 000000 .gitignore Changes examples/basic.pl inc/Module/Install.pm inc/Module/Install/Authority.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/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/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.15/MANIFEST.SKIP000644 000765 000024 00000000160 12132354332 016524 0ustar00t0mstaff000000 000000 Directory-Scratch-* MYMETA.* .git/ blib pm_to_blib MANIFEST.bak MANIFEST.SKIP~ cover_db Makefile$ Makefile.old$ Directory-Scratch-0.15/META.yml000644 000765 000024 00000001414 12132354340 016101 0ustar00t0mstaff000000 000000 --- abstract: 'Easy-to-use self-cleaning scratch space.' author: - 'Jonathan Rockway, all rights reserved.' build_requires: ExtUtils::MakeMaker: 6.36 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.36 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Directory-Scratch no_index: directory: - examples - inc - t requires: Carp: 0 File::Copy: 0 File::Path: 0 File::Slurp: 9999.12 File::Spec: 0 File::Temp: 0 File::stat: 0 Path::Class: 0 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/bobtfish/directory-scratch.git version: 0.15 x_authority: JROCKWAY Directory-Scratch-0.15/README000644 000765 000024 00000002067 12132353454 015522 0ustar00t0mstaff000000 000000 Directory-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.15/t/000755 000765 000024 00000000000 12132354364 015101 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/t/00-load.t000644 000765 000024 00000000244 12132353454 016421 0ustar00t0mstaff000000 000000 #!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Directory::Scratch' ); } diag( "Testing Directory::Scratch $Directory::Scratch::VERSION, Perl $], $^X" ); Directory-Scratch-0.15/t/developer/000755 000765 000024 00000000000 12132354364 017066 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/t/integration/000755 000765 000024 00000000000 12132354364 017424 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/t/os/000755 000765 000024 00000000000 12132354364 015522 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/t/unit/000755 000765 000024 00000000000 12132354364 016060 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/t/unit/append.t000644 000765 000024 00000001171 12132353454 017513 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # append.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 6; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); # this tests touch a bit too, sorry. ok($tmp->touch('foo', qw(Foo bar baz quux)), 'created foo'); my @lines = $tmp->read('foo'); is(scalar @lines, 4, 'read 4 lines'); is_deeply(\@lines, [qw(Foo bar baz quux)]); $tmp->append('foo', qw(Now the lines are different)); @lines = $tmp->read('foo'); is(scalar @lines, 9, 'read all 9 lines'); is_deeply(\@lines, [qw(Foo bar baz quux Now the lines are different)]); Directory-Scratch-0.15/t/unit/chmod.t000644 000765 000024 00000001076 12132353454 017342 0ustar00t0mstaff000000 000000 #!/usr/bin/env perl use Test::More tests => 7; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok $tmp, 'created $tmp' ; my @files = qw/foo bar baz/; my @paths = map { $tmp->touch($_, "this is $_") } @files; is scalar @paths, 3, '3 files created'; $tmp->chmod(0666, @files); is mode($_), 0666, 'mode is 0666' for @paths; $tmp->chmod(0444, 'foo'); is mode($paths[0]), 0444, 'mode is 0444 for foo'; is mode($paths[1]), 0666, 'mode is 0666 for bar'; sub mode { my $mode = [stat $_[0]]->[2]; $mode &= 0777; return $mode; } Directory-Scratch-0.15/t/unit/cleanup.t000644 000765 000024 00000000722 12132353454 017674 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # cleanup.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 8; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'create $tmp'); ok($tmp->touch('foo'), 'touch foo'); ok($tmp->mkdir('bar'), 'mkdir bar'); ok($tmp->touch('bar/baz'), 'touch baz'); $tmp->cleanup; ok(!$tmp->exists('foo')); ok(!$tmp->exists('bar')); ok(!$tmp->exists('baz')); ok(!-e $tmp->base, 'no base'); Directory-Scratch-0.15/t/unit/create_tree.t000644 000765 000024 00000001712 12132353454 020527 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # create_tree.t # Copyright (c) 2007 Jonathan Rockway use Test::More tests => 14; use Directory::Scratch; use strict; use warnings; use Path::Class; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); eval { $tmp->create_tree() }; ok(!$@, 'creating an empty tree works'); is(scalar $tmp->ls, 0, 'no files created'); my %tree = ( foo => 'foo', 'bar/baz' => 'this is bar/baz', 'quux' => 'this is quux', 'lines' => ['lots', 'of', 'lines'], 'dir' => \undef, ); $tmp->create_tree(\%tree); foreach my $file (keys %tree){ ok($tmp->exists($file), "$file exists") } ok(-d $tmp->exists('bar'), 'bar is a directory'); ok(-d $tmp->exists('dir'), 'dir is a dir'); foreach my $file (keys %tree){ is_deeply([$tmp->read($file)], [$tree{$file}], "$file contains expected text") unless ref $tree{$file}; } is_deeply($tree{lines}, [$tmp->read('lines')], 'read lines'); Directory-Scratch-0.15/t/unit/delete.t000644 000765 000024 00000001717 12132353454 017514 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # delete.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 17; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, '1 ko'); # palindromic > informative ok($tmp->touch('foo'), 'touch foo'); ok($tmp->mkdir('bar'), 'mkdir bar'); ok($tmp->touch('bar/baz'), 'touch bar/baz'); ok( $tmp->exists('bar/baz'), 'bar/baz exists'); ok( $tmp->delete('bar/baz'), 'delete bar/baz'); ok(!$tmp->exists('bar/baz'), 'bar/baz !exists'); ok( $tmp->exists('bar'), 'bar exists'); ok( $tmp->delete('bar'), 'rmdir bar'); ok(!$tmp->exists('bar'), 'bar !exists'); ok( $tmp->exists('foo'), 'foo exists'); ok( $tmp->delete('foo'), 'delete foo'); ok(!$tmp->exists('foo'), 'foo !exists'); ok($tmp->mkdir('bar'), 'create bar again'); ok($tmp->touch('bar/baz'), 'create bar/baz again'); ok($tmp->exists('bar/baz'), 'bar/baz exists'); eval { $tmp->delete('bar'); }; ok($@, q{can't remove full directory}); Directory-Scratch-0.15/t/unit/invalid_clone.t000644 000765 000024 00000000621 12132353454 021051 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # invalid_clone.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 2; use Directory::Scratch; use strict; use warnings; eval { Directory::Scratch::child({}); }; ok($@, "can't clone an unblessed ref"); eval { my $ref = {}; bless $ref => 'Foo'; Directory::Scratch::child($ref); }; ok($@, "can't clone a non-Directory::Scratch ref"); Directory-Scratch-0.15/t/unit/invalid_directory.t000644 000765 000024 00000001676 12132353454 021770 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # invalid_directory.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 7; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; my $d; ok($tmp->touch('foo'), 'create a file called foo'); $d = eval { $tmp->mkdir('foo'); }; ok(!$d, 'no directory'); ok($@, "can't create a directory with the same name as a file: $@"); undef $d; $d = eval { no warnings 'redefine'; # mostly here to make devel::cover happy; the above is the real test *Path::Class::Dir::mkpath = sub { mkdir $tmp->exists('foo') }; $tmp->mkdir('foo'); }; ok(!$d, 'no directory'); ok($@, "can't create a directory with the same name as a file: $@"); undef $d; $d = eval { # make mkdir not work no warnings 'redefine'; *Path::Class::Dir::mkpath = sub { return }; $tmp->mkdir('bar'); }; ok(!$d, 'no directory'); ok($@, "can't create a directory when mkdir doesn't work: $@"); Directory-Scratch-0.15/t/unit/link.t000644 000765 000024 00000000705 12132353454 017203 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # link.t # Copyright (c) 2006 Jonathan Rockway use Test::More; use Directory::Scratch; use strict; use warnings; plan skip_all => "Win32 can't symlink" if $^O eq 'MSWin32'; plan tests => 4; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); # this tests touch a bit too, sorry. ok($tmp->touch('foo'), 'created foo'); ok($tmp->link('foo', 'bar'), 'created bar'); ok($tmp->exists('bar'), 'bar exists!'); Directory-Scratch-0.15/t/unit/ls.t000644 000765 000024 00000002426 12132353454 016666 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # ls.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 12; use Directory::Scratch; use strict; use warnings; use Path::Class; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); ok($tmp->touch('foo'), 'foo'); ok($tmp->mkdir('bar/baz'), 'bar/baz'); ok($tmp->touch('bar/quux'), 'bar/quux'); ok($tmp->touch('bar/baz/quux'), 'bar/baz/quux'); my @files = sort $tmp->ls; is(scalar @files, 5, 'got 5 files under /'); my @reference = (file('bar'), dir(qw|bar baz|), file(qw|bar baz quux|), file(qw|bar quux|), file('foo')); is_deeply([map {$_->stringify} @files], [map {$_->stringify} @reference], 'check that paths agree'); # test ls / @files = sort $tmp->ls('/'); is(scalar @files, 5, 'got 5 files under /'); @reference = (file('bar'), dir(qw|bar baz|), file(qw|bar baz quux|), file(qw|bar quux|), file('foo')); is_deeply([map {$_->stringify} @files], [map {$_->stringify} @reference], 'check that paths agree'); eval { @files = sort $tmp->ls('this filename is fake'); }; ok($@, "can't ls files that don't exist"); @files = sort $tmp->ls('foo'); is_deeply(\@files, [file('foo')], 'single file = list'); @files = sort $tmp->ls('bar/baz'); is_deeply(\@files, [file(qw|bar baz quux|)], 'got bar/baz/quux in bar/baz'); Directory-Scratch-0.15/t/unit/mkdir.t000644 000765 000024 00000000573 12132353454 017357 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # mkdir.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 9; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); my $dir = $tmp->mkdir('foo/bar/baz/bat'); for(1..4){ ok(-e $dir, "$dir exists"); ok(-d $dir, ' and is a directory'); $dir = $dir->parent; } Directory-Scratch-0.15/t/unit/openfile.t000644 000765 000024 00000001420 12132353454 020042 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # openfile.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 8; use Directory::Scratch; use File::Slurp qw(read_file); use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); my ($fh, $path) = $tmp->openfile('foo'); is($path->stringify, $tmp->exists('foo')->stringify, 'openfile returned sane path'); eval { print {$fh} "Foo\nbar\nbaz\n"; }; ok(!$@, 'writing to fh works'); ok(close $fh, 'closed fh'); $fh = $tmp->openfile('bar'); eval { print {$fh} "Foo\nbar\nbaz\n"; }; ok(!$@, 'writing to fh works'); ok(close $fh, 'closed fh'); ok($tmp->exists('bar'), 'bar exists'); my $contents = read_file($tmp->exists('bar')->stringify); is($contents, "Foo\nbar\nbaz\n", 'bar can be read'); Directory-Scratch-0.15/t/unit/randfile.t000644 000765 000024 00000001037 12132353454 020031 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # randfile.t # Copyright (c) 2006 Jonathan Rockway use Test::More; use Directory::Scratch; eval "use String::Random"; plan skip_all => "Requires String::Random" if $@; plan tests => 321; my $tmp = Directory::Scratch->new; ok($tmp, 'create $tmp'); for(1..80){ my $name; ok($name = $tmp->randfile(60, 100), 'create random file'); ok(-e $name, 'created ok'); my @stat = stat _; ok($stat[7] <= 100 && $stat[7] >= 60, 'file is the correct size'); ok(unlink($name), "delete $name"); } Directory-Scratch-0.15/t/unit/read.t000644 000765 000024 00000000665 12132353454 017166 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # read.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 4; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); # this tests touch a bit too, sorry. ok($tmp->touch('foo', qw(Foo bar baz quux)), 'created foo'); my @lines = $tmp->read('foo'); is(scalar @lines, 4, 'read 4 lines'); is_deeply(\@lines, [qw(Foo bar baz quux)]); Directory-Scratch-0.15/t/unit/stat.t000644 000765 000024 00000000521 12132353454 017215 0ustar00t0mstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Test::More tests => 2; use Directory::Scratch; my $tmp = Directory::Scratch->new; my $file = $tmp->touch('foo', 'foo bar baz'); my $stats = $tmp->stat('foo'); isa_ok $stats, 'File::stat', '$stats'; my @stats = $tmp->stat('foo'); ok scalar @stats > 10, 'got an array, not an object'; Directory-Scratch-0.15/t/unit/tempfile.t000644 000765 000024 00000001102 12132353454 020043 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # tempfile.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 8; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); my ($fh, $filename) = $tmp->tempfile; eval { print {$fh} "Foo\nbar\nbaz\n"; }; ok(!$@, 'writing to fh works'); ok(close $fh, 'closed fh'); ok(-e $filename, 'file exists'); # try this in scalar context $fh = $tmp->tempfile; ok($fh, 'got a filehandle'); ok(print {$fh} "A line\n"); ok(seek $fh, 0, 0); is(<$fh>, "A line\n", 'read the line back'); Directory-Scratch-0.15/t/unit/touch.t000644 000765 000024 00000001233 12132353454 017365 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # touch.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 8; use Directory::Scratch; use strict; use warnings; use File::Slurp qw(read_file); my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); ok($tmp->touch('foo', qw(foo bar baz)), 'created foo'); ok($tmp->exists('foo'), 'foo exists'); my @lines = read_file($tmp->exists('foo')->stringify); is(chomp @lines, 3, 'right number of lines'); is_deeply(\@lines, [qw(foo bar baz)], 'foo has correct contents'); ok($tmp->touch('bar'), 'created bar'); ok($tmp->exists('bar'), 'bar exists'); ok(!read_file($tmp->exists('bar')->stringify), 'bar has no content'); Directory-Scratch-0.15/t/unit/write.t000644 000765 000024 00000001153 12132353454 017376 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # write.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 6; use Directory::Scratch; use strict; use warnings; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); # this tests touch a bit too, sorry. ok($tmp->touch('foo', qw(Foo bar baz quux)), 'created foo'); my @lines = $tmp->read('foo'); is(scalar @lines, 4, 'read 4 lines'); is_deeply(\@lines, [qw(Foo bar baz quux)]); $tmp->write('foo', qw(Now the lines are different)); @lines = $tmp->read('foo'); is(scalar @lines, 5, 'read the 5 new lines'); is_deeply(\@lines, [qw(Now the lines are different)]); Directory-Scratch-0.15/t/os/win32.t000644 000765 000024 00000000646 12132353454 016656 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # win32.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 3; use Directory::Scratch qw(Win32); use Path::Class; my $tmp = Directory::Scratch->new; ok($tmp, 'created $tmp'); my $file = $tmp->touch("foo\\bar\\baz"); ok(-e $file, "$file (foo\\bar\\baz) exists"); my @files = sort $tmp->ls; is_deeply(\@files, [sort (dir('foo'), dir(qw'foo bar'), dir(qw'foo bar baz'))]); Directory-Scratch-0.15/t/integration/01-parents_too.t000644 000765 000024 00000000527 12132353454 022367 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 01-parents_too.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 2; use Directory::Scratch; use strict; use warnings; my $t = Directory::Scratch->new; ok($t->touch('foo/bar/baz/bat/yay', qw(foo bar baz bat yay))); is_deeply([$t->read('foo/bar/baz/bat/yay')], [qw(foo bar baz bat yay)]); Directory-Scratch-0.15/t/integration/01-scratch.t000644 000765 000024 00000002614 12132353454 021460 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 01-scratch.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 19; use Directory::Scratch; my $temp = Directory::Scratch->new; my $base = $temp->base; # create (4) ok($temp); ok(-e $base, 'tempdir exists'); ok(-d _, 'tempdir is a directory'); ok(-w _, 'tempdir is writable'); # mkdir (3) my $dir = $temp->mkdir('foo/bar/baz'); ok($dir =~ m{foo.?bar.?baz.?$}, 'dir has a reasonable name'); ok(-e $dir, 'dir exists'); ok(-d $dir, 'dir is a directory'); # openfile (5) ok(my $fh = $temp->openfile('baaa'), "openfile" ); ok(fileno($fh), "openfile() returned a filehandle" ); ok($temp->exists('baaa'), 'the file exists'); ok(print {$fh} "hello\n"); ok(close($fh), "can close the opened filehandle"); # touch (2) my $file = $temp->touch('foo/bar/baz/bat', qw{Here are some lines}); ok(-e $file, 'file exists'); ok(-r $file, 'file readable'); # touch with lines (2) my $lfile = $temp->touch('baa', "This is a single line"); open($fh, '<', $lfile); my @lines = <$fh>; is($lines[0], "This is a single line\n"); is($lines[1], undef); close $fh; $lfile = $temp->touch('baaa', qw{There is more than one line}); open($fh, '<', $lfile); @lines = <$fh>; chomp @lines; is_deeply(\@lines, [qw{There is more than one line}]); close $fh; # delete (2) $temp->delete('foo/bar/baz/bat'); ok(!-e $file, 'file went away'); $temp->delete('foo/bar/baz'); ok(!-e $dir, 'dir went away'); Directory-Scratch-0.15/t/integration/02-nesting.t000644 000765 000024 00000000540 12132353454 021475 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 02-nesting.t # Copyright (c) 2006 Jonathan Rockway # make sure nesting directories is ok use Test::More tests => 4; use Directory::Scratch; my $tmp = Directory::Scratch->new; my $a = $tmp->mkdir('a'); ok(-d $a); my $b = $tmp->mkdir('a/b'); ok(-d $a); ok(-d $b); my $c = $tmp->mkdir('foo/bar/baz'); ok(-d $c); Directory-Scratch-0.15/t/integration/03-list.t000644 000765 000024 00000001720 12132353454 021003 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 03-list.t # Copyright (c) 2006 Jonathan Rockway use strict; use warnings; use Test::More tests=>16; use Directory::Scratch; use Path::Class; my @files = qw(foo bar baz); my @dirs = qw(1 2 3); my $t = Directory::Scratch->new; my @list; foreach my $dir (@dirs){ my $tmp = $t->mkdir($dir); ok($tmp, "mkdir $dir"); push @list, $dir; foreach my $file (@files){ my $name = file($dir, $file); $tmp = $t->touch($name); ok($tmp, "touch $tmp"); push @list, $name; } } # do it my @result = $t->ls; @list = sort @list; @result = sort @result; is_deeply(\@result, \@list, "listed everything"); @result = $t->ls; @result = sort @result; is_deeply(\@result, \@list, "listed everything (with /)"); @result = sort $t->ls('1'); my @possible = map {file('1', $_)} qw(bar baz foo); is_deeply(\@result, \@possible, 'listed 1'); $t->touch('fooo'); is_deeply([$t->ls('fooo')], ['fooo'], "listing a single file is OK"); Directory-Scratch-0.15/t/integration/04-links.t000644 000765 000024 00000001721 12132353454 021152 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 04-links.t # Copyright (c) 2006 Jonathan Rockway use Directory::Scratch; use Test::More; use strict; use warnings; plan skip_all => "links don't work under Win32" if $^O eq 'MSWin32'; plan tests => 14; my $t = Directory::Scratch->new; my $file1 = $t->touch('test', "this is a test"); my $dir = $t->mkdir('foo'); my $file2 = $t->touch('foo/test', "this is also a test"); ok($file1); ok($dir); ok($file2); ok($t->link('test', 'new_test')); ok($t->link('foo', 'new_foo')); ok($t->link('foo/test', 'new_foo_test')); ok($t->link('new_foo/test', 'newer_test')); is($t->read('test'), "this is a test"); is($t->read('foo/test'), "this is also a test"); is($t->read('newer_test'), "this is also a test"); is($t->read('new_foo/test'), "this is also a test"); ok($t->touch('bar')); eval { $t->link('test', 'bar'); }; ok($@, 'cannot link over an existing file'); eval { $t->link('test', 'test'); }; ok($@, 'cannot link over self'); Directory-Scratch-0.15/t/integration/05-readwrite.t000644 000765 000024 00000001665 12132353454 022030 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 05-readwrite.t # Copyright (c) 2006 Jonathan Rockway use Directory::Scratch; use Test::More tests=>15; use strict; use warnings; my $t = Directory::Scratch->new; ok($t->touch('foo')); is($t->read('foo'), q{}, "nothing in foo"); ok($t->write('foo', "this is a test")); is(scalar $t->read('foo'), "this is a test", 'read test'); is_deeply([$t->read('foo')], ["this is a test"]); ok($t->touch('bar', qw(this is a test))); is(scalar $t->read('bar'), "this\nis\na\ntest"); is_deeply([$t->read('bar')], [qw(this is a test)]); ok($t->touch('baz', "this already has a line")); ok($t->write('baz', "oh no, it went away")); is(scalar $t->read('baz'), "oh no, it went away"); ok($t->write('baz', qw(foo bar baz yay!))); is(scalar $t->read('baz'), "foo\nbar\nbaz\nyay!"); is_deeply([$t->read('baz')], [qw(foo bar baz yay!)]); eval { $t->write('/made/up/filename', qw(foo bar)); }; ok(!$@, "didn't get an error"); Directory-Scratch-0.15/t/integration/06-append-prepend.t000644 000765 000024 00000001361 12132353454 022736 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 06-append-prepend.t # Copyright (c) 2006 Jonathan Rockway use Directory::Scratch; use Test::More tests=>8; use strict; use warnings; my $t = Directory::Scratch->new; ok($t->write('baz', qw(foo bar baz yay!))); is(scalar $t->read('baz'), "foo\nbar\nbaz\nyay!"); is_deeply([$t->read('baz')], [qw(foo bar baz yay!)]); ok($t->append('baz', qw(yay! again))); is(scalar $t->read('baz'), "foo\nbar\nbaz\nyay!\nyay!\nagain"); is_deeply([$t->read('baz')], [qw(foo bar baz yay! yay! again)]); SKIP: { skip "waiting for prepend from uri", 2; ok($t->prepend('baz', [qw(what are we gonna do tonight brain)])); is_deeply([$t->read('baz')], [qw(what are we gonna do tonight brain foo bar baz yay! yay! again)]); } Directory-Scratch-0.15/t/integration/07-delete.t000644 000765 000024 00000001375 12132353454 021304 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 07-delete.t # Copyright (c) 2006 Jonathan Rockway use Directory::Scratch; use Test::More tests=>15; use strict; use warnings; my $t = Directory::Scratch->new; eval { $t->delete('fake'); }; ok($@, "can't delete things that don't exist"); ok($t->mkdir('foo')); ok($t->touch('foo/bar')); eval { $t->delete('foo'); }; ok($@, "can't delete non-empty directories"); ok($t->exists('foo')); ok($t->exists('foo/bar')); ok($t->delete('foo/bar')); ok($t->delete('foo')); ok(!$t->exists('foo')); ok(!$t->exists('foo/bar')); ok($t->touch('foo')); SKIP: { skip 'no links on win32', 4 if $^O eq 'MSWin32'; ok($t->link('foo', 'bar')); ok($t->exists('bar')); ok($t->delete('bar')); ok(!$t->exists('bar')); } Directory-Scratch-0.15/t/integration/08-exists.t000644 000765 000024 00000000671 12132353454 021360 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 08-exists.t # Copyright (c) 2006 Jonathan Rockway use Directory::Scratch; use Test::More tests=>7; use strict; use warnings; my $t = Directory::Scratch->new; my $base = $t->base; ok(!$t->exists('foo/bar')); ok(!$t->exists('foo')); ok(!$t->exists('bar')); my $foobar = $t->touch('foo/bar'); ok($foobar); is($t->exists('foo/bar'), $foobar); ok($t->exists('foo')); ok($t->exists('foo') =~ /foo$/); Directory-Scratch-0.15/t/integration/09-clone_object.t000644 000765 000024 00000002251 12132353454 022464 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 09-clone_object.t # Copyright (c) 2006 Al Tobey # and Jonathan Rockway use Directory::Scratch; use Test::More tests=>12; use strict; use warnings; my $t = Directory::Scratch->new; isa_ok($t, 'Directory::Scratch'); can_ok( $t, 'child' ); ok( my $sub_t = $t->child, "Call child on a parent Directory::Scratch object." ); my @parent = $t->base->dir_list; my @child = $sub_t->base->dir_list; ok( @child > @parent, "Child should have more nodes than the parent." ); my $subdir = pop @child; is_deeply( \@child, \@parent, "Child with last element popped should == parent." ); #diag( "chdir into the parent directory" ); chdir($t->base); ok( -d $subdir, "child subdirectory basename exists under parent" ); ok( my $sub_sub_t = $sub_t->child, "create a grandchild" ); my $subsub_dir = $sub_sub_t->base; ok( -d $subsub_dir, "grandchild directory exists" ); ok( $sub_t->cleanup, "call cleanup() on the child" ); ok( !-d $subsub_dir, "grandchild no longer exists after cleanup()" ); ok( !-d $subdir, "child no longer exists after cleanup()" ); ok( -d $t->base, "parent still exists after cleanup()" ); Directory-Scratch-0.15/t/integration/10-new-with-arguments.t000644 000765 000024 00000001330 12132353454 023570 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 10-new-with-arguments.t # Copyright (c) 2006 Jonathan Rockway use strict; use warnings; use Test::More tests => 5; use Directory::Scratch; use File::Spec; my $tmp = Directory::Scratch->new( TEMPLATE => 'foo_bar_baz_XXXX', ); ok($tmp); my $dir = $tmp->base; like($dir, qr/[^\w]foo_bar_baz_....[^\w]?$/, 'base matches template'); $tmp = Directory::Scratch->new( DIR => File::Spec->tmpdir, TEMPLATE => 'foo_bar_baz_XXXX', ); ok($tmp); my $new_dir = $tmp->base; like($new_dir, qr/[^\w]foo_bar_baz_....[^\w]?$/, 'base matches template'); $dir =~ s/....$//; $new_dir =~ s/....$//; is($dir, $new_dir, 'DIR = tmpdir, and no DIR produce identical paths'); Directory-Scratch-0.15/t/integration/11-cleanup.t000644 000765 000024 00000001423 12132353454 021456 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 11-cleanup.t # Copyright (c) 2006 Jonathan Rockway use strict; use warnings; use Test::More tests=>8; use Directory::Scratch; use File::Path; my $tmp = Directory::Scratch->new; isa_ok($tmp, 'Directory::Scratch'); my $base_1 = $tmp->base; $tmp->touch('foo'); ok(-e $base_1); undef $tmp; diag("Manually verify that $base_1 got cleaned up."); $tmp = Directory::Scratch->new; isa_ok($tmp, 'Directory::Scratch'); my $base = $tmp->base; ok(-e $base); $tmp->cleanup; ok(!-e $base, 'explicitly cleaned up OK'); $tmp = Directory::Scratch->new(CLEANUP => 0); isa_ok($tmp, 'Directory::Scratch'); $base = $tmp->base; $SIG{__WARN__} = sub {}; ok(-e $base); undef $tmp; File::Path::rmtree($base->stringify, 0, 1); ok(!-e $base, 'cleaned up manually OK'); Directory-Scratch-0.15/t/integration/11-stringify.t000644 000765 000024 00000000405 12132353454 022044 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 11-stringify.t # Copyright (c) 2006 Jonathan Rockway use strict; use warnings; use Test::More tests => 1; use Directory::Scratch; my $tmp = Directory::Scratch->new; is($tmp->base, "$tmp", 'tmp stringifies to its base'); Directory-Scratch-0.15/t/integration/12-randfile.t000644 000765 000024 00000003023 12132353454 021612 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # 12-randfile.t # Copyright (c) 2006 Rockway # Copyright (c) 2006 Al Tobey use Test::More; use Directory::Scratch; eval "use String::Random"; plan skip_all => "Requires String::Random" if $@; plan tests => 109; # I run local tests of 512 or more to exhaust the chances entropy is causing # tests to pass that might fail on client machines # 20 should suffice for clients downloading from CPAN my $loop_iterations = 20; my $temp = Directory::Scratch->new; ok( my $rfile = $temp->randfile, "randfile()" ); ok( length($rfile), "randfile() returned a string" ); ok( -e $rfile, "file exists" ); ok( unlink($rfile), "file unlink() succeeds" ); $rfile = undef; sub test_iterations { for my $i (1..$loop_iterations) { ok( $rfile = $temp->randfile( 1024, 2048 ), "$i: randfile( 1024, 2048 )" ); my $size = -s $rfile; ok( -e $rfile, " $i: File exists." ); cmp_ok( $size, '>=', 1024, " $i: size of file: $size > 1024" ); cmp_ok( $size, '<=', 2048, " $i: size of file: $size < 2048" ); } } test_iterations(); my $j = 1; for ( my $i=1; $i<=1000000; $i *= 10 ) { ok( my $file = $temp->randfile($j, $i), "randfile($j, $i)" ); my $size = -s $file; if ( $size <= $i && $size >= $j ) { pass( " check file size" ); } else { fail( " check file size ( $size <= $i && $size >= $j )" ); } $j = $i; unlink $file; } for ( my $i=1; $i<=1024; $i *= 2 ) { ok( my $file = $temp->randfile($i), "randfile($i)" ); } Directory-Scratch-0.15/t/integration/other_output_seperator.t000644 000765 000024 00000001606 12132353454 024440 0ustar00t0mstaff000000 000000 #!/usr/bin/perl # other_output_seperator.t # Copyright (c) 2006 Jonathan Rockway use Test::More tests => 8; use Directory::Scratch; use File::Slurp qw(read_file); my $tmp = Directory::Scratch->new; local $, = '!'; local $/ = '!'; ok($tmp->touch('foo', qw(these are some lines)), 'create foo'); my $file = read_file(''. $tmp->exists('foo')); ok($file, 'read it back in'); is($file, 'these!are!some!lines!', 'lines end in !'); my @file = $tmp->read('foo'); is_deeply(\@file, [qw(these are some lines)], 'works in array context too'); ok($tmp->append('foo', qw(now there are more)), 'add more lines'); $file = read_file(''. $tmp->exists('foo')); ok($file, 'read it back in'); is($file, 'these!are!some!lines!now!there!are!more!', 'lines end in !'); @file = $tmp->read('foo'); is_deeply(\@file, [qw(these are some lines now there are more)], 'works in array context too'); Directory-Scratch-0.15/t/developer/boilerplate.t000644 000765 000024 00000002330 12132353454 021552 0ustar00t0mstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 3; sub not_in_file_ok { my ($filename, %regex) = @_; open my $fh, "<", $filename or die "couldn't open $filename for reading: $!"; my %violated; while (my $line = <$fh>) { while (my ($desc, $regex) = each %regex) { if ($line =~ $regex) { push @{$violated{$desc}||=[]}, $.; } } } if (%violated) { fail("$filename contains boilerplate text"); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass("$filename contains no boilerplate text"); } } not_in_file_ok(README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok(Changes => "placeholder date/time" => qr(Date/time) ); sub module_boilerplate_ok { my ($module) = @_; not_in_file_ok($module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } module_boilerplate_ok('lib/Directory/Scratch.pm'); Directory-Scratch-0.15/t/developer/pod-coverage.t000644 000765 000024 00000000254 12132353454 021626 0ustar00t0mstaff000000 000000 #!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); Directory-Scratch-0.15/t/developer/pod.t000644 000765 000024 00000000214 12132353454 020031 0ustar00t0mstaff000000 000000 #!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Directory-Scratch-0.15/lib/Directory/000755 000765 000024 00000000000 12132354364 017350 5ustar00t0mstaff000000 000000 Directory-Scratch-0.15/lib/Directory/Scratch.pm000644 000765 000024 00000047700 12132354332 021300 0ustar00t0mstaff000000 000000 package 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.15'; # 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