File-Fu-v0.0.8000755000764000764 012153041214 13734 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/META.json000444000764000764 406212153041214 15514 0ustar00ewilhelmewilhelm000000000000{ "abstract" : "file and directory objects", "author" : [ "Eric Wilhelm @ " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4005, CPAN::Meta::Converter version 2.131490", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "File-Fu", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.38", "Test::More" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.40" } }, "runtime" : { "requires" : { "Class::Accessor::Classy" : "v0.9.0", "File::Spec" : "0", "File::Which" : "0.05", "IO::File" : "0" } } }, "provides" : { "File::Fu" : { "file" : "lib/File/Fu.pm", "version" : "v0.0.8" }, "File::Fu::Base" : { "file" : "lib/File/Fu/Base.pm", "version" : "v0.0.8" }, "File::Fu::Dir" : { "file" : "lib/File/Fu/Dir.pm", "version" : "v0.0.8" }, "File::Fu::Dir::FindKnob" : { "file" : "lib/File/Fu/Dir.pm" }, "File::Fu::Dir::Temp" : { "file" : "lib/File/Fu/Dir/Temp.pm", "version" : "v0.0.8" }, "File::Fu::Dir::Token" : { "file" : "lib/File/Fu/Dir.pm" }, "File::Fu::File" : { "file" : "lib/File/Fu/File.pm", "version" : "v0.0.8" }, "File::Fu::File::Temp" : { "file" : "lib/File/Fu/File/Temp.pm", "version" : "v0.0.8" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Fu" }, "homepage" : "http://enobacon.com/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "git://git.enobacon.com/File-Fu.pm.git" } }, "version" : "v0.0.8" } File-Fu-v0.0.8/MANIFEST000444000764000764 51712153041214 15205 0ustar00ewilhelmewilhelm000000000000Build.PL Changes lib/File/Fu.pm lib/File/Fu/Base.pm lib/File/Fu/Dir.pm lib/File/Fu/Dir/Temp.pm lib/File/Fu/File.pm lib/File/Fu/File/Temp.pm MANIFEST MANIFEST.SKIP META.json META.yml README t/00-load.t t/basic.t t/dir.t t/dirlinks.t t/end_bits.t t/errors.t t/finder.t t/findknob.t t/global.t t/links.t t/slice.t t/slurp.t t/temp.t todo File-Fu-v0.0.8/MANIFEST.SKIP000444000764000764 107712153041214 15774 0ustar00ewilhelmewilhelm000000000000# Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \b_darcs\b \b.cvsignore\b ^.gitignore$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.swp$ # Avoid archives of this distribution \b-v?[\d\.\_]+ # Avoid Devel::Cover files. \bcover_db\b TODO ^MYMETA.yml$ ^MYMETA.json$ File-Fu-v0.0.8/Changes000444000764000764 431112153041214 15363 0ustar00ewilhelmewilhelm000000000000Revision history for File-Fu v0.0.8 2013-06-02 * fixed t/findknob.t failures / logic * added File move(), mkfifo(), sysopen() * made File write() chainable * added write() and do() to temp filehandles * added remove() to File * added relative_to() method * fixed a regression in the temp dir rename() method v0.0.7 2010-02-27 * much better documentation for File::Fu::Dir::find() * added rename() for Dir objects * allow Dir parts() and slice() to have negative indices * improvements to temp_dir v0.0.6 2009-01-31 * added File::Fu->which() ala File::Which::which * supporting e.g. 'use File::Fu::File' as the entry-point v0.0.5 2008-12-09 * added is_same() method * added copy() method * fix for $dir + 'path/and/file' bug * added write() method to File objects * added relative_symlink() * corrected File SYNOPSIS pod (pointed out by John LoVerso) * corrected 'dir/', 'foo/', 'bar/' error in introduction (pointed out by Ron Savage) * fixed perl 5.6.2 nit todo with chdir_for() v0.0.4 2008-09-07 * resolve() method * File::Fu->THIS_FILE * chdir_for() and chdir_local() methods for Dir * added slice parameter to map() for Dir * File::Fu->program_name() / program_dir() * File::Fu->cwd * absolutely() method for Cwd-style resolution * updated %= documentation * added pipe_open() method for files * chmod(), chdir() methods * some handling of auto cleanup in Temp * create() and mkdir() return self * mode support in mkdir() * File::Fu->home() * part() and slice() methods in dir * relative() has an optional $to argument v0.0.3 2008-03-08 ! changed inner append to '%' from . v0.0.2 2008-02-27 ! still subject to API changes * lots of new methods (readlink, mkdir, rmdir, touch, stat) * part() and end() methods (Dir) * renamed listing() to list() and iterate_listing() to lister() (Dir) * find()/finder() methods (Dir) * temp_file()/temp_dir() methods (Dir) * read() method for slurping (File) * pod, tests, and other good stuff v0.0.1 2008-02-18 * first public release See the source code repository for more detail. http://svn.scratchcomputing.com/File-Fu/trunk vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/todo000444000764000764 121512153041214 14760 0ustar00ewilhelmewilhelm000000000000o coverage: o relative($tobase); o parts/slice o dir->map(..., $n/[$m,$n]) o File::Fu->program_name o File::Fu->program_dir ? directory mod within filename - wav/thing/foo.wav => flac/thing/foo.flac $file->dirname->map(sub {s/wav/flac/}, 0); $file->dirname->map([wav => 'flac'], 0); $file->dirname->map([qw(wav flac)], 0); ($file &= λ{s/wav/flac/})->dirname &= λ{s/wav/flac/}; $file->map(λ{s/\.wav$/flac/})->dirname->map(λ{s/wav/flac/}, 0); x $dir + 'foo/bar' problem o freedesktop o home o mimeinfo o basedir o resolve() symlink chase-down o URI support? - is that just a subclass with a volume-like thing? File-Fu-v0.0.8/README000444000764000764 41712153041214 14733 0ustar00ewilhelmewilhelm000000000000File-Fu INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc File::Fu File-Fu-v0.0.8/META.yml000444000764000764 235312153041214 15345 0ustar00ewilhelmewilhelm000000000000--- abstract: 'file and directory objects' author: - 'Eric Wilhelm @ ' build_requires: Module::Build: 0.38 Test::More: 0 configure_requires: Module::Build: 0.40 dynamic_config: 1 generated_by: 'Module::Build version 0.4005, CPAN::Meta::Converter version 2.131490' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: File-Fu provides: File::Fu: file: lib/File/Fu.pm version: v0.0.8 File::Fu::Base: file: lib/File/Fu/Base.pm version: v0.0.8 File::Fu::Dir: file: lib/File/Fu/Dir.pm version: v0.0.8 File::Fu::Dir::FindKnob: file: lib/File/Fu/Dir.pm File::Fu::Dir::Temp: file: lib/File/Fu/Dir/Temp.pm version: v0.0.8 File::Fu::Dir::Token: file: lib/File/Fu/Dir.pm File::Fu::File: file: lib/File/Fu/File.pm version: v0.0.8 File::Fu::File::Temp: file: lib/File/Fu/File/Temp.pm version: v0.0.8 requires: Class::Accessor::Classy: v0.9.0 File::Spec: 0 File::Which: 0.05 IO::File: 0 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Fu homepage: http://enobacon.com/ license: http://dev.perl.org/licenses/ repository: git://git.enobacon.com/File-Fu.pm.git version: v0.0.8 File-Fu-v0.0.8/Build.PL000444000764000764 171012153041214 15364 0ustar00ewilhelmewilhelm000000000000 use strict; use warnings; use Module::Build; my $build_class = 'Module::Build'; my $builder = $build_class->new( module_name => 'File::Fu', license => 'perl', dist_version_from => 'lib/File/Fu.pm', requires => { 'IO::File' => 0, # TODO check version 'File::Spec' => 0, # TODO remove 'File::Which' => 0.05, 'Class::Accessor::Classy' => 'v0.9.0', }, build_requires => { 'Module::Build' => 0.38, 'Test::More' => 0, }, add_to_cleanup => [ qw(File-Fu-* META.yml)], # create_makefile_pl => 'passthrough', meta_merge => { resources => { homepage => 'http://enobacon.com/', bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Fu', #MailingList => 'mailto:...', repository => 'git://git.enobacon.com/File-Fu.pm.git', } }, ); $builder->create_build_script(); # vi:syntax=perl:ts=2:sw=2:et:sta File-Fu-v0.0.8/t000755000764000764 012153041214 14177 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/t/errors.t000555000764000764 141512153041214 16041 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; { # invalid ops my $f = File::Fu->dir; eval {my $nope = $f - 8}; like($@, qr/^- is not a valid op/); eval {my $nope = $f * 8}; like($@, qr/^\* is not a valid op/); eval {my $nope = $f << 8}; like($@, qr/^<< is not a valid op/); } { # readlink on a non-link my $f = File::Fu->file("blortleblat89"); $f->e and $f->unlink; ok(! $f->e, "no $f") or die "where did $f come from?!"; eval {my $l = $f->readlink}; like($@, qr/^cannot readlink .* No such/, 'no readlink on nil'); my $fh = $f->open('>'); close($fh) or die "ack $!"; eval {my $l = $f->readlink}; like($@, qr/^cannot readlink .* Invalid/, 'no readlink on file'); $f->unlink; } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/basic.t000555000764000764 514612153041214 15613 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $dir = File::Fu->dir; ok($dir, 'constructor'); is($dir, File::Fu::Dir->new('.'), 'current directory default'); is("$dir", './', 'stringify'); is("$dir\n", "./\n", 'stringify'); is($dir->part(0), '.'); is($dir->part(-1), '.'); my $root = File::Fu->dir('/'); ok(defined($root), 'root dir'); ok($root->is_absolute, 'absolute'); is($root, '/'); is($root->part(0), ''); is($root->part(-1), ''); my $file = $dir + 'Build.PL'; is("$file", "Build.PL"); ok($file->e, 'file exists'); my $abs_dir = $dir->absolute; ok($abs_dir->is_absolute, 'dir is absolute'); my $abs_file = $abs_dir + 'Build.PL'; ok($abs_file->is_absolute, 'file is absolute'); is($abs_file, $file->absolute, 'absolute matches abs_dir->file(...)'); is($file . 'foo', 'Build.PLfoo', 'append'); is('.'.$file, '.Build.PL', 'reverse append'); my $also_file = $file->clone; $also_file->file =~ s/\.PL/.foo/; ok(ref($also_file), 'has ref'); is($also_file, 'Build.foo', 'whee'); is($file, 'Build.PL', 'original unchanged'); { my $f = File::Fu->file("foo"); my $q = $f; $f &= sub {s/o/i/g}; is($q, 'foo', 'q ok'); is($f, 'fii', 's///'); is(ref($f), 'File::Fu::File', 'object ok'); is(ref($f.''), '', 'stringify'); my $s = $q & sub {s/o/i/g}; is($q, 'foo', 'q ok'); is($s, 'fii', 's///'); } # append with override { my $f = File::Fu->file("foo"); my $d = $f % 'bar'; is($d, 'foobar', 'inner append'); is(ref($d), 'File::Fu::File', 'object ok'); is($f, 'foo', 'f ok'); my $q = $f; $f %= 'bar'; is(ref($f), 'File::Fu::File', 'object ok'); is($f, 'foobar', 'f ok'); is($q, 'foo', 'q ok'); } # append as method { my $f = File::Fu->file("foo"); $f->append('baz'); is($f, 'foobaz'); } { my $d = File::Fu->dir("foo"); my $q = $d; my $r = $d % 'foo'; is($r, 'foofoo/', 'append'); ok($d ne 'foofoo/', 'deref'); $d %= 'foo'; is($r, 'foofoo/', 'r unbroken'); is($q, 'foo/', 'q unbroken'); ok($d ne $q, 'unbroken'); is(ref($q), ref($d), 'same package'); $q += "bar"; is($d, 'foofoo/'); is($q, 'foo/bar'); is(ref($q), 'File::Fu::File'); } { my $d = File::Fu->dir; ok($d->is_cwd); is($d, './'); $d /= 'foo'; ok(!$d->is_cwd); is($d, 'foo/'); $d /= 'bar'; is($d, 'foo/bar/'); is($d->basename, 'bar/'); is($d->dirname, 'foo/'); is($d->dirname->dirname, './'); is($d->part(0), 'foo'); is($d->part(1), 'bar'); is($d->part(-1), 'bar'); } # $dir + 'path/and/file' { my $dir = File::Fu->dir('foo'); my $file = $dir + 'this/and/that'; is($file->basename, 'that'); is($file->dirname, 'foo/this/and/'); } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/slice.t000555000764000764 54512153041214 15607 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw{no_plan}; use File::Fu; my $dir = File::Fu->dir('foo/bar/baz/bort/'); is($dir->slice(0,3), 'foo/bar/baz/bort/'); is($dir->slice(0,-1), 'foo/bar/baz/bort/'); is($dir->slice(0,-2), 'foo/bar/baz/'); is($dir->slice(0,-3), 'foo/bar/'); is($dir->slice(-2,-1), 'baz/bort/'); # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/global.t000555000764000764 36612153041214 15751 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; is(File::Fu->program_name->relative, 't/global.t'); is(File::Fu->program_dir->relative, 't/'); is(File::Fu->THIS_FILE, 't/global.t'); # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/00-load.t000444000764000764 50712153041214 15637 0ustar00ewilhelmewilhelm000000000000 use warnings; use strict; use Test::More tests => 1; my $package = 'File::Fu'; eval("require $package"); my $err = $@; ok(! $err, 'load ok'); if($err) { warn $err, "\n"; BAIL_OUT("cannot load $package STOP!"); } eval {require version}; diag("Testing $package ", $package->VERSION ); # vim:syntax=perl:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/findknob.t000555000764000764 135612153041214 16323 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More no_plan =>; use File::Fu; my $topdir = File::Fu->dir('tmp.' . $$); END { $topdir->remove; } $topdir->mkdir; ($topdir+$_)->touch for('a'..'z'); my $foo = $topdir->subdir("foo"); $foo->mkdir; $foo->basename->symlink($topdir/'link'); ($foo+$_)->touch for('a'..'z'); # TODO multiple runs / fs order permutation? my $x = 'j'; { # without prune => recurse my @files = $topdir->find(sub { $_->basename eq $x }); is(join('|', sort @files), join('|', sort $foo + $x, $topdir + $x )); } { # with prune my @files = $topdir->find(sub { return shift->prune if $_->is_dir; $_->basename eq $x }); is(join('|', sort @files), $topdir + $x); } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/end_bits.t000555000764000764 256112153041214 16317 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $root = File::Fu->dir('/'); is($root, '/'); is($root->basename, '/'); is($root->dirname, '/'); my $also = $root; $also /= 'foo'; is($also, '/foo/'); is($root, '/', 'undamaged'); my $cwd = File::Fu->dir('./'); is($cwd, './'); is($cwd->basename, './'); is($cwd->dirname, './'); my $rpath = $cwd / 'foo' / 'bar' / 'baz'; is($rpath, 'foo/bar/baz/'); is($rpath->dirname, 'foo/bar/'); is($rpath->basename, 'baz/'); my $rpath2 = $cwd / 'foo/bar/baz'; is($rpath2, 'foo/bar/baz/'); is($rpath2->dirname, 'foo/bar/'); is($rpath2->basename, 'baz/'); my $apath = $root / 'foo' / 'bar' / 'baz'; is($apath, '/foo/bar/baz/'); is($apath->dirname, '/foo/bar/'); is($apath->basename, 'baz/'); is("foo:$apath", 'foo:/foo/bar/baz/'); my $afile = $apath+'bort'; is($afile, '/foo/bar/baz/bort'); is("foo:$afile", 'foo:/foo/bar/baz/bort'); my $afile2 = File::Fu->file('/foo/bar/baz/bort'); is($afile2->dir, '/foo/bar/baz/'); is($afile2, '/foo/bar/baz/bort'); is("foo:$afile2", 'foo:/foo/bar/baz/bort'); { my $apath2 = $root / 'foo/bar/baz'; is($apath2, '/foo/bar/baz/'); is($apath2->dirname, '/foo/bar/'); is($apath2->basename, 'baz/'); my $apath3 = $root / 'foo//bar/baz////'; is($apath3, '/foo/bar/baz/'); is($apath3->dirname, '/foo/bar/'); is($apath3->basename, 'baz/'); } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/links.t000555000764000764 341312153041214 15645 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $tmp = File::Fu->dir('tmp'); mkdir($tmp); # make a file my $file = $tmp + 'file'; is($file, 'tmp/file'); my $fh = $file->open('>'); print $fh "yay\n"; close($fh) or die "cannot write '$file' $!"; ok($file->e); # hardlink my $link = $file->link($tmp->file('link')->stringify); is($link, 'tmp/link'); $file->unlink; ok(! $file->e); ok($link->e, 'link still there'); # TODO stat { my $fh = $link->open; chomp(my $line = <$fh>); is($line, 'yay'); } my $sl = $link->symlink($tmp->file('symlink')->stringify); is($sl, 'tmp/symlink'); ok($sl->l, 'is a link'); is($sl->readlink, 'tmp/link'); ok(! $sl->e, 'target does not exist (relativity)'); $sl->unlink; ok(! $sl->l, 'gone'); $sl = $link->basename->symlink($sl); ok($sl->e, 'exists'); ok($sl->l, 'is a link'); # renaming my $linknow = $link->rename('tmp/linknow'); is($linknow, 'tmp/linknow'); ok(! $link->e); ok(! $sl->e); is($link, 'tmp/link'); $linknow->rename($link); ok($link->e); ok($sl->e); ok(!$linknow->e); is($linknow, 'tmp/linknow'); $link->unlink; ok(! $link->e); ok(! $sl->e); $sl->unlink; ok(! $sl->l); # symlink->symlink->symlink { my $tmp = File::Fu->dir('tmp.links.' . $$); $tmp->mkdir; my $file = $tmp->file('file')->touch; is($file->resolve, $file); my $link = $file->basename->symlink($tmp + 'link1'); is($link->resolve, $file); $tmp->remove; } # relative symlink { my $file = $tmp->file('file')->touch; ok($file->e); my $dir = $tmp->subdir('dir')->mkdir; ok($dir->d); my $link = $file->relative_symlink($dir + 'and'); ok($link->l); ok($link->e); $file->unlink; ok(! $file->e); ok(! $link->e); $link->unlink; $dir->rmdir; } rmdir($tmp) or die "cannot delete '$tmp'"; # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/dir.t000555000764000764 415412153041214 15306 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; { my $d = File::Fu->dir("foo." . $$); $d->e and $d->rmdir; is($d->mkdir, $d); ok($d->e, 'exists'); ok($d->d, 'is a directory'); $d->rmdir; ok(! $d->e, 'not exists'); eval { $d->touch }; like($@, qr/^cannot/); # make a file my $f = $d + 'foo'; eval { $f->touch }; like($@, qr/^cannot.*No such/); $d->mkdir; $f->touch; eval { $d->rmdir }; like($@, qr/^cannot.*not empty/); $f->unlink; $d->rmdir; ok(! $d->e, 'not exists'); { # check chdir_for(), cwd(), chdir() $d->mkdir; $f->touch; my $cwd = File::Fu->cwd; my @got = $d->chdir_for(sub {shift->list}); is(scalar(@got), 1); is($got[0], 'foo', 'chdir_for'); is(File::Fu->cwd, $cwd); $f->unlink; $d->rmdir; } my $dl = $d->symlink('link.' . $$); ok($dl->l, 'is a link'); is($dl->readlink, "$d"); ok(! $dl->e, 'not exists'); eval { $dl->mkdir }; like($@, qr/^cannot.*exists/, 'link not dir'); # lstat a broken link is ok, stat isn't ok($dl->lstat); eval { $dl->stat }; like($@, qr/^cannot.*No such/); $d->mkdir; ok($dl->e, 'exists'); ok($d->e, 'exists'); # cannot change the time of a link? my $lt = $d->lstat->mtime; $dl->utime($lt + 8); my $dt = $lt + 8; is($dl->lstat->mtime, $lt); is($d->stat->mtime, $dt); is($dl->stat->mtime, $dt, 'mtime'); # hmm, what else can I test without sleeping? $dl->unlink; $d->rmdir; } { my $d = File::Fu->dir('tmp.' . $$); $d->e and $d->rmdir; $d->mkdir; my @files = map({my $f = $d + $_; $f->touch; $f} qw(bar baz foo)); (my $subdir = $d / 'zonk')->mkdir; push(@files, $subdir); is_deeply([sort $d->list], [@files], 'list'); is((sort $d->list)[-1], $d/'zonk'); my $it = $d->lister; my @got; while(my $f = $it->()) { push(@got, $f); } is_deeply([sort @got], [@files], 'lister'); $d->remove; } { my $d = File::Fu->dir('tmp.' . $$); $d->e and $d->rmdir; $d->mkdir(0400); is($d->stat->mode & 07777, 0400) or die; $d->chmod(0700); is($d->chdir, './'); chdir('..') or die "oh no!"; $d->remove; } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/slurp.t000555000764000764 102112153041214 15663 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $d = File::Fu->dir->temp_dir('tmp.'); my $f = $d + 'file'; is($f->basename, 'file'); my $fh = $f->open('>'); print $fh "foo\nbar\n"; close($fh) or die "cannot write '$f' $!"; ok($f->e); my @lines = $f->read; is_deeply(\@lines, ["foo\n", "bar\n"], 'slurp array'); is($f->read, "foo\nbar\n", 'slurp scalar'); # TODO something where File::Slurp is not loaded # (probably in another test file and messing with @INC) # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/finder.t000555000764000764 137312153041214 15777 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $topdir = File::Fu->dir('tmp.' . $$); END { $topdir->remove; } $topdir->subdir('foo')->subdir('bar')->subdir('baz')->create; $topdir->file('file.1')->touch; $topdir->file('file.2')->touch; $topdir->subdir('foo')->file('file.3')->touch; $topdir->subdir('foo')->file('file.4')->touch; ($topdir/'foo'/'bar'/'baz' + 'file.5')->touch; ($topdir/'foo'/'bar'/'baz' + 'file.6')->touch; { my @files = $topdir->find(sub {1}); is(scalar(@files), 9, 'find') or die join("\n", @files); my $finder = $topdir->finder(sub {1}); my @got; while(defined(my $p = $finder->())) { $p or next; push(@got, $p); } is(scalar(@got), 9, 'finder'); } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/temp.t000555000764000764 231512153041214 15472 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More qw(no_plan); use File::Fu; my $tmp = File::Fu->dir->temp_dir('tmp.'); can_ok($tmp, 'basename'); can_ok($tmp, 'dirname'); is($tmp->dirname, './'); like($tmp->basename, qr/^tmp\./); eval {$tmp /= "foo"}; like($@, qr/^cannot mutate/); my $subdir = $tmp / 'foo'; ok(! $subdir->isa('File::Fu::Dir::Temp')); { my $fn; { my $fh = File::Fu->dir->temp_file; $fn = $fh->name; is($fn->dirname, File::Fu->dir); ok($fn->e); ok(-e $fn); $fn = "$fn"; } ok(! -e $fn, 'gone'); } { my $fn; { my $fh = File::Fu->temp_file('foo'); $fn = $fh->name; like($fn->basename, qr/^foo/); is($fn->dirname, File::Fu->tmp); ok($fn->e); ok(-e $fn); $fn = "$fn"; } ok(! -e $fn, 'gone'); } { # write+do my @stuff = ("thbbt\n", "xo094auc\n", "\n \n...ee\n"); my $n; is(scalar( File::Fu->temp_file->write(@stuff)->do(sub { $n = ''.$_->name; ok(-e $n); $_->name->read }) ), join('',@stuff), "write temp file"); ok(not(-e $n), "$n gone"); } { my $x = File::Fu->temp_file; $x->write("..."); eval {$x->write("\n")}; like(($@||''), qr/^write\(\) on closed tempfile/); } # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/t/dirlinks.t000555000764000764 325712153041214 16352 0ustar00ewilhelmewilhelm000000000000#!/usr/bin/perl use warnings; use strict; use Test::More no_plan =>; use File::Fu; my $tempdir = File::Fu->temp_dir; $tempdir->chdir; my $this = File::Fu->dir('this')->mkdir; # simply creating a link { my $link = $this->symlink('foo'); ok($link); ok($link->l); ok($link->e); $link->unlink; ok(! $link->e, 'gone'); ok($this->e); } # links don't have to point to existing directories { my $none = File::Fu->dir('bah'); my $link = $none->symlink('deal'); isa_ok($link, 'File::Fu::Dir'); ok($link->l); ok(! $link->e, 'nothing there'); $link->unlink; ok(! $link->l); } # make sure we can pass inputs a few ways { my $dir = File::Fu->dir("dir")->mkdir; my $link = File::Fu->dir("what")->symlink($dir / 'link'); ok(! $link->e); ok($link->l, 'is a link'); $link->unlink; $link = File::Fu->dir("what")->symlink('dir/link'); ok($link->l, 'is a link'); $link->unlink; $link = File::Fu->dir("what")->symlink('dir/link/'); ok($link->l, 'is a link'); $link->unlink; $dir->rmdir; } # relative { my $dir = File::Fu->dir("dir")->mkdir; my $link = $this->relative_symlink($dir / 'whee'); ok($link->l); ok($link->e); ok($link->d); my $lfile = $link + 'file'; $lfile->touch; my $file = $this + 'file'; ok($file->e, 'exists'); $file->unlink; ok(! $lfile->e, 'gone'); $link->unlink; $dir->rmdir; } # relative where there is no depth involved { my $link = $this->relative_symlink('whee'); ok($link->e); ok($link->l); ok($link->d); my $lfile = $link + 'file'; $lfile->touch; my $file = $this + 'file'; ok($file->e, 'exists'); $file->unlink; ok(! $lfile->e, 'gone'); $link->unlink; } $this->rmdir; # vim:ts=2:sw=2:et:sta File-Fu-v0.0.8/lib000755000764000764 012153041214 14502 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/lib/File000755000764000764 012153041214 15361 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/lib/File/Fu.pm000444000764000764 2140112153041214 16444 0ustar00ewilhelmewilhelm000000000000package File::Fu; $VERSION = v0.0.8; use warnings; use strict; use Carp; =head1 NAME File::Fu - file and directory objects =head1 SYNOPSIS The directory constructor: use File::Fu; my $dir = File::Fu->dir("bar"); print "$dir\n"; # 'bar/' my $file = $dir + 'bar.txt'; print "$file\n"; # 'bar/bar.txt' my $d2 = $dir % 'baz'; # 'barbaz/' my $d3 = $dir / 'bat'; # 'bar/bat/' my $file2 = $dir / 'bat' + 'foo.txt'; # 'bar/bat/foo.txt' The file constructor: my $file = File::Fu->file("foo"); $file->e and warn "$file exists"; $file->l and warn "$file is a link"; warn "file is in ", $file->dir; =head1 ABOUT This class provides the toplevel interface to File::Fu directory and file objects, with operator overloading which allows precise path composition and support for most builtin methods, as well as creation of temporary files/directories, finding files, and more. The interface and style are quite different than the perl builtins or File::Spec. The syntax is concise. Errors are thrown with croak(), so you never need to check a return code. =cut use Cwd (); use File::Fu::File; use File::Fu::Dir; use File::Spec (); use constant dir_class => 'File::Fu::Dir'; use constant file_class => 'File::Fu::File'; =head1 Constructors The actual objects are in the 'Dir' and 'File' sub-namespaces. =head2 dir my $dir = File::Fu->dir($path); See L =cut sub dir { my $package = shift; $package or croak("huh?"); # also as a function call unless($package and $package->isa(__PACKAGE__)) { unshift(@_, $package); $package = __PACKAGE__; } $package->dir_class->new(@_); } # end subroutine dir definition ######################################################################## =head2 file my $file = File::Fu->file($path); See L =cut sub file { my $package = shift; # also as a function call unless($package->isa(__PACKAGE__)) { unshift(@_, $package); $package = __PACKAGE__; } $package->file_class->new(@_); } # end subroutine file definition ######################################################################## =head1 Class Constants =head2 tmp Your system's '/tmp/' directory (or equivalent of that.) my $dir = File::Fu->tmp; =cut { my $tmp; # XXX needs locking? sub tmp { my $package = shift; $tmp and return($tmp); return($tmp = $package->dir(File::Spec->tmpdir)); }} ######################################################################## =head2 home User's $HOME directory. my $dir = File::Fu->home; =cut { my $home; # XXX needs locking! sub home { my $package = shift; $home and return($home); return($home = $package->dir($ENV{HOME})); }} # end subroutine home definition ######################################################################## =head2 program_name The absolute name of your program. This will be relative from the time File::Fu was loaded. It dies if the name is '-e'. my $prog = File::Fu->program_name; If File::Fu was loaded after a chdir and the $0 was relative, calling program_name() throws an error. (Unless you set $0 correctly before requiring File::Fu.) =head2 program_dir Returns what typically corresponds to program_name()->dirname, but just the compile-time cwd() when $0 is -e/-E. my $dir = File::Fu->program_dir; =cut { # fun startup stuff and various logic: my $prog = $0; my $name_sub; my $dir_sub; if(lc($prog) eq '-e') { my $prog_dir = Cwd::cwd(); $dir_sub = eval(qq(sub {shift->dir("$prog_dir")})); $name_sub = eval(qq(sub {croak("program_name => '$prog'")})); } else { if(-e $prog) { my $prog_name = __PACKAGE__->file($prog)->absolutely; my $prog_dir = $prog_name->dirname; $name_sub = eval(qq(sub {shift->file('$prog_name')})); $dir_sub = eval(qq(sub {shift->dir('$prog_dir')})); } else { # runtime error $dir_sub = sub {croak("$prog not found => no program_dir known")}; $name_sub = sub {croak("$prog not found => no program_name known")}; } } *program_name = $name_sub; *program_dir = $dir_sub; } # program_name/program_dir ######################################################################## =head1 Class Methods =head2 THIS_FILE A nicer way to say __FILE__. my $file = File::Fu->THIS_FILE; =cut sub THIS_FILE { my $package = shift; my $name = (caller)[1]; return $package->file($name); } # end subroutine THIS_FILE definition ######################################################################## =head2 cwd The current working directory. my $dir = File::Fu->cwd; =cut sub cwd { my $package = shift; defined(my $ans = Cwd::cwd()) or croak("cwd() failed"); return $package->dir($ans); } # end subroutine cwd definition ######################################################################## =head2 which Returns File::Fu::File objects of ordered candidates for $name found in the path. my @prog = File::Fu->which($name) or die "cannot find $name"; If called in scalar context, returns a single File::Fu::File object or throws an error if no candidates were found. my $prog = File::Fu->which($name); =cut sub which { my $package = shift; croak("must have an argument") unless(@_); my ($what) = @_; require File::Which; if(wantarray) { return map({$package->file($_)} File::Which::which($what)); } else { my $found = scalar(File::Which::which($what)) or croak("cannot locate '$what' in PATH"); return $package->file($found); } } # which ############################################################## =head1 Temporary Directories and Files These class methods call the corresponding File::Fu::Dir methods on the value of tmp(). That is, you get a temporary file/dir in the '/tmp/' directory. =head2 temp_dir my $dir = File::Fu->temp_dir; =cut sub temp_dir { my $package = shift; $package->tmp->temp_dir(@_); } # end subroutine temp_dir definition ######################################################################## =head2 temp_file my $handle = File::Fu->temp_file; =cut sub temp_file { my $package = shift; $package->tmp->temp_file(@_); } # end subroutine temp_file definition ######################################################################## =head1 Operators If you choose not to use the overloaded operators, you can just say C<$obj-Estringify()> or "$obj" whenever you want to drop the object-y nature and treat the path as a string. The operators can be convenient for building-up path names, but you probably don't want to think of them as "math on filenames", because they are nothing like that. The '+' and '/' operators only apply to directory objects. op method mnemonic -- ---------------- -------------------- + $d->file($b) ............. plus (not "add") / $d->subdir($b) ........... slash (not "divide") The other operators apply to both files and directories. op method mnemonic -- ---------------- -------------------- %= $p->append($b) ........... mod(ify) % $p->clone->append($b) &= $p->map(sub{...}) ........ invoke subref & $p->clone->map(sub {...}) Aside: It would be more natural to use C<.=> as append(), but the way perl compiles C<"$obj foo"> into C<$obj . " foo"> makes it impossible to do the right thing because the lines between object and string are too ambiguous. =head1 Subclassing You may wish to subclass File:Fu and override the dir_class() and/or file_class() class methods to point to your own Dir/File subclasses. my $class = 'My::FileFu'; my $dir = $class->dir("foo"); See L and L for more info. =head2 dir_class File::Fu->dir_class # File::Fu::Dir =head2 file_class File::Fu->file_class # File::Fu::File =head1 See Also L if I need to explain my motivations. L, from which many an idea was taken. L, L, L, L, L, L, L, L, L. =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # vi:ts=2:sw=2:et:sta 1; File-Fu-v0.0.8/lib/File/Fu000755000764000764 012153041214 15733 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/lib/File/Fu/File.pm000444000764000764 3367012153041214 17336 0ustar00ewilhelmewilhelm000000000000package File::Fu::File; $VERSION = v0.0.8; use warnings; use strict; use Carp; use IO::File (); =head1 NAME File::Fu::File - a filename object =head1 SYNOPSIS use File::Fu; my $file = File::Fu->file("path/to/file"); $file %= '.extension'; $file->e and warn "$file exists"; $file->l and warn "$file is a link to ", $file->readlink; =cut use base 'File::Fu::Base'; use Class::Accessor::Classy; lv 'file'; ro 'dir'; aka dir => 'dirname', 'parent'; no Class::Accessor::Classy; #use overload (); =head1 Constructor =head2 new my $file = File::Fu::File->new($path); my $file = File::Fu::File->new(@path); =cut sub new { my $package = shift; my $class = ref($package) || $package; my $self = {$class->_init(@_)}; bless($self, $class); return($self); } # end subroutine new definition ######################################################################## =head2 new_direct my $file = File::Fu::File->new_direct( dir => $dir_obj, file => $name ); =cut sub new_direct { my $package = shift; my $class = ref($package) || $package; my $self = {@_}; bless($self, $class); return($self); } # end subroutine new_direct definition ######################################################################## =head1 Class Constants =head2 dir_class Return the corresponding dir class for this file object. Default: L. my $dc = $class->dir_class; =head2 is_dir Always false for a file. =head2 is_file Always true for a file. =cut use constant dir_class => 'File::Fu::Dir'; use constant is_dir => 0; use constant is_file => 1; ######################################################################## =for internal head2 _init my %fields = $class->_init(@_); =cut sub _init { my $class = shift; my @dirs = @_ or croak("file must have a name"); my $file = pop(@dirs); if($file =~ m#/#) { croak("strange mix: ", join(',', @_, $file)) if(@dirs); my %p = $class->dir_class->_init($file); @dirs = @{$p{dirs}}; $file = pop(@dirs); } return(dir => $class->dir_class->new(@dirs), file => $file); } # end subroutine _init definition ######################################################################## =head1 Parts =head2 basename Returns a new object representing only the file part of the name. my $obj = $file->basename; =cut sub basename { my $self = shift; $self->new($self->file); } # end subroutine basename definition ######################################################################## =head1 Methods =head2 stringify my $string = $file->stringify; =cut sub stringify { my $self = shift; my $dir = $self->dir; #warn "stringify(..., $_[1], $_[2])"; #Carp::carp("stringify ", overload::StrVal($self), " ($self->{file})"); $dir = $dir->is_cwd ? '' : $dir->stringify; return($dir . $self->file); } # end subroutine stringify definition ######################################################################## =head2 append Append a string only to the filename part. $file->append('.gz'); $file %= '.gz'; (Yeah... I tried to use .=, but overloading hates me.) =cut sub append { my $self = shift; my ($tail) = @_; $self->file .= $tail; $self; } # end subroutine append definition ######################################################################## =head2 map $file->map(sub {...}); $file &= sub {...}; =cut sub map :method { my $self = shift; my ($sub) = shift; local $_ = $self->file; $sub->(); $self->file = $_; $self; } # end subroutine map definition ######################################################################## =head2 absolute Get an absolute name (without checking the filesystem.) my $abs = $file->absolute; =cut sub absolute { my ($self) = shift; return($self->dir->absolute->file($self->file)); } # end subroutine absolutely definition ######################################################################## =head2 absolutely Get an absolute name (resolved on the filesytem.) my $abs = $file->absolutely; =cut sub absolutely { my $self = shift; return($self->dir->absolutely->file($self->file)); } # end subroutine absolutely definition ######################################################################## =head1 Doing stuff =head2 open Open the file with $mode ('<', 'r', '>', 'w', etc) -- see L. my $fh = $file->open($mode, $permissions); Throws an error if anything goes wrong or if the resulting filehandle happens to be a directory. =cut # TODO should probably have our own filehandle so we can close in the # destructor and croak there too? sub open :method { my $self = shift; my $fh = IO::File->new($self, @_) or croak("cannot open '$self' $!"); -d $fh and croak("$self is a directory"); return($fh); } # end subroutine open definition ######################################################################## =head2 sysopen Interface to the sysopen() builtin. The value of $mode is a text string joined by '|' characters which must be valid O_* constants from Fcntl. my $fh = $file->sysopen($mode, $perms); =cut sub sysopen :method { my $self = shift; my ($mode, $perms) = @_; my $m = 0; foreach my $w (split /\|/, $mode) { my $word = 'O_' . uc($w); my $x = Fcntl->can($word) or croak("'$word' not found in Fcntl"); $m |= $x->(); } my $fh = IO::Handle->new; sysopen($fh, "$self", $m, $perms || 0666) or croak("error on sysopen '$self' - $!"); return($fh); } # sysopen ############################################################ =head2 piped_open Opens a read pipe. The file is appended to @command. my $fh = $file->piped_open(@command); Example: useless use of cat. my $fh = $file->piped_open('cat'); This interface is deprecated (maybe) because it is limited to commands which take the $file as the last argument. See run() for the way of the future. =cut sub piped_open { my $self = shift; my (@command) = @_; # TODO some way to decide where self goes in @command push(@command, $self); # TODO closing STDIN and such before the fork? # TODO here is where we need our own filehandle object again my $pid = open(my $fh, '-|', @command) or croak("cannot exec '@command' $!"); return($fh); } # end subroutine piped_open definition ######################################################################## =head2 run Treat C<$file> as a program and execute a pipe open. my $fh = $file->run(@args); If called in void context, runs C with autodie semantics and multi-arg form (suppresses shell interpolation.) $file->run(@args); No special treatment is made for whether $file is relative or not (the underlying C/C will search your path.) Use File::Fu->which() to get an absolute path beforehand. File::Fu->which('ls')->run('-l'); =cut sub run { my $self = shift; my (@args) = @_; if(defined wantarray) { # TODO use IPC::Run my $fh = IO::Handle->new; my @command = ($self, @args); my $pid = open($fh, '-|', @command) or croak("cannot exec '@command' $!"); return($fh); } else { my $ret = system {$self} $self, @args; croak("error executing '$self'", $ret < 0 ? " $!" : '') if($ret); } } # run ################################################################ =head2 touch Update the timestamp of a file (or create it.) $file->touch; =cut sub touch { my $self = shift; if(-e $self) { $self->utime(time); } else { $self->open('>'); } return($self); } # end subroutine touch definition ######################################################################## =head2 mkfifo my $file = $file->mkfifo($mode); =cut sub mkfifo :method { my $self = shift; my ($mode) = @_; $mode ||= 0700; require POSIX; POSIX::mkfifo("$self", $mode) or croak("mkfifo '$self' failed $!"); return $self; } # mkfifo ############################################################# =head2 link my $link = $file->link($name); =cut sub link :method { my $self = shift; my ($name) = @_; link($self, $name) or croak("link '$self' to '$name' failed $!"); return($self->new($name)); } # end subroutine link definition ######################################################################## =head2 symlink my $link = $file->symlink($linkname); Note that symlinks are relative to where they live. my $dir = File::Fu->dir("foo"); my $file = $dir+'file'; # $file->symlink($dir+'link'); is a broken link my $link = $file->basename->symlink($dir+'link'); =head2 relative_symlink See L. =cut sub symlink :method { my $self = shift; my ($name) = @_; symlink($self, $name) or croak("symlink '$self' to '$name' failed $!"); return($self->new($name)); } # end subroutine symlink definition ######################################################################## # TODO # my $link = $file->dwimlink(absolute|relative|samedir => $linkname); =head2 unlink $file->unlink; =cut sub unlink :method { my $self = shift; unlink("$self") or croak("unlink '$self' failed $!"); } # end subroutine unlink definition ######################################################################## =head2 remove A forced unlink (chmod the file if it is not writable.) $file->remove; =cut sub remove { my $self = shift; $self->chmod(0200) unless($self->w); $self->unlink; } # remove ############################################################# =head2 readlink my $to = $file->readlink; =cut sub readlink :method { my $self = shift; my $name = readlink($self); defined($name) or croak("cannot readlink '$self' $!"); return($self->new($name)); } # end subroutine readlink definition ######################################################################## ######################################################################## { # a closure for this variable my $has_slurp; =head2 read Read the entire file into memory (or swap!) my @lines = $file->read; my $file = $file->read; If File::Slurp is available, options to read_file will be passed along. See L. =cut sub read :method { my $self = shift; my @args = @_; $has_slurp ||= eval {require File::Slurp; 1} || -1; if($has_slurp > 0) { local $Carp::CarpLevel = 1; return(File::Slurp::read_file("$self", @args, err_mode => 'croak')); } else { croak("must have File::Slurp for fancy reads") if(@args); my $fh = $self->open; local $/ = wantarray ? $/ : undef; return(<$fh>); } } # end subroutine read definition ######################################################################## =head2 write Write the file's contents. Returns the $file object for chaining. $file = $file->write($content); If File::Slurp is available, $content may be either a scalar, scalar ref, or array ref. $file->write($content, %args); =cut sub write { my $self = shift; my ($content, @args) = @_; $has_slurp ||= eval {require File::Slurp; 1} || -1; if($has_slurp > 0) { local $Carp::CarpLevel = 1; File::Slurp::write_file("$self", {@args, err_mode => 'croak'}, $content ); } else { croak("must have File::Slurp for fancy writes") if(@args or ref($content)); my $fh = $self->open('>'); print $fh $content; close($fh) or croak("write '$self' failed: $!"); } return $self; } # end subroutine write definition ######################################################################## } # File::Slurp closure ######################################################################## =head2 copy Copies $file to $dest (which can be a file or directory) and returns the name of the new file as an object. my $new = $file->copy($dest); Note that if $dest is already a File object, that existing object will be returned. =cut sub copy { my $self = shift; my ($dest) = shift; my (%opts) = @_; # decide if this is file-to-dir or file-to-file if(-d $dest) { $dest = $self->dir_class->new($dest)->file($self->basename); } else { $dest = $self->new($dest) unless(ref($dest)); } if($dest->e) { croak("'$dest' and '$self' are the same file") if($self->is_same($dest)); } # TODO here's another good reason to have our own filehandle object: # This fh-copy should be in there. my $ifh = $self->open; my $ofh = $dest->open('>'); binmode($_) for($ifh, $ofh); while(1) { my $buf; defined(my $r = sysread($ifh, $buf, 1024)) or croak("sysread failed $!"); $r or last; # why did File::Copy::copy do it like this? for(my $t = my $w = 0; $w < $r; $w += $t) { $t = syswrite($ofh, $buf, $r - $w, $w) or croak("syswrite failed $!"); } } close($ofh) or croak("write '$dest' failed: $!"); # TODO some form of rollback? # TODO handle opts #if($opts{preserve}) { # # TODO chmod/chown and such # $dest->utime($self->stat->mtime); #} return($dest); } # copy ############################################################### =head2 move my $new = $file->move($dest); =cut sub move { my $self = shift; my $new = $self->copy(@_); # TODO can use rename? $self->unlink; return($new); } # move ############################################################### ######################################################################## =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut require File::Fu; # vi:ts=2:sw=2:et:sta 1; File-Fu-v0.0.8/lib/File/Fu/Base.pm000444000764000764 1744412153041214 17332 0ustar00ewilhelmewilhelm000000000000package File::Fu::Base; $VERSION = v0.0.8; use warnings; use strict; use Carp; use File::stat (); =head1 NAME File::Fu::Base - nothing to see here =head1 SYNOPSIS =cut use overload ( '=' => sub {shift->clone(@_)}, '""' => 'stringify', '%=' => 'append', '%' => sub {shift->clonedo('append', @_)}, # can't overload s/// or accomplish anything with prototypes '&' => sub {shift->clonedo('map', @_)}, '&=' => 'map', cmp => sub {"$_[0]" cmp "$_[1]"}, # invalid methods '-' => sub {shift->error('-')}, '*' => sub {shift->error('*')}, '~' => sub {~ shift->stringify}, nomethod => sub {shift->error($_[2])}, ); =head2 clone my $obj = $obj->clone; =cut sub clone { my $self = shift; my $clone = {%$self}; bless($clone, ref($self)); #carp("clone the ", overload::StrVal($self)); foreach my $item (values(%$clone)) { my $ref = ref($item) or next; if($ref eq 'ARRAY') { #warn "clone [@$item]\n"; $item = [@$item]; } elsif($ref eq 'HASH') { $item = {%$item}; } elsif(eval {$item->can('clone')}) { $item = $item->clone } else { croak("cannot deref $item"); } } #carp("now ", overload::StrVal($clone)); return($clone); } # end subroutine clone definition ######################################################################## =head2 clonedo $clone = $self->clonedo($action, @args); =cut sub clonedo { my $self = shift; my ($action, $arg, $rev) = @_; #carp("clonedo $action", $rev ? ' backwards' : ''); if($rev) { return($arg . $self->stringify) if($action eq 'append'); croak("$action is invalid in that order"); } # perl doesn't know how to stringify # TODO how can I tell when this is just a quoted string? #if($action eq 'append' and $arg =~ m/\n/) { return($self->stringify . $arg); } $self = $self->clone; $self->$action($arg); #carp("now ", overload::StrVal($self)); return($self); } # end subroutine clonedo definition ######################################################################## =head2 error $package->error($op); =cut sub error { my $self = shift; my ($op) = @_; croak("$op is not a valid op for a ", ref($self), " object"); } # end subroutine error definition ######################################################################## =head1 Filetests =head2 r w x o R W X O e z s f d l p S b c t u g k T B M A C See perldoc -f -x =cut foreach my $test (split(//, 'rwxoRWXOezsfdlpSbctugkTBMAC')) { my $subref = eval("sub {-$test shift}"); $@ and croak("I broke this -- $@"); no strict 'refs'; *{"$test"} = $subref; } =head1 File::Spec stuff This needs to be redone. =cut use File::Spec; # GRR =head2 is_absolute =cut sub is_absolute { # XXX this is immutable, no? File::Spec->file_name_is_absolute($_[0]->stringify); } =head2 relative Get a relative name. my $rel = $abs->relative; Also, with optional relative-to directory: my $rel = $abs->relative($to); =cut sub relative { my $self = shift; my $base = shift; return $self->new(File::Spec->abs2rel($self->stringify, defined($base) ? "$base" : () )); } =head2 relative_to Same as relative(), but requires the $dir argument. my $rel = $abs->relative_to($dir); =cut sub relative_to { my $self = shift; my $base = shift or croak('relative_to() requires a $dir'); return $self->relative($base); } =head2 resolve Fully resolve any symlinks; my $path = $path->resolve; =cut sub resolve { my $self = shift; while(1) { return $self unless($self->l); my $to = $self->readlink; return $to if($to->is_absolute); $self = $self->new($self->dirname . $to); } } # end subroutine resolve definition ######################################################################## =head2 relative_symlink Where $path and $linkname are both relative to the current directory. $path->relative_symlink($linkname); =cut sub relative_symlink { my $self = shift; my ($link) = @_; my $rel = $self->relative($self->new($link)->dirname); return($rel->symlink($link)); } # end subroutine relative_symlink definition ######################################################################## =head2 utime Update the file timestamps. $file->utime($atime, $mtime); Optionally, set both to the same time. $file->utime($time); Also see touch(). =cut sub utime { my $self = shift; @_ or croak("not enough arguments to utime()"); my $at = shift; my $mt = @_ ? shift(@_) : $at; if($self->is_dir) { $self = $self->bare; } utime($at, $mt, $self) or croak("cannot utime '$self' $!"); } # end subroutine utime definition ######################################################################## =head2 chmod $path->chmod($mode); =cut sub chmod :method { my $self = shift; my ($mode) = @_; chmod($mode, "$self") or croak("cannot chmod '$self' $!"); } # end subroutine chmod definition ######################################################################## =head2 rename Calls the builtin rename() on the $path and returns a new object with that name. $path = $path->rename($newname); =cut sub rename :method { my $self = shift; my ($name) = @_; rename($self, $name) or croak("cannot rename '$self' to '$name' $!"); return($self->new($name)); } # end subroutine rename definition ######################################################################## =head1 Stat Object The stat() and lstat() methods both return a File::stat object. =head2 stat my $st = $obj->stat; =cut sub stat { my $self = shift; my $st = File::stat::stat("$self") or croak("cannot stat '$self' $!"); return($st); } # end subroutine stat definition ######################################################################## =head2 lstat Same as stat, but does not dereference symlinks. my $st = $obj->lstat; =cut sub lstat { my $self = shift; if($self->is_dir and $self->l) { $self = $self->bare; } my $st = File::stat::lstat("$self") or croak("cannot lstat '$self' $!"); return($st); } # end subroutine lstat definition ######################################################################## =head2 is_same Returns true if the two paths are the same. This is by string equality, then (if both paths exist) by device+inode equality. $bool = $path->is_same($other); =cut sub is_same { my $self = shift; my ($other) = @_; unless(ref $other) { my $proto = ($self->is_file and $other =~ m#/$#) ? $self->dir_class : $self; $other = $proto->new($other); } return(1) if($self eq $other); return(0) if($self->is_dir != $other->is_dir); my $n = 0; # TODO just check absolutely? # this currently probably misses non-existent files where the dirname # resolves to the same location. my ($s1, $s2) = map({eval {$_->stat}} $self, $other); return(0) unless($s1 and $s2); return( $s1->dev eq $s2->dev and $s1->ino eq $s2->ino ); } # end subroutine is_same definition ######################################################################## =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # vi:ts=2:sw=2:et:sta 1; File-Fu-v0.0.8/lib/File/Fu/Dir.pm000444000764000764 5425012153041214 17172 0ustar00ewilhelmewilhelm000000000000package File::Fu::Dir; $VERSION = v0.0.8; use warnings; use strict; use Carp; use Cwd (); use File::Path (); # for now use File::Fu::Dir::Temp; use File::Fu::File::Temp; =head1 NAME File::Fu::Dir - a directoryname object =head1 SYNOPSIS use File::Fu; my $dir = File::Fu->dir("path/to/dir"); $dir->e and warn "$dir exists"; $dir->l and warn "$dir is a link to ", $dir->readlink; foreach my $entry ($dir->list) { warn $entry . ': ' . $entry->stat->size, "\n" if($entry->f); } =cut use base 'File::Fu::Base'; use overload ( '+' => 'file', '/' => 'subdir', ); =head1 Constructor =head2 new my $dir = File::Fu::Dir->new($path); my $dir = File::Fu::Dir->new(@path); =cut sub new { my $package = shift; my $class = ref($package) || $package; my $self = {$class->_init(@_)}; bless($self, $class); return($self); } # end subroutine new definition ######################################################################## =head1 Class Constants/Methods =head2 file_class Return the corresponding file class for this dir object. Default: L. my $fc = $class->file_class; =head2 is_dir Always true for a directory. =head2 is_file Always false for a directory. =cut use constant top_class => 'File::Fu'; use constant file_class => 'File::Fu::File'; use constant token_class => 'File::Fu::Dir::Token'; use constant is_dir => 1; use constant is_file => 0; ######################################################################## =head2 temp_dir_class Class for L objects. Default: L. my $class = File::Fu::Dir->temp_dir_class; =cut sub temp_dir_class { my $package = shift; my $class = ref($package) . '::Temp'; $class = __PACKAGE__ . '::Temp' unless($class->can('new')); return($class); } # end subroutine temp_dir_class definition ######################################################################## =head2 temp_file_class my $class = File::Fu::Dir->temp_file_class; =cut sub temp_file_class { my $package = shift; my $class = $package->file_class . '::Temp'; $class = __PACKAGE__->file_class.'::Temp' unless($class->can('new')); return($class); } # end subroutine temp_file_class definition ######################################################################## =for internal head2 _init my %fields = $class->_init(@_); =cut sub _init { my $class = shift; @_ or return(dirs => ['.']); my $dirs = [map({ $_ eq '' ? ('') : split(/\/+/, $_) } @_)]; @$dirs or $dirs = ['']; # XXX return(dirs => $dirs); } # end subroutine _init definition ######################################################################## =head1 Methods =head2 stringify my $string = $dir->stringify; =cut sub stringify { my $self = shift; #Carp::carp("stringify", overload::StrVal($self)); #defined($self->{dirs}) or croak("how did this happen?"); my @dirs = @{$self->{dirs}}; #warn "I'm (", join(',', @{$self->{dirs}}), ")"; @dirs or return('/'); # TODO volume join('/', @dirs, ''); # always a trailing slash } # end subroutine stringify definition ######################################################################## =begin shutup_pod_cover =head2 l =end shutup_pod_cover =cut *l = sub {-l shift->bare}; =head2 bare Stringify without the trailing slash/assertion. my $str = $self->bare; The trailing slash causes trouble when trying to address a symlink to a directory via a dir object. Thus, C<-l $dir> doesn't work, but C<$dir-El> does the same thing as C<-l $dir-Ebare>. =cut sub bare { my $self = shift; my @dirs = @{$self->{dirs}}; @dirs or return('/'); # TODO volume join('/', @dirs); # always a trailing slash } # end subroutine bare definition ######################################################################## =head2 file Create a filename object with $dir as its parent. my $file = $dir->file($filename); my $file = $dir + $filename; =cut sub file { my $self = shift; my ($name, $rev) = @_; $rev and croak("bah"); # filename might have dir parts if($name =~ m#/#) { my $bit = $self->file_class->new($name); return $self->file_class->new_direct( dir => $self->subdir($bit->dirname), file => $bit->basename ); } return($self->file_class->new_direct(dir => $self, file => $name)); } # end subroutine file definition ######################################################################## =head2 append Append a string only to the last directory part. $dir->append('.tmp'); $dir %= "something"; =cut sub append { my $self = shift; my ($bit, $rev) = @_; $rev and return($bit . "$self"); # stringify is out-of-order #carp("appending $bit"); #$self = $self->clone; $self->{dirs}[-1] .= $bit; return($self); } # end subroutine append definition ######################################################################## =head2 subdir $newdir = $dir->subdir('foo'); $newdir = $dir / 'foo'; =cut sub subdir { my $self = shift; my ($name, $rev) = @_; $rev and croak("bah"); # appending to cwd means starting over return($self->new($name)) if($self->is_cwd); my %newbits = $self->_init($name); $self = $self->clone; push(@{$self->{dirs}}, @{$newbits{dirs}}); $self; } # end subroutine subdir definition ######################################################################## =head2 part Returns the $i'th part of the directory list. my $part = $dir->part($i); $dir->part(-1) is like $dir->basename, but not an object and not quite like File::Basename::basename() when it comes to the / directory. =cut sub part { my $self = shift; my ($i) = @_; return($self->{dirs}[$i]); } # end subroutine part definition ######################################################################## =head2 end Shorthand for part(-1); =cut sub end {shift->part(-1)}; =head2 parts Retrieve the inner list of the directory's parts. my @parts = $dir->parts; my @parts = $dir->parts(0..2); The returned parts will be contiguous, but the request can be a two-element list (and can also start or end at negative indices.) my @parts = $dir->parts(3, 7); my @parts = $dir->parts(3, -1); my @parts = $dir->parts(-5, -1); =cut sub parts { my $self = shift; my @want = @_; @want or return(@{$self->{dirs}}); if(@want == 2) { foreach my $end (@want) { $end = $#{$self->{dirs}} + 1 + $end if($end < 0); } if($want[0] > $want[1]) { croak("first endpoint '$want[0]' is after last '$want[1]'"); } @want = $want[0]..$want[1]; } # TODO else check contiguity? return(@{$self->{dirs}}[@want]); } # end subroutine parts definition ######################################################################## =head2 slice Returns a new dir object as the return of parts(). my $slice = $dir->slice(0); my $slice = $dir->slice(0,3); =cut sub slice { my $self = shift; $self = $self->clone; @{$self->{dirs}} = $self->parts(@_); return($self); } # end subroutine slice definition ######################################################################## =head2 map Execute a callback on each part of $dir. The sub should modify $_ (yes, this is slightly unlike the map() builtin.) If $parts is defined as an integer or array reference of integers, it will be treated as a slice on the directory parts to which the map should be applied. $dir->map(sub {...}, [@parts]); $dir &= sub {s/foo$/bar/}; So, to modify only the first directory part: $dir->map(sub {s/foo$/bar/}, 0); =cut sub map :method { my $self = shift; my ($sub, $parts) = @_; my @parts = defined($parts) ? (ref($parts) ? @$parts : $parts) : 0..($#{$self->{dirs}}); # TODO actually use the parts() code for this # warn "@parts"; foreach my $dir (@{$self->{dirs}}[@parts]) { local $_ = $dir; $sub->(); $dir = $_; } $self; } # end subroutine map definition ######################################################################## =head1 Properties =head2 is_cwd True if the $dir represents a relative (e.g. '.') directory. my $bool = $dir->is_cwd; =cut sub is_cwd { my $self = shift; my @dirs = @{$self->{dirs}}; return(@dirs == 1 and $dirs[0] eq '.'); } # end subroutine is_cwd definition ######################################################################## =for note dirname('.') and basename('.') are both '.' -- also true for '/' =head2 basename Returns the last part of the path as a Dir object. my $bit = $dir->basename; =cut sub basename { my $self = shift; return($self->new($self->{dirs}[-1])); } # end subroutine basename definition ######################################################################## =head2 dirname Returns the parent parts of the path as a Dir object. my $parent = $dir->dirname; =cut sub dirname { my $self = shift; $self = $self->clone; my $dirs = $self->{dirs}; if(@$dirs == 1 and $dirs->[0] eq '') { return($self->new('/')); } pop(@$dirs); @$dirs or return($self->new); return($self); } # end subroutine dirname definition ######################################################################## =head2 absolute Get an absolute name (without checking the filesystem.) my $abs = $dir->absolute; =cut sub absolute { my $self = shift; return $self if $self->is_absolute; return $self->new(File::Spec->rel2abs($self->stringify)); } # end subroutine absolute definition ######################################################################## =head2 absolutely Get an absolute path (resolved on filesystem, so it must exist.) my $abs = $dir->absolutely; =cut sub absolutely { my $self = shift; my $res = Cwd::abs_path($self->stringify); defined($res) or croak("$self absolutely() not found"); return $self->new($res); } # end subroutine absolutely definition ######################################################################## =head1 Doing stuff =head2 open Calls opendir(), but throws an error if it fails. my $dh = $dir->open; Returns a directory handle, for e.g. readdir(). my @files = map({$dir + $_} grep({$_ !~ m/^\./} readdir($dh))); =cut sub open :method { my $self = shift; opendir(my $dh, "$self") or die "cannot opendir '$self' $!"; return($dh); } # end subroutine open definition ######################################################################## =head2 touch Update the timestamp of a directory (croak if it doesn't exist.) $dir->touch; =cut sub touch { my $self = shift; $self->utime(time); } # end subroutine touch definition ######################################################################## =head2 list my @paths = $dir->list(all => 1); =cut sub list { my $self = shift; map({my $d = $self/$_; -d $d ? $d : $self+$_} $self->contents(@_)); } # end subroutine list definition ######################################################################## =head2 lister my $subref = $dir->lister(all => 1); =cut sub lister { my $self = shift; my $csub = $self->iterate_contents(@_); my $sub = sub { $csub or return(); while(defined(my $n = $csub->())) { my $d = $self/$n; return(-d $d->bare ? $d : $self+$n) } $csub = undef; return(); }; return($sub); } # end subroutine lister definition ######################################################################## =head2 contents Equivelant to readdir. With the 'all' option true, returns hidden names too (but not the '.' and '..' entries.) The return values are strings, not File::Fu objects. my @names = $dir->contents(all => 1); =cut sub contents { my $self = shift; (@_ % 2) and croak('odd number of items in options hash'); my %opts = @_; my $dh = $self->open; # XXX needs more cross-platformness $opts{all} and return(grep({$_ !~ m/^\.{1,2}$/} readdir($dh))); return(grep({$_ !~ m/^\./} readdir($dh))); } # end subroutine contents definition ######################################################################## =head2 iterate_contents Returns a subref which will iterate over the directory's contents. my $subref = $dir->iterate_contents(all => 1); =cut sub iterate_contents { my $self = shift; (@_ % 2) and croak('odd number of items in options hash'); my %opts = @_; my $all = $opts{all}; my $dh = $self->open; # XXX needs more cross-platformness return sub { $dh or return(); while(defined(my $n = readdir($dh))) { if($all) { return($n) unless($n =~ m/^\.{1,2}$/); } else { return($n) unless($n =~ m/^\./); } } $dh = undef; return(); }; } # end subroutine iterate_contents definition ######################################################################## =head2 find Recursively search a directory's contents for items where the supplied coderef (matcher) returns true. The matcher will be invoked with the topic (C<$_>) set to the current path (which is either a Dir or File object.) The return values will be File::Fu::File or File::Fu::Dir objects. If your matcher returns true, the topic will be added to the return values. my @paths = $dir->find(sub {m/foo/}); There is a knob for controlling recursion, which is the first argument to your matcher. my @pm_files = $dir->find(sub { return shift->prune if($_->is_dir and $_->part(-1) =~ m/^\.svn$/); $_->is_file and m/\.pm$/; }); =over =item Differences from File::Find::find() The invocant (C<$dir> aka '.') is not examined (because this is an object method, there is always only one starting path.) The topic is always absolute in the same sense as the invocant. That is, if C<$dir> is relative to your current directory, then so are the topics and return values. If C<$dir> is absolute, so are the topics and return values. =back =cut sub find { my $self = shift; my @return; my $finder = $self->finder(@_); while(defined(my $ans = $finder->())) { $ans or next; push(@return, $ans); } return(@return); } # end subroutine find definition ######################################################################## =head2 finder Returns an iterator for finding files. This iterator does everything that find() does, but returns one path at a time. Returns undef when exhausted and zero when it is just taking a break. my $subref = $dir->finder(sub {$_->is_file and $_->file =~ m/foo/}); This allows a non-blocking find. while(defined(my $path = $subref->())) { $path or next; # 0 means 'not done yet' # do something with $path (a file or dir object) } The find() method is implemented in terms of finder() by simply using a while() loop and accumulating the return values. =cut sub finder { my $self = shift; my ($matcher, @opt) = @_; # TODO support options e.g. loops my %opt = (all => 1); my $reader; my @stack; my $it = sub { my $loops = 0; FIND: { $reader ||= $self->lister(all => $opt{all}); $loops++; if(defined(my $path = $reader->())) { if($path->is_dir and not $path->l) { push(@stack, [$self, $reader]); ($self, $reader) = ($path, undef); } local $_ = $path; my $ok = $matcher->(my $knob = File::Fu::Dir::FindKnob->new); if($knob->pruned and not $path->l) { # XXX nofollow assumption ($self, $reader) = @{pop(@stack)}; } if($ok) { return($path); } redo FIND if($loops < 50); return(0); # no match, but continue } else { @stack or return(); ($self, $reader) = @{pop(@stack)}; redo FIND; } } }; return($it); } # end subroutine finder definition ######################################################################## =head2 The FindKnob object The FindKnob object allows you to control the next steps of find(). Methods called on it will typically return a value which also makes sense as a return value of your matcher sub. Thus the idiom: $dir->find(sub {return shift->prune if(condition); ...}) =over =item prune Do not recurse into the topic directory. Returns false. =back =cut BEGIN { package File::Fu::Dir::FindKnob; use Class::Accessor::Classy; with 'new'; ri 'pruned'; no Class::Accessor::Classy; sub prune {shift->set_pruned(1); 0} } # File::Fu::Dir::FindKnob ######################################################################## =head2 mkdir Create the directory or croak with an error. $dir->mkdir; $dir->mkdir(0700); =cut sub mkdir :method { my $self = shift; if(@_) { my $mode = shift(@_); mkdir($self, $mode) or croak("cannot mkdir('$self', $mode) $!"); } else { mkdir($self) or croak("cannot mkdir('$self') $!"); } return($self); } # end subroutine mkdir definition ######################################################################## =head2 create Create the directory, with parents if needed. $dir->create; =cut sub create { my $self = shift; # TODO pass mode, but the verbose parameter is silly (should have been # a callback or something -- so we'll end up reimplementing mkpath?) File::Path::mkpath("$self"); return($self); } # end subroutine create definition ######################################################################## =head2 rmdir Remove the directory or croak with an error. $dir->rmdir; =cut sub rmdir :method { my $self = shift; rmdir($self) or croak("cannot rmdir('$self') $!"); } # end subroutine rmdir definition ######################################################################## =head2 remove Remove the directory and all of its children. $dir->remove; =cut sub remove { my $self = shift; my $dir = $self->stringify; File::Path::rmtree($dir); -e $dir and croak("rmtree failed"); # XXX rmtree is buggy } # end subroutine remove definition ######################################################################## =head2 unlink $link->unlink; =cut sub unlink :method { my $self = shift; $self->l or croak("not a link"); unlink($self->bare) or croak("unlink '$self' failed $!"); } # end subroutine unlink definition ######################################################################## =head2 symlink Create a symlink which points to $dir. my $link = $dir->symlink($linkname); Note that symlinks are relative to where they live, so if $dir is a relative path, it must be relative to $linkname. =cut sub symlink :method { my $self = shift; my ($name) = @_; $name =~ s#/$##; # stringify and strip symlink($self, $name) or croak("symlink '$self' to '$name' failed $!"); return($self->new($name)); } # end subroutine symlink definition ######################################################################## =head2 readlink my $to = $file->readlink; =cut sub readlink :method { my $self = shift; my $name = readlink($self->bare); defined($name) or croak("cannot readlink '$self' $!"); return($self->new($name)); } # end subroutine readlink definition ######################################################################## =head1 Changing Directories =head2 chdir Change to the directory in self, returning a new '.' directory object. $dir = $dir->chdir; =cut sub chdir :method { my $self = shift; chdir($self) or croak("cannot chdir '$self' $!"); # should return a new '.' object ? return($self->new('.')); } # end subroutine chdir definition ######################################################################## =head2 chdir_for Change to $dir and run the given subroutine. The sub will be passed a './' directory object. $dir->chdir_for(sub {...}); =cut sub chdir_for { my $self = shift; my ($sub) = @_; # we need to guarantee that we return, so we must implement the scoped # version in order to implement the wrapper. my $dot = $self->chdir_local; # XXX bah. the $token binds weirdly in 5.6.2 return $sub->($self->new('.')); } # end subroutine chdir_for definition ######################################################################## =head2 chdir_local Change to $dir, but return to the current cwd when $token goes out of scope. my $token = $self->chdir_local; =cut sub chdir_local { my $self = shift; my $now = $self->top_class->cwd; $self->chdir; return $self->token_class->new->return_to($now); } # end subroutine chdir_local definition ######################################################################## BEGIN { package File::Fu::Dir::Token; our @ISA = qw('File::Fu::Dir); sub return_to { my $self = shift(@_); $self->{return_to} = shift(@_) or croak("invalid usage"); return($self); } sub DESTROY { my $ret = shift->{return_to} or return; $ret->chdir; } } ######################################################################## =head1 Temporary Directories and Files These methods use the $dir object as a parent location for the temp path. To use your system's global temp space (e.g. '/tmp/'), just replace $dir with 'File::Fu'. File::Fu->temp_dir; # '/tmp/' File::Fu->dir->temp_dir; # './' File::Fu->dir("foo")->temp_dir; # 'foo/' File::Fu->temp_file; # '/tmp/' File::Fu->dir->temp_file; # './' File::Fu->dir("foo")->temp_file; # 'foo/' =head2 temp_dir Return a temporary directory in $dir. my $dir = $dir->temp_dir; =cut sub temp_dir { my $self = shift; $self->temp_dir_class->new($self, @_); } # end subroutine temp_dir definition ######################################################################## =head2 temp_file Return a filehandle to a temporary file in $dir. my $handle = $dir->temp_file; =cut sub temp_file { my $self = shift; $self->temp_file_class->new($self, @_); } # end subroutine temp_file definition ######################################################################## =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut require File::Fu; # vi:ts=2:sw=2:et:sta 1; File-Fu-v0.0.8/lib/File/Fu/File000755000764000764 012153041214 16612 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/lib/File/Fu/File/Temp.pm000444000764000764 1264412153041214 20241 0ustar00ewilhelmewilhelm000000000000package File::Fu::File::Temp; $VERSION = v0.0.8; use warnings; use strict; use Carp; =head1 NAME File::Fu::File::Temp - temporary files =head1 SYNOPSIS use File::Fu; my $handle = File::Fu->temp_file; =cut use File::Temp (); # XXX should be File::Fu::Handle; #use base 'File::Temp'; =head2 new The directory argument is required, followed by an optional template argument and/or flags. The template may contain some number of 'X' characters. If it does not, ten of them will be appended. my $handle = File::Fu::File::Temp->new($dir, 'foo'); my $file = $handle->name; By default, the file will be deleted when the handle goes out of scope. Optionally, it may be deleted immediately after creation or just not deleted. my $handle = File::Fu::File::Temp->new($dir, 'foo', -secure); my $handle = File::Fu::File::Temp->new($dir, -noclean); # also $handle->noclean; =over =item -secure Delete the named file (if the OS supports it) immediately after opening. Calling name() on this sort of handle throws an error. =item -nocleanup Don't attempt to remove the file when the $handle goes out of scope. =back =cut { my %argmap = ( secure => [], nocleanup => [UNLINK => 0], ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my ($dir, $send, $opt) = $class->_validate(\%argmap, @_); my ($self, $fn); if($opt->{secure}) { $self = File::Temp::tempfile(@$send); $class .= '::HasNoFileName'; } else { ($self, $fn) = File::Temp::tempfile(@$send); ${*$self} = $dir->file_class->new($fn); } %{*$self} = %$opt; bless($self, $class); return($self); }} # end subroutine new definition ######################################################################## =for internal head2 _validate my ($dir, $send, $opt) = $class->_validate(\%map, @_); =cut sub _validate { my $class = shift; my %argmap = %{shift(@_)}; my ($dir, @opt) = @_; croak("invalid directory '$dir' ") unless(eval {$dir->can('e')} and $dir->e); my @send; my %opt; for(my $i = 0; $i < @opt; $i++) { ($opt[$i] =~ s/^-//) or next; my ($key) = splice(@opt, $i, 1); $i--; my $do = $argmap{$key} or croak("invalid argument '$key'"); push(@send, @$do); $opt{$key} = 1; } if(@opt) { my $template = shift(@opt); croak("invalid arguments '@opt'") if(@opt); $template .= $class->XXX unless($template =~ m/X/); # XXX File::Temp specific unshift(@send, $template); } $opt{auto_delete} = ! delete($opt{nocleanup}); push(@send, DIR => "$dir"); return($dir, \@send, \%opt); } # end subroutine _validate definition ######################################################################## =head2 name my $file_obj = $handle->name; =cut sub name { my $self = shift; return(${*$self}); } # end subroutine name definition ######################################################################## =head2 nocleanup Disable autocleanup. $handle->nocleanup; =cut sub nocleanup { my $self = shift; my %opt = %{*$self}; $opt{auto_delete} = 0; } # end subroutine nocleanup definition ######################################################################## =head2 write Write @content to the tempfile and close it. $handle = $handle->write(@content); =cut sub write { my $self = shift; my (@content) = @_; do { local $SIG{__WARN__} = sub { # ugh my $x = shift; local $Carp::Level = 1; if($x =~ m/^print\(\) on closed filehandle/) { croak("write() on closed tempfile"); } my $file = __FILE__; $x =~ s/ at \Q$file\E .*\n//; warn Carp::shortmess($x); }; print $self @content; }; close($self) or croak("write '" . $_->name . "' failed: $!"); return $self; } # write ############################################################## =head2 do Execute subref with $handle as $_. If you chain this with the constructor, the destructor cleanup will happen immediately after sub has returned. my @x = $handle->do(sub {something($_->name); ...}); =cut sub do { my $self = shift; my ($sub) = @_; local $_ = $self; return $sub->(); } # do ################################################################# =head2 DESTROY Called automatically when the handle goes out of scope. $handle->DESTROY; =cut sub DESTROY { my $self = shift; my %opt = %{*$self}; return if($opt{secure} or ! $opt{auto_delete}); $self->name->unlink; } # end subroutine DESTROY definition ######################################################################## =head2 XXX Constant representing a chunk of X characters. =cut use constant XXX => 'X'x10; =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # vi:ts=2:sw=2:et:sta 1; File-Fu-v0.0.8/lib/File/Fu/Dir000755000764000764 012153041214 16451 5ustar00ewilhelmewilhelm000000000000File-Fu-v0.0.8/lib/File/Fu/Dir/Temp.pm000444000764000764 1023612153041214 20073 0ustar00ewilhelmewilhelm000000000000package File::Fu::Dir::Temp; $VERSION = v0.0.8; use warnings; use strict; use Carp; =begin shutup_pod_cover =head2 clone =head2 XXX =end shutup_pod_cover =cut use File::Fu::File::Temp; *_validate = \&File::Fu::File::Temp::_validate; *XXX = \&File::Fu::File::Temp::XXX; =head1 NAME File::Fu::Dir::Temp - temporary directories =head1 SYNOPSIS use File::Fu; my $dir = File::Fu->temp_dir; =cut use base 'File::Fu::Dir'; use overload ( '/=' => sub {croak("cannot mutate a temp dir");}, '+=' => sub {croak("cannot mutate a temp dir");}, '.=' => sub {croak("cannot mutate a temp dir");}, ); use Class::Accessor::Classy; rs auto_delete => \(my $set_auto_delete); rs dir_class => \(my $set_dir_class); no Class::Accessor::Classy; =head2 new my $tmp = File::Fu::Dir::Temp->new($dir, 'foo'); =cut { my %argmap = ( nocleanup => [UNLINK => 0], ); sub new { my $proto = shift; if(ref($proto)) { # calls to subdir, etc are not in the Temp class return $proto->dir_class->new(@_); } my $class = $proto; #warn "args: @_"; my ($dir, $send, $opt) = $class->_validate(\%argmap, @_); #warn "dir: $dir"; #warn "opts: @$send"; my $temp = File::Temp::tempdir(@$send); my $self = $class->SUPER::new($temp); $self->{$_} = $opt->{$_} for(keys(%$opt)); $self->{_proc} = $$; $self->$set_dir_class(ref($dir)); return($self); }} # end subroutine new definition ######################################################################## =head2 chdir my $dir = $dir->chdir; =cut sub chdir { my $self = shift; my $dir = $self->SUPER::chdir; $dir->{temp_parent} = $self; return($dir); } # chdir ############################################################## =for nit head2 clone Because clone doesn't call new :-/ $not_temp = $temp->clone; =cut sub clone { my $self = shift; $self = $self->SUPER::clone; bless($self, $self->dir_class); } # end subroutine clone definition ######################################################################## =head2 rename Same as the base rename(), but promotes the temp dir to a regular Dir object (prevents any cleanup actions.) $temp = $temp->rename($dest); =cut sub rename { my $self = shift; my $dir_class = $self->dir_class; $self = $self->SUPER::rename(@_); bless($self, $dir_class); return($self); } # TODO File::Fu->temp_dir->chdir causes immediate deletion? =head2 nocleanup Disable autocleanup. $dir->nocleanup; =cut # XXX I think this is named wrong -- should probably just delete the # dependency on File::Temp because I can't override that END block sub nocleanup { my $self = shift; $self->$set_auto_delete(0); } # end subroutine nocleanup definition ######################################################################## =head2 DESTROY Called automatically when the object goes out of scope. $dir->DESTROY; =cut sub DESTROY { my $self = shift; # ? should this have: return unless($self->auto_delete); # forked case return unless($$ == $self->{_proc}); my $string = $self->stringify; #warn "DESTROY ($$/$self->{_proc}", $string; # XXX overload stops operating in DESTROY()? die("$string does not exist") unless(-d $string); $self->remove; $self->{auto_delete} = 0; } # end subroutine DESTROY definition ######################################################################## =head1 AUTHOR Eric Wilhelm @ http://scratchcomputing.com/ =head1 BUGS If you found this module on CPAN, please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. If you pulled this development version from my /svn/, please contact me directly. =head1 COPYRIGHT Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved. =head1 NO WARRANTY Absolutely, positively NO WARRANTY, neither express or implied, is offered with this software. You use this software at your own risk. In case of loss, no person or entity owes you anything whatsoever. You have been warned. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # vi:ts=2:sw=2:et:sta 1;