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