« back to all changes in this revision
Viewing changes to lib/File/Fu/Dir.pm
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Jonathan Yu
- Date: 2009-07-25 07:10:04 UTC
- Revision ID: james.westby@ubuntu.com-20090725071004-p7cmwowvpf0f7k81
Tags: upstream-0.0.6
Import upstream version 0.0.6
- files added:
- lib
- lib/File
- lib/File/Fu
- lib/File/Fu/Dir
- lib/File/Fu/File
- t
added
removed
lib/File/Fu/Dir.pm
1
package File::Fu::Dir;
2
$VERSION = v0.0.6;
3
4
use warnings;
5
use strict;
6
use Carp;
7
8
use Cwd ();
9
10
use File::Path (); # for now
11
12
use File::Fu::Dir::Temp;
13
use File::Fu::File::Temp;
14
15
=head1 NAME
16
17
File::Fu::Dir - a directoryname object
18
19
=head1 SYNOPSIS
20
21
use File::Fu;
22
23
my $dir = File::Fu->dir("path/to/dir");
24
$dir->e and warn "$dir exists";
25
26
$dir->l and warn "$dir is a link to ", $dir->readlink;
27
28
foreach my $entry ($dir->list) {
29
warn $entry . ': ' . $entry->stat->size, "\n"
30
if($entry->f);
31
}
32
33
=cut
34
35
use base 'File::Fu::Base';
36
37
use overload (
38
'+' => 'file',
39
'/' => 'subdir',
40
);
41
42
=head1 Constructor
43
44
=head2 new
45
46
my $dir = File::Fu::Dir->new($path);
47
48
my $dir = File::Fu::Dir->new(@path);
49
50
=cut
51
52
sub new {
53
my $package = shift;
54
my $class = ref($package) || $package;
55
my $self = {$class->_init(@_)};
56
bless($self, $class);
57
return($self);
58
} # end subroutine new definition
59
########################################################################
60
61
=head1 Class Constants/Methods
62
63
=head2 file_class
64
65
Return the corresponding file class for this dir object.
66
67
my $fc = $class->file_class;
68
69
=head2 is_dir
70
71
Always true for a directory.
72
73
=head2 is_file
74
75
Always false for a directory.
76
77
=cut
78
79
use constant top_class => 'File::Fu';
80
use constant file_class => 'File::Fu::File';
81
use constant token_class => 'File::Fu::Dir::Token';
82
use constant is_dir => 1;
83
use constant is_file => 0;
84
85
########################################################################
86
87
=head2 temp_dir_class
88
89
my $class = File::Fu::Dir->temp_dir_class;
90
91
=cut
92
93
sub temp_dir_class {
94
my $package = shift;
95
my $class = ref($package) . '::Temp';
96
$class = __PACKAGE__ . '::Temp' unless($class->can('new'));
97
return($class);
98
} # end subroutine temp_dir_class definition
99
########################################################################
100
101
=head2 temp_file_class
102
103
my $class = File::Fu::Dir->temp_file_class;
104
105
=cut
106
107
sub temp_file_class {
108
my $package = shift;
109
my $class = $package->file_class . '::Temp';
110
$class = __PACKAGE__->file_class.'::Temp' unless($class->can('new'));
111
return($class);
112
} # end subroutine temp_file_class definition
113
########################################################################
114
115
=for internal head2 _init
116
my %fields = $class->_init(@_);
117
118
=cut
119
120
sub _init {
121
my $class = shift;
122
@_ or return(dirs => ['.']);
123
my $dirs = [map({
124
$_ eq '' ? ('') : split(/\/+/, $_)
125
} @_)];
126
@$dirs or $dirs = ['']; # XXX
127
return(dirs => $dirs);
128
} # end subroutine _init definition
129
########################################################################
130
131
=head1 Methods
132
133
=head2 stringify
134
135
my $string = $dir->stringify;
136
137
=cut
138
139
sub stringify {
140
my $self = shift;
141
#Carp::carp("stringify", overload::StrVal($self));
142
#defined($self->{dirs}) or croak("how did this happen?");
143
my @dirs = @{$self->{dirs}};
144
#warn "I'm (", join(',', @{$self->{dirs}}), ")";
145
@dirs or return('/');
146
# TODO volume
147
join('/', @dirs, ''); # always a trailing slash
148
} # end subroutine stringify definition
149
########################################################################
150
151
=begin shutup_pod_cover
152
153
=head2 l
154
155
=end shutup_pod_cover
156
157
=cut
158
159
*l = sub {-l shift->bare};
160
161
=head2 bare
162
163
Stringify without the trailing slash/assertion.
164
165
my $str = $self->bare;
166
167
The trailing slash causes trouble when trying to address a symlink to a
168
directory via a dir object. Thus, C<-l $dir> doesn't work, but
169
C<$dir->l> does.
170
171
=cut
172
173
sub bare {
174
my $self = shift;
175
my @dirs = @{$self->{dirs}};
176
@dirs or return('/');
177
# TODO volume
178
join('/', @dirs); # always a trailing slash
179
} # end subroutine bare definition
180
########################################################################
181
182
=head2 file
183
184
Create a filename object with $dir as its parent.
185
186
my $file = $dir->file($filename);
187
188
my $file = $dir + $filename;
189
190
=cut
191
192
sub file {
193
my $self = shift;
194
my ($name, $rev) = @_;
195
$rev and croak("bah");
196
197
# filename might have dir parts
198
if($name =~ m#/#) {
199
my $bit = $self->file_class->new($name);
200
return $self->file_class->new_direct(
201
dir => $self->subdir($bit->dirname),
202
file => $bit->basename
203
);
204
}
205
206
return($self->file_class->new_direct(dir => $self, file => $name));
207
} # end subroutine file definition
208
########################################################################
209
210
=head2 append
211
212
Append a string only to the last directory part.
213
214
$dir->append('.tmp');
215
216
$dir %= "something";
217
218
=cut
219
220
sub append {
221
my $self = shift;
222
my ($bit, $rev) = @_;
223
224
$rev and return($bit . "$self"); # stringify is out-of-order
225
#carp("appending $bit");
226
#$self = $self->clone;
227
$self->{dirs}[-1] .= $bit;
228
return($self);
229
} # end subroutine append definition
230
########################################################################
231
232
=head2 subdir
233
234
$newdir = $dir->subdir('foo');
235
236
$dir /= 'foo';
237
238
=cut
239
240
sub subdir {
241
my $self = shift;
242
my ($name, $rev) = @_;
243
$rev and croak("bah");
244
245
# appending to cwd means starting over
246
return($self->new($name)) if($self->is_cwd);
247
248
my %newbits = $self->_init($name);
249
$self = $self->clone;
250
push(@{$self->{dirs}}, @{$newbits{dirs}});
251
$self;
252
} # end subroutine subdir definition
253
########################################################################
254
255
=head2 part
256
257
Returns the $i'th part of the directory list.
258
259
my $part = $dir->part($i);
260
261
$dir->part(-1) is like $dir->basename, but not an object and not quite
262
like File::Basename::basename() when it comes to the / directory.
263
264
=cut
265
266
sub part {
267
my $self = shift;
268
my ($i) = @_;
269
return($self->{dirs}[$i]);
270
} # end subroutine part definition
271
########################################################################
272
273
=head2 end
274
275
Shorthand for part(-1);
276
277
=cut
278
279
sub end {shift->part(-1)};
280
281
=head2 parts
282
283
Retrieve the inner list of the directory's parts.
284
285
my @parts = $dir->parts;
286
287
my @parts = $dir->parts(0..2);
288
289
The returned parts will be contiguous, but the request can be a
290
two-element list (and can also end at -1.)
291
292
my @parts = $dir->parts(3, 7);
293
294
my @parts = $dir->parts(3, -1);
295
296
=cut
297
298
sub parts {
299
my $self = shift;
300
my @want = @_;
301
@want or return(@{$self->{dirs}});
302
if(@want == 2) {
303
if($want[1] < 0) {
304
$want[1] = $#{$self->{dirs}};
305
}
306
@want = $want[0]..$want[1];
307
}
308
# TODO else check contiguity?
309
return(@{$self->{dirs}}[@want]);
310
} # end subroutine parts definition
311
########################################################################
312
313
=head2 slice
314
315
Returns a new dir object as the return of parts().
316
317
my $slice = $dir->slice(0);
318
319
my $slice = $dir->slice(0,3);
320
321
=cut
322
323
sub slice {
324
my $self = shift;
325
$self = $self->clone;
326
@{$self->{dirs}} = $self->parts(@_);
327
return($self);
328
} # end subroutine slice definition
329
########################################################################
330
331
=head2 map
332
333
Execute a callback on each part of $dir. The sub should modify $_ (yes,
334
this is slightly unlike the map() builtin.)
335
336
If $parts is defined as an integer or array reference of integers, it
337
will be treated as a slice on the directory parts to which the map
338
should be applied.
339
340
$dir->map(sub {...}, [@parts]);
341
342
$dir &= sub {s/foo$/bar/};
343
344
So, to modify only the first directory part:
345
346
$dir->map(sub {s/foo$/bar/}, 0);
347
348
=cut
349
350
sub map :method {
351
my $self = shift;
352
my ($sub, $parts) = @_;
353
my @parts = defined($parts) ? (ref($parts) ? @$parts : $parts) :
354
0..($#{$self->{dirs}});
355
# TODO actually use the parts() code for this
356
# warn "@parts";
357
foreach my $dir (@{$self->{dirs}}[@parts]) {
358
local $_ = $dir;
359
$sub->();
360
$dir = $_;
361
}
362
$self;
363
} # end subroutine map definition
364
########################################################################
365
366
=head1 Properties
367
368
=head2 is_cwd
369
370
True if the $dir represents a relative (e.g. '.') directory.
371
372
my $bool = $dir->is_cwd;
373
374
=cut
375
376
sub is_cwd {
377
my $self = shift;
378
379
my @dirs = @{$self->{dirs}};
380
return(@dirs == 1 and $dirs[0] eq '.');
381
} # end subroutine is_cwd definition
382
########################################################################
383
384
=for note
385
dirname('.') and basename('.') are both '.' -- also true for '/'
386
387
=head2 basename
388
389
Returns the last part of the path as a Dir object.
390
391
my $bit = $dir->basename;
392
393
=cut
394
395
sub basename {
396
my $self = shift;
397
return($self->new($self->{dirs}[-1]));
398
} # end subroutine basename definition
399
########################################################################
400
401
=head2 dirname
402
403
Returns the parent parts of the path as a Dir object.
404
405
my $parent = $dir->dirname;
406
407
=cut
408
409
sub dirname {
410
my $self = shift;
411
$self = $self->clone;
412
my $dirs = $self->{dirs};
413
if(@$dirs == 1 and $dirs->[0] eq '') {
414
return($self->new('/'));
415
}
416
pop(@$dirs);
417
@$dirs or return($self->new);
418
return($self);
419
} # end subroutine dirname definition
420
########################################################################
421
422
=head2 absolute
423
424
Get an absolute name (without checking the filesystem.)
425
426
my $abs = $dir->absolute;
427
428
=cut
429
430
sub absolute {
431
my $self = shift;
432
return $self if $self->is_absolute;
433
return $self->new(File::Spec->rel2abs($self->stringify));
434
} # end subroutine absolute definition
435
########################################################################
436
437
=head2 absolutely
438
439
Get an absolute path (resolved on filesystem, so it must exist.)
440
441
my $abs = $dir->absolutely;
442
443
=cut
444
445
sub absolutely {
446
my $self = shift;
447
my $res = Cwd::abs_path($self->stringify);
448
defined($res) or croak("$self absolutely() not found");
449
return $self->new($res);
450
} # end subroutine absolutely definition
451
########################################################################
452
453
=head1 Doing stuff
454
455
=head2 open
456
457
Calls opendir(), but throws an error if it fails.
458
459
my $dh = $dir->open;
460
461
Returns a directory handle, for e.g. readdir().
462
463
my @files = map({$dir + $_} grep({$_ !~ m/^\./} readdir($dh)));
464
465
=cut
466
467
sub open :method {
468
my $self = shift;
469
470
opendir(my $dh, "$self") or die "cannot opendir '$self' $!";
471
return($dh);
472
} # end subroutine open definition
473
########################################################################
474
475
=head2 touch
476
477
Update the timestamp of a directory (croak if it doesn't exist.)
478
479
$dir->touch;
480
481
=cut
482
483
sub touch {
484
my $self = shift;
485
$self->utime(time);
486
} # end subroutine touch definition
487
########################################################################
488
489
=head2 list
490
491
my @paths = $dir->list(all => 1);
492
493
=cut
494
495
sub list {
496
my $self = shift;
497
498
map({my $d = $self/$_; -d $d ? $d : $self+$_} $self->contents(@_));
499
} # end subroutine list definition
500
########################################################################
501
502
=head2 lister
503
504
my $subref = $dir->lister(all => 1);
505
506
=cut
507
508
sub lister {
509
my $self = shift;
510
my $csub = $self->iterate_contents(@_);
511
my $sub = sub {
512
$csub or return();
513
while(defined(my $n = $csub->())) {
514
my $d = $self/$n;
515
return(-d $d->bare ? $d : $self+$n)
516
}
517
$csub = undef;
518
return();
519
};
520
return($sub);
521
} # end subroutine lister definition
522
########################################################################
523
524
=head2 contents
525
526
Equivelant to readdir. With the 'all' option true, returns hidden names
527
too (but not the '.' and '..' entries.)
528
529
The return values are strings, not File::Fu objects.
530
531
my @names = $dir->contents(all => 1);
532
533
=cut
534
535
sub contents {
536
my $self = shift;
537
(@_ % 2) and croak('odd number of items in options hash');
538
my %opts = @_;
539
my $dh = $self->open;
540
# XXX needs more cross-platformness
541
$opts{all} and return(grep({$_ !~ m/^\.{1,2}$/} readdir($dh)));
542
return(grep({$_ !~ m/^\./} readdir($dh)));
543
} # end subroutine contents definition
544
########################################################################
545
546
=head2 iterate_contents
547
548
Returns a subref which will iterate over the directory's contents.
549
550
my $subref = $dir->iterate_contents(all => 1);
551
552
=cut
553
554
sub iterate_contents {
555
my $self = shift;
556
(@_ % 2) and croak('odd number of items in options hash');
557
my %opts = @_;
558
my $all = $opts{all};
559
my $dh = $self->open;
560
# XXX needs more cross-platformness
561
return sub {
562
$dh or return();
563
while(defined(my $n = readdir($dh))) {
564
if($all) {
565
return($n) unless($n =~ m/^\.{1,2}$/);
566
}
567
else {
568
return($n) unless($n =~ m/^\./);
569
}
570
}
571
$dh = undef;
572
return();
573
};
574
} # end subroutine iterate_contents definition
575
########################################################################
576
577
=head2 find
578
579
Not the same as File::Find::find().
580
581
my @files = $dir->find(sub {m/foo/});
582
583
=cut
584
585
sub find {
586
my $self = shift;
587
588
my @return;
589
my $finder = $self->finder(@_);
590
while(defined(my $ans = $finder->())) {
591
$ans or next;
592
push(@return, $ans);
593
}
594
return(@return);
595
} # end subroutine find definition
596
########################################################################
597
598
=head2 finder
599
600
Returns an iterator for finding files.
601
602
my $subref = $dir->finder(sub {$_->is_file and $_->file =~ m/foo/});
603
604
This allows a non-blocking find.
605
606
while(defined(my $path = $subref->())) {
607
$path or next; # 0 means 'not done yet'
608
# do something with $path (is a file or dir object)
609
}
610
611
And there is a knob:
612
613
my $finder = $dir->finder(sub {
614
return shift->prune
615
if($_->is_dir and $_->part(-1) =~ m/^\.svn$/);
616
$_->is_file and m/\.pm$/;
617
});
618
619
=cut
620
621
sub finder {
622
my $self = shift;
623
my ($matcher, @opt) = @_;
624
625
my %opt = (all => 1);
626
627
my $reader;
628
my @stack;
629
my $it = sub {
630
my $loops = 0;
631
FIND: {
632
$reader ||= $self->lister(all => $opt{all});
633
$loops++;
634
if(defined(my $path = $reader->())) {
635
if($path->is_dir and not $path->l) {
636
push(@stack, [$self, $reader]);
637
($self, $reader) = ($path, undef);
638
}
639
local $_ = $path;
640
#warn " check $path\n";
641
my $ok = $matcher->(my $knob = File::Fu::Dir::FindKnob->new);
642
if($knob->pruned) {
643
($self, $reader) = @{pop(@stack)};
644
}
645
if($ok) {
646
return($path);
647
}
648
redo FIND if($loops < 50);
649
return(0); # no match, but continue
650
}
651
else {
652
@stack or return();
653
($self, $reader) = @{pop(@stack)};
654
redo FIND;
655
}
656
}
657
};
658
return($it);
659
} # end subroutine finder definition
660
########################################################################
661
662
BEGIN {
663
package File::Fu::Dir::FindKnob;
664
use Class::Accessor::Classy;
665
with 'new';
666
ri 'pruned';
667
no Class::Accessor::Classy;
668
sub prune {shift->set_pruned(1); 0}
669
} # File::Fu::Dir::FindKnob
670
########################################################################
671
672
=head2 mkdir
673
674
Create the directory or croak with an error.
675
676
$dir->mkdir;
677
678
$dir->mkdir(0700);
679
680
=cut
681
682
sub mkdir :method {
683
my $self = shift;
684
if(@_) {
685
my $mode = shift(@_);
686
mkdir($self, $mode) or croak("cannot mkdir('$self', $mode) $!");
687
}
688
else {
689
mkdir($self) or croak("cannot mkdir('$self') $!");
690
}
691
return($self);
692
} # end subroutine mkdir definition
693
########################################################################
694
695
=head2 create
696
697
Create the directory, with parents if needed.
698
699
$dir->create;
700
701
=cut
702
703
sub create {
704
my $self = shift;
705
# TODO pass mode, but the verbose parameter is silly (should have been
706
# a callback or something -- so we'll end up reimplementing mkpath?)
707
File::Path::mkpath("$self");
708
return($self);
709
} # end subroutine create definition
710
########################################################################
711
712
=head2 rmdir
713
714
Remove the directory or croak with an error.
715
716
$dir->rmdir;
717
718
=cut
719
720
sub rmdir :method {
721
my $self = shift;
722
rmdir($self) or croak("cannot rmdir('$self') $!");
723
} # end subroutine rmdir definition
724
########################################################################
725
726
=head2 remove
727
728
Remove the directory and all of its children.
729
730
$dir->remove;
731
732
=cut
733
734
sub remove {
735
my $self = shift;
736
my $dir = $self->stringify;
737
File::Path::rmtree($dir);
738
-e $dir and croak("rmtree failed"); # XXX rmtree is buggy
739
} # end subroutine remove definition
740
########################################################################
741
742
=head2 unlink
743
744
$link->unlink;
745
746
=cut
747
748
sub unlink :method {
749
my $self = shift;
750
$self->l or croak("not a link");
751
unlink($self->bare) or croak("unlink '$self' failed $!");
752
} # end subroutine unlink definition
753
########################################################################
754
755
=head2 symlink
756
757
Create a symlink which points to $dir.
758
759
my $link = $dir->symlink($linkname);
760
761
Note that symlinks are relative to where they live, so if $dir is a
762
relative path, it must be relative to $linkname.
763
764
=cut
765
766
sub symlink :method {
767
my $self = shift;
768
my ($name) = @_;
769
770
$name =~ s#/$##; # stringify and strip
771
symlink($self, $name) or
772
croak("symlink '$self' to '$name' failed $!");
773
return($self->new($name));
774
} # end subroutine symlink definition
775
########################################################################
776
777
=head2 readlink
778
779
my $to = $file->readlink;
780
781
=cut
782
783
sub readlink :method {
784
my $self = shift;
785
my $name = readlink($self->bare);
786
defined($name) or croak("cannot readlink '$self' $!");
787
return($self->new($name));
788
} # end subroutine readlink definition
789
########################################################################
790
791
=head1 Changing Directories
792
793
794
=head2 chdir
795
796
Change to the directory in self, returning a new '.' directory object.
797
798
$dir = $dir->chdir;
799
800
=cut
801
802
sub chdir :method {
803
my $self = shift;
804
chdir($self) or croak("cannot chdir '$self' $!");
805
# should return a new '.' object ?
806
return($self->new('.'));
807
} # end subroutine chdir definition
808
########################################################################
809
810
=head2 chdir_for
811
812
Change to $dir and run the given subroutine. The sub will be passed a
813
'./' directory object.
814
815
$dir->chdir_for(sub {...});
816
817
=cut
818
819
sub chdir_for {
820
my $self = shift;
821
my ($sub) = @_;
822
# we need to guarantee that we return, so we must implement the scoped
823
# version in order to implement the wrapper.
824
my $dot = $self->chdir_local;
825
# XXX bah. the $token binds weirdly in 5.6.2
826
return $sub->($self->new('.'));
827
} # end subroutine chdir_for definition
828
########################################################################
829
830
=head2 chdir_local
831
832
Change to $dir, but return to the current cwd when $token goes out of
833
scope.
834
835
my $token = $self->chdir_local;
836
837
=cut
838
839
sub chdir_local {
840
my $self = shift;
841
my $now = $self->top_class->cwd;
842
$self->chdir;
843
return $self->token_class->new->return_to($now);
844
} # end subroutine chdir_local definition
845
########################################################################
846
BEGIN {
847
package File::Fu::Dir::Token;
848
our @ISA = qw('File::Fu::Dir);
849
sub return_to {
850
my $self = shift(@_);
851
$self->{return_to} = shift(@_) or croak("invalid usage");
852
return($self);
853
}
854
sub DESTROY { my $ret = shift->{return_to} or return; $ret->chdir; }
855
}
856
########################################################################
857
858
=head1 Temporary Directories and Files
859
860
These methods use the $dir object as a parent location for the temp
861
path. To use your system's global temp space (e.g. '/tmp/'), just
862
replace $dir with 'File::Fu'.
863
864
File::Fu->temp_dir; # '/tmp/'
865
File::Fu->dir->temp_dir; # './'
866
File::Fu->dir("foo")->temp_dir; # 'foo/'
867
868
File::Fu->temp_file; # '/tmp/'
869
File::Fu->dir->temp_file; # './'
870
File::Fu->dir("foo")->temp_file; # 'foo/'
871
872
=head2 temp_dir
873
874
Return a temporary directory in $dir.
875
876
my $dir = $dir->temp_dir;
877
878
=cut
879
880
sub temp_dir {
881
my $self = shift;
882
$self->temp_dir_class->new($self, @_);
883
} # end subroutine temp_dir definition
884
########################################################################
885
886
=head2 temp_file
887
888
Return a filehandle to a temporary file in $dir.
889
890
my $handle = $dir->temp_file;
891
892
=cut
893
894
sub temp_file {
895
my $self = shift;
896
$self->temp_file_class->new($self, @_);
897
} # end subroutine temp_file definition
898
########################################################################
899
900
=head1 AUTHOR
901
902
Eric Wilhelm @ <ewilhelm at cpan dot org>
903
904
http://scratchcomputing.com/
905
906
=head1 BUGS
907
908
If you found this module on CPAN, please report any bugs or feature
909
requests through the web interface at L<http://rt.cpan.org>. I will be
910
notified, and then you'll automatically be notified of progress on your
911
bug as I make changes.
912
913
If you pulled this development version from my /svn/, please contact me
914
directly.
915
916
=head1 COPYRIGHT
917
918
Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved.
919
920
=head1 NO WARRANTY
921
922
Absolutely, positively NO WARRANTY, neither express or implied, is
923
offered with this software. You use this software at your own risk. In
924
case of loss, no person or entity owes you anything whatsoever. You
925
have been warned.
926
927
=head1 LICENSE
928
929
This program is free software; you can redistribute it and/or modify it
930
under the same terms as Perl itself.
931
932
=cut
933
934
require File::Fu;
935
# vi:ts=2:sw=2:et:sta
936
1;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1