1 | # IO::Dir.pm
|
---|
2 | #
|
---|
3 | # Copyright (c) 1997-8 Graham Barr <[email protected]>. All rights reserved.
|
---|
4 | # This program is free software; you can redistribute it and/or
|
---|
5 | # modify it under the same terms as Perl itself.
|
---|
6 |
|
---|
7 | package IO::Dir;
|
---|
8 |
|
---|
9 | use 5.006;
|
---|
10 |
|
---|
11 | use strict;
|
---|
12 | use Carp;
|
---|
13 | use Symbol;
|
---|
14 | use Exporter;
|
---|
15 | use IO::File;
|
---|
16 | our(@ISA, $VERSION, @EXPORT_OK);
|
---|
17 | use Tie::Hash;
|
---|
18 | use File::stat;
|
---|
19 | use File::Spec;
|
---|
20 |
|
---|
21 | @ISA = qw(Tie::Hash Exporter);
|
---|
22 | $VERSION = "1.05";
|
---|
23 | $VERSION = eval $VERSION;
|
---|
24 | @EXPORT_OK = qw(DIR_UNLINK);
|
---|
25 |
|
---|
26 | sub DIR_UNLINK () { 1 }
|
---|
27 |
|
---|
28 | sub new {
|
---|
29 | @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]';
|
---|
30 | my $class = shift;
|
---|
31 | my $dh = gensym;
|
---|
32 | if (@_) {
|
---|
33 | IO::Dir::open($dh, $_[0])
|
---|
34 | or return undef;
|
---|
35 | }
|
---|
36 | bless $dh, $class;
|
---|
37 | }
|
---|
38 |
|
---|
39 | sub DESTROY {
|
---|
40 | my ($dh) = @_;
|
---|
41 | closedir($dh);
|
---|
42 | }
|
---|
43 |
|
---|
44 | sub open {
|
---|
45 | @_ == 2 or croak 'usage: $dh->open(DIRNAME)';
|
---|
46 | my ($dh, $dirname) = @_;
|
---|
47 | return undef
|
---|
48 | unless opendir($dh, $dirname);
|
---|
49 | # a dir name should always have a ":" in it; assume dirname is
|
---|
50 | # in current directory
|
---|
51 | $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) );
|
---|
52 | ${*$dh}{io_dir_path} = $dirname;
|
---|
53 | 1;
|
---|
54 | }
|
---|
55 |
|
---|
56 | sub close {
|
---|
57 | @_ == 1 or croak 'usage: $dh->close()';
|
---|
58 | my ($dh) = @_;
|
---|
59 | closedir($dh);
|
---|
60 | }
|
---|
61 |
|
---|
62 | sub read {
|
---|
63 | @_ == 1 or croak 'usage: $dh->read()';
|
---|
64 | my ($dh) = @_;
|
---|
65 | readdir($dh);
|
---|
66 | }
|
---|
67 |
|
---|
68 | sub seek {
|
---|
69 | @_ == 2 or croak 'usage: $dh->seek(POS)';
|
---|
70 | my ($dh,$pos) = @_;
|
---|
71 | seekdir($dh,$pos);
|
---|
72 | }
|
---|
73 |
|
---|
74 | sub tell {
|
---|
75 | @_ == 1 or croak 'usage: $dh->tell()';
|
---|
76 | my ($dh) = @_;
|
---|
77 | telldir($dh);
|
---|
78 | }
|
---|
79 |
|
---|
80 | sub rewind {
|
---|
81 | @_ == 1 or croak 'usage: $dh->rewind()';
|
---|
82 | my ($dh) = @_;
|
---|
83 | rewinddir($dh);
|
---|
84 | }
|
---|
85 |
|
---|
86 | sub TIEHASH {
|
---|
87 | my($class,$dir,$options) = @_;
|
---|
88 |
|
---|
89 | my $dh = $class->new($dir)
|
---|
90 | or return undef;
|
---|
91 |
|
---|
92 | $options ||= 0;
|
---|
93 |
|
---|
94 | ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK;
|
---|
95 | $dh;
|
---|
96 | }
|
---|
97 |
|
---|
98 | sub FIRSTKEY {
|
---|
99 | my($dh) = @_;
|
---|
100 | $dh->rewind;
|
---|
101 | scalar $dh->read;
|
---|
102 | }
|
---|
103 |
|
---|
104 | sub NEXTKEY {
|
---|
105 | my($dh) = @_;
|
---|
106 | scalar $dh->read;
|
---|
107 | }
|
---|
108 |
|
---|
109 | sub EXISTS {
|
---|
110 | my($dh,$key) = @_;
|
---|
111 | -e File::Spec->catfile(${*$dh}{io_dir_path}, $key);
|
---|
112 | }
|
---|
113 |
|
---|
114 | sub FETCH {
|
---|
115 | my($dh,$key) = @_;
|
---|
116 | &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key));
|
---|
117 | }
|
---|
118 |
|
---|
119 | sub STORE {
|
---|
120 | my($dh,$key,$data) = @_;
|
---|
121 | my($atime,$mtime) = ref($data) ? @$data : ($data,$data);
|
---|
122 | my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
|
---|
123 | unless(-e $file) {
|
---|
124 | my $io = IO::File->new($file,O_CREAT | O_RDWR);
|
---|
125 | $io->close if $io;
|
---|
126 | }
|
---|
127 | utime($atime,$mtime, $file);
|
---|
128 | }
|
---|
129 |
|
---|
130 | sub DELETE {
|
---|
131 | my($dh,$key) = @_;
|
---|
132 |
|
---|
133 | # Only unlink if unlink-ing is enabled
|
---|
134 | return 0
|
---|
135 | unless ${*$dh}{io_dir_unlink};
|
---|
136 |
|
---|
137 | my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
|
---|
138 |
|
---|
139 | -d $file
|
---|
140 | ? rmdir($file)
|
---|
141 | : unlink($file);
|
---|
142 | }
|
---|
143 |
|
---|
144 | 1;
|
---|
145 |
|
---|
146 | __END__
|
---|
147 |
|
---|
148 | =head1 NAME
|
---|
149 |
|
---|
150 | IO::Dir - supply object methods for directory handles
|
---|
151 |
|
---|
152 | =head1 SYNOPSIS
|
---|
153 |
|
---|
154 | use IO::Dir;
|
---|
155 | $d = IO::Dir->new(".");
|
---|
156 | if (defined $d) {
|
---|
157 | while (defined($_ = $d->read)) { something($_); }
|
---|
158 | $d->rewind;
|
---|
159 | while (defined($_ = $d->read)) { something_else($_); }
|
---|
160 | undef $d;
|
---|
161 | }
|
---|
162 |
|
---|
163 | tie %dir, 'IO::Dir', ".";
|
---|
164 | foreach (keys %dir) {
|
---|
165 | print $_, " " , $dir{$_}->size,"\n";
|
---|
166 | }
|
---|
167 |
|
---|
168 | =head1 DESCRIPTION
|
---|
169 |
|
---|
170 | The C<IO::Dir> package provides two interfaces to perl's directory reading
|
---|
171 | routines.
|
---|
172 |
|
---|
173 | The first interface is an object approach. C<IO::Dir> provides an object
|
---|
174 | constructor and methods, which are just wrappers around perl's built in
|
---|
175 | directory reading routines.
|
---|
176 |
|
---|
177 | =over 4
|
---|
178 |
|
---|
179 | =item new ( [ DIRNAME ] )
|
---|
180 |
|
---|
181 | C<new> is the constructor for C<IO::Dir> objects. It accepts one optional
|
---|
182 | argument which, if given, C<new> will pass to C<open>
|
---|
183 |
|
---|
184 | =back
|
---|
185 |
|
---|
186 | The following methods are wrappers for the directory related functions built
|
---|
187 | into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
|
---|
188 | for details of these functions.
|
---|
189 |
|
---|
190 | =over 4
|
---|
191 |
|
---|
192 | =item open ( DIRNAME )
|
---|
193 |
|
---|
194 | =item read ()
|
---|
195 |
|
---|
196 | =item seek ( POS )
|
---|
197 |
|
---|
198 | =item tell ()
|
---|
199 |
|
---|
200 | =item rewind ()
|
---|
201 |
|
---|
202 | =item close ()
|
---|
203 |
|
---|
204 | =back
|
---|
205 |
|
---|
206 | C<IO::Dir> also provides an interface to reading directories via a tied
|
---|
207 | hash. The tied hash extends the interface beyond just the directory
|
---|
208 | reading routines by the use of C<lstat>, from the C<File::stat> package,
|
---|
209 | C<unlink>, C<rmdir> and C<utime>.
|
---|
210 |
|
---|
211 | =over 4
|
---|
212 |
|
---|
213 | =item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ]
|
---|
214 |
|
---|
215 | =back
|
---|
216 |
|
---|
217 | The keys of the hash will be the names of the entries in the directory.
|
---|
218 | Reading a value from the hash will be the result of calling
|
---|
219 | C<File::stat::lstat>. Deleting an element from the hash will
|
---|
220 | delete the corresponding file or subdirectory,
|
---|
221 | provided that C<DIR_UNLINK> is included in the C<OPTIONS>.
|
---|
222 |
|
---|
223 | Assigning to an entry in the hash will cause the time stamps of the file
|
---|
224 | to be modified. If the file does not exist then it will be created. Assigning
|
---|
225 | a single integer to a hash element will cause both the access and
|
---|
226 | modification times to be changed to that value. Alternatively a reference to
|
---|
227 | an array of two values can be passed. The first array element will be used to
|
---|
228 | set the access time and the second element will be used to set the modification
|
---|
229 | time.
|
---|
230 |
|
---|
231 | =head1 SEE ALSO
|
---|
232 |
|
---|
233 | L<File::stat>
|
---|
234 |
|
---|
235 | =head1 AUTHOR
|
---|
236 |
|
---|
237 | Graham Barr. Currently maintained by the Perl Porters. Please report all
|
---|
238 | bugs to <[email protected]>.
|
---|
239 |
|
---|
240 | =head1 COPYRIGHT
|
---|
241 |
|
---|
242 | Copyright (c) 1997-2003 Graham Barr <[email protected]>. All rights reserved.
|
---|
243 | This program is free software; you can redistribute it and/or
|
---|
244 | modify it under the same terms as Perl itself.
|
---|
245 |
|
---|
246 | =cut
|
---|