« back to all changes in this revision
Viewing changes to lib/File/Fu/Base.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/Base.pm
1
package File::Fu::Base;
2
$VERSION = v0.0.6;
3
4
use warnings;
5
use strict;
6
use Carp;
7
8
use File::stat ();
9
10
=head1 NAME
11
12
File::Fu::Base - nothing to see here
13
14
=head1 SYNOPSIS
15
16
=cut
17
18
use overload (
19
'=' => sub {shift->clone(@_)},
20
'""' => 'stringify',
21
'%=' => 'append',
22
'%' => sub {shift->clonedo('append', @_)},
23
# can't overload s/// or accomplish anything with prototypes
24
'&' => sub {shift->clonedo('map', @_)},
25
'&=' => 'map',
26
cmp => sub {"$_[0]" cmp "$_[1]"},
27
28
# invalid methods
29
'-' => sub {shift->error('-')},
30
'*' => sub {shift->error('*')},
31
nomethod => sub {shift->error($_[2])},
32
);
33
34
=head2 clone
35
36
my $obj = $obj->clone;
37
38
=cut
39
40
sub clone {
41
my $self = shift;
42
my $clone = {%$self};
43
bless($clone, ref($self));
44
#carp("clone the ", overload::StrVal($self));
45
foreach my $item (values(%$clone)) {
46
my $ref = ref($item) or next;
47
if($ref eq 'ARRAY') {
48
#warn "clone [@$item]\n";
49
$item = [@$item];
50
}
51
elsif($ref eq 'HASH') {
52
$item = {%$item};
53
}
54
elsif(eval {$item->can('clone')}) {
55
$item = $item->clone
56
}
57
else {
58
croak("cannot deref $item");
59
}
60
}
61
#carp("now ", overload::StrVal($clone));
62
return($clone);
63
} # end subroutine clone definition
64
########################################################################
65
66
=head2 clonedo
67
68
$clone = $self->clonedo($action, @args);
69
70
=cut
71
72
sub clonedo {
73
my $self = shift;
74
my ($action, $arg, $rev) = @_;
75
#carp("clonedo $action", $rev ? ' backwards' : '');
76
if($rev) {
77
return($arg . $self->stringify) if($action eq 'append');
78
croak("$action is invalid in that order");
79
}
80
81
# perl doesn't know how to stringify
82
# TODO how can I tell when this is just a quoted string?
83
#if($action eq 'append' and $arg =~ m/\n/) { return($self->stringify . $arg); }
84
85
$self = $self->clone;
86
$self->$action($arg);
87
#carp("now ", overload::StrVal($self));
88
return($self);
89
} # end subroutine clonedo definition
90
########################################################################
91
92
=head2 error
93
94
$package->error($op);
95
96
=cut
97
98
sub error {
99
my $self = shift;
100
my ($op) = @_;
101
croak("$op is not a valid op for a ", ref($self), " object");
102
} # end subroutine error definition
103
########################################################################
104
105
=head1 Filetests
106
107
=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
108
109
See perldoc -f -x
110
111
=cut
112
113
foreach my $test (split(//, 'rwxoRWXOezsfdlpSbctugkTBMAC')) {
114
my $subref = eval("sub {-$test shift}");
115
$@ and croak("I broke this -- $@");
116
no strict 'refs';
117
*{"$test"} = $subref;
118
}
119
120
=head1 File::Spec stuff
121
122
This needs to be redone.
123
124
=cut
125
126
use File::Spec; # GRR
127
128
=head2 is_absolute
129
130
=cut
131
132
sub is_absolute {
133
# XXX this is immutable, no?
134
File::Spec->file_name_is_absolute($_[0]->stringify);
135
}
136
137
=head2 relative
138
139
Get a relative name.
140
141
my $rel = $abs->relative;
142
143
Also, with optional relative-to directory:
144
145
my $rel = $abs->relative($to);
146
147
=cut
148
149
sub relative {
150
my $self = shift;
151
my $base = shift;
152
return $self->new(File::Spec->abs2rel($self->stringify,
153
defined($base) ? "$base" : ()
154
));
155
}
156
157
=head2 resolve
158
159
Fully resolve any symlinks;
160
161
my $path = $path->resolve;
162
163
=cut
164
165
sub resolve {
166
my $self = shift;
167
while(1) {
168
return $self unless($self->l);
169
my $to = $self->readlink;
170
return $to if($to->is_absolute);
171
$self = $self->new($self->dirname . $to);
172
}
173
} # end subroutine resolve definition
174
########################################################################
175
176
=head2 relative_symlink
177
178
Where $path and $linkname are both relative to the current directory.
179
180
$path->relative_symlink($linkname);
181
182
=cut
183
184
sub relative_symlink {
185
my $self = shift;
186
my ($link) = @_;
187
188
my $rel = $self->relative($self->new($link)->dirname);
189
return($rel->symlink($link));
190
} # end subroutine relative_symlink definition
191
########################################################################
192
193
=head2 utime
194
195
Update the file timestamps.
196
197
$file->utime($atime, $mtime);
198
199
Optionally, set both to the same time.
200
201
$file->utime($time);
202
203
Also see touch().
204
205
=cut
206
207
sub utime {
208
my $self = shift;
209
@_ or croak("not enough arguments to utime()");
210
my $at = shift;
211
my $mt = @_ ? shift(@_) : $at;
212
if($self->is_dir) {
213
$self = $self->bare;
214
}
215
utime($at, $mt, $self) or croak("cannot utime '$self' $!");
216
} # end subroutine utime definition
217
########################################################################
218
219
=head2 chmod
220
221
$path->chmod($mode);
222
223
=cut
224
225
sub chmod :method {
226
my $self = shift;
227
my ($mode) = @_;
228
229
chmod($mode, "$self") or croak("cannot chmod '$self' $!");
230
} # end subroutine chmod definition
231
########################################################################
232
233
=head1 Stat Object
234
235
The stat() and lstat() methods both return a File::stat object.
236
237
=head2 stat
238
239
my $st = $obj->stat;
240
241
=cut
242
243
sub stat {
244
my $self = shift;
245
my $st = File::stat::stat("$self") or
246
croak("cannot stat '$self' $!");
247
return($st);
248
} # end subroutine stat definition
249
########################################################################
250
251
=head2 lstat
252
253
Same as stat, but does not dereference symlinks.
254
255
my $st = $obj->lstat;
256
257
=cut
258
259
sub lstat {
260
my $self = shift;
261
262
if($self->is_dir and $self->l) {
263
$self = $self->bare;
264
}
265
my $st = File::stat::lstat("$self") or
266
croak("cannot lstat '$self' $!");
267
return($st);
268
} # end subroutine lstat definition
269
########################################################################
270
271
=head2 is_same
272
273
Returns true if the two paths are the same. This is by string equality,
274
then (if both paths exist) by device+inode equality.
275
276
$bool = $path->is_same($other);
277
278
=cut
279
280
sub is_same {
281
my $self = shift;
282
my ($other) = @_;
283
unless(ref $other) {
284
my $proto = ($self->is_file and $other =~ m#/$#) ?
285
$self->dir_class : $self;
286
$other = $proto->new($other);
287
}
288
return(1) if($self eq $other);
289
return(0) if($self->is_dir != $other->is_dir);
290
my $n = 0;
291
# TODO just check absolutely?
292
# this currently probably misses non-existent files where the dirname
293
# resolves to the same location.
294
my ($s1, $s2) = map({eval {$_->stat}} $self, $other);
295
return(0) unless($s1 and $s2);
296
return(
297
$s1->dev eq $s2->dev and
298
$s1->ino eq $s2->ino
299
);
300
} # end subroutine is_same definition
301
########################################################################
302
303
=head1 AUTHOR
304
305
Eric Wilhelm @ <ewilhelm at cpan dot org>
306
307
http://scratchcomputing.com/
308
309
=head1 BUGS
310
311
If you found this module on CPAN, please report any bugs or feature
312
requests through the web interface at L<http://rt.cpan.org>. I will be
313
notified, and then you'll automatically be notified of progress on your
314
bug as I make changes.
315
316
If you pulled this development version from my /svn/, please contact me
317
directly.
318
319
=head1 COPYRIGHT
320
321
Copyright (C) 2008 Eric L. Wilhelm, All Rights Reserved.
322
323
=head1 NO WARRANTY
324
325
Absolutely, positively NO WARRANTY, neither express or implied, is
326
offered with this software. You use this software at your own risk. In
327
case of loss, no person or entity owes you anything whatsoever. You
328
have been warned.
329
330
=head1 LICENSE
331
332
This program is free software; you can redistribute it and/or modify it
333
under the same terms as Perl itself.
334
335
=cut
336
337
# vi:ts=2:sw=2:et:sta
338
1;
Loggerhead is a web-based interface for Breezy
Version: 2.0.1