ext/IO/lib/IO/Dir.pm

   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;
  16 use vars qw(@ISA $VERSION @EXPORT_OK);
  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
 230 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 231 bugs to <perl5-porters@perl.org>.
 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