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     # Only unlink if unlink-ing is enabled
 133     my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key);
 134
 135     return 0
 136         unless ${*$dh}{io_dir_unlink};
 137
 138     -d $file
 139         ? rmdir($file)
 140         : unlink($file);
 141 }
 142
 143 1;
 144
 145 __END__
 146
 147 =head1 NAME
 148
 149 IO::Dir - supply object methods for directory handles
 150
 151 =head1 SYNOPSIS
 152
 153     use IO::Dir;
 154     $d = new IO::Dir ".";
 155     if (defined $d) {
 156         while (defined($_ = $d->read)) { something($_); }
 157         $d->rewind;
 158         while (defined($_ = $d->read)) { something_else($_); }
 159         undef $d;
 160     }
 161
 162     tie %dir, IO::Dir, ".";
 163     foreach (keys %dir) {
 164         print $_, " " , $dir{$_}->size,"\n";
 165     }
 166
 167 =head1 DESCRIPTION
 168
 169 The C<IO::Dir> package provides two interfaces to perl's directory reading
 170 routines.
 171
 172 The first interface is an object approach. C<IO::Dir> provides an object
 173 constructor and methods, which are just wrappers around perl's built in
 174 directory reading routines.
 175
 176 =over 4
 177
 178 =item new ( [ DIRNAME ] )
 179
 180 C<new> is the constuctor for C<IO::Dir> objects. It accepts one optional
 181 argument which,  if given, C<new> will pass to C<open>
 182
 183 =back
 184
 185 The following methods are wrappers for the directory related functions built
 186 into perl (the trailing `dir' has been removed from the names). See L<perlfunc>
 187 for details of these functions.
 188
 189 =over 4
 190
 191 =item open ( DIRNAME )
 192
 193 =item read ()
 194
 195 =item seek ( POS )
 196
 197 =item tell ()
 198
 199 =item rewind ()
 200
 201 =item close ()
 202
 203 =back
 204
 205 C<IO::Dir> also provides an interface to reading directories via a tied
 206 HASH. The tied HASH extends the interface beyond just the directory
 207 reading routines by the use of C<lstat>, from the C<File::stat> package,
 208 C<unlink>, C<rmdir> and C<utime>.
 209
 210 =over 4
 211
 212 =item tie %hash, IO::Dir, DIRNAME [, OPTIONS ]
 213
 214 =back
 215
 216 The keys of the HASH will be the names of the entries in the directory.
 217 Reading a value from the hash will be the result of calling
 218 C<File::stat::lstat>. Deleting an element from the hash will call C<unlink>
 219 providing that C<DIR_UNLINK> is passed in the C<OPTIONS>.
 220
 221 Assigning to an entry in the HASH will cause the time stamps of the file
 222 to be modified. If the file does not exist then it will be created. Assigning
 223 a single integer to a HASH element will cause both the access and
 224 modification times to be changed to that value. Alternatively a reference to
 225 an array of two values can be passed. The first array element will be used to
 226 set the access time and the second element will be used to set the modification
 227 time.
 228
 229 =head1 SEE ALSO
 230
 231 L<File::stat>
 232
 233 =head1 AUTHOR
 234
 235 Graham Barr. Currently maintained by the Perl Porters.  Please report all
 236 bugs to <perl5-porters@perl.org>.
 237
 238 =head1 COPYRIGHT
 239
 240 Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
 241 This program is free software; you can redistribute it and/or
 242 modify it under the same terms as Perl itself.
 243
 244 =cut