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.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.04";
  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 <perl5-porters@perl.org>.
 239
 240 =head1 COPYRIGHT
 241
 242 Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. 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