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