modules/File/Access.pm

   1 package File::Access;
   2
   3 #
   4 # Dev-Editor - Module File::Access
   5 #
   6 # Some simple routines for doing things with files by
   7 # using only one command
   8 #
   9 # Author:        Patrick Canterino <patrick@patshaping.de>
  10 # Last modified: 2005-08-01
  11 #
  12
  13 use strict;
  14
  15 use vars qw(@EXPORT
  16             $has_flock);
  17
  18 use Fcntl qw(:DEFAULT
  19              :flock);
  20
  21 use File::Copy;
  22
  23 ### Export ###
  24
  25 use base qw(Exporter);
  26
  27 @EXPORT = qw(dir_copy
  28              dir_read
  29              file_create
  30              file_lock
  31              file_read
  32              file_save
  33
  34              LOCK_SH
  35              LOCK_EX
  36              LOCK_UN
  37              LOCK_NB);
  38
  39 # Check if flock() is available
  40 # I found this piece of code somewhere in the internet
  41
  42 $has_flock = eval { local $SIG{'__DIE__'}; flock(STDOUT,0); 1 };
  43
  44 # Predeclaration of dir_copy()
  45
  46 sub dir_copy($$);
  47
  48 # dir_copy()
  49 #
  50 # Copy a directory
  51 #
  52 # Params: 1. Directory to copy
  53 #         2. Target
  54 #
  55 # Return: Status code (Boolean)
  56
  57 sub dir_copy($$)
  58 {
  59  my ($dir,$target) = @_;
  60
  61  return unless(-d $dir);
  62
  63  my $entries = dir_read($dir) or return;
  64
  65  my $dirs    = $entries->{'dirs'};
  66  my $files   = $entries->{'files'};
  67
  68  mkdir($target,0777) unless(-d $target);
  69
  70  foreach my $directory(@$dirs)
  71  {
  72   unless(-d $target.'/'.$directory)
  73   {
  74    mkdir($target.'/'.$directory,0777) or next;
  75   }
  76
  77   if(-r $target.'/'.$directory && -x $target.'/'.$directory)
  78   {
  79    dir_copy($dir.'/'.$directory,$target.'/'.$directory) or next;
  80   }
  81  }
  82
  83  foreach my $file(@$files)
  84  {
  85   copy($dir.'/'.$file,$target.'/'.$file) or next;
  86  }
  87
  88  return 1;
  89 }
  90
  91 # dir_read()
  92 #
  93 # Collect the files and directories in a directory
  94 #
  95 # Params: Directory
  96 #
  97 # Return: Hash reference: dirs  => directories
  98 #                         files => files and symbolic links
  99
 100 sub dir_read($)
 101 {
 102  my $dir = shift;
 103  local *DIR;
 104
 105  return unless(-d $dir);
 106
 107  # Get all the entries in the directory
 108
 109  opendir(DIR,$dir) or return;
 110  my @entries = readdir(DIR);
 111  closedir(DIR) or return;
 112
 113  # Sort the entries
 114
 115  @entries = sort {uc($a) cmp uc($b)} @entries;
 116
 117  my @files;
 118  my @dirs;
 119
 120  foreach my $entry(@entries)
 121  {
 122   next if($entry eq '.' || $entry eq '..');
 123
 124   if(-d $dir.'/'.$entry && not -l $dir.'/'.$entry)
 125   {
 126    push(@dirs,$entry);
 127   }
 128   else
 129   {
 130    push(@files,$entry);
 131   }
 132  }
 133
 134  return {dirs => \@dirs, files => \@files};
 135 }
 136
 137 # file_create()
 138 #
 139 # Create a file, but only if it doesn't already exist
 140 #
 141 # (I wanted to use O_EXCL for this, but `perldoc -f sysopen`
 142 # doesn't say that it is available on every system - so I
 143 # created this workaround using O_RDONLY and O_CREAT)
 144 #
 145 # Params: File to create
 146 #
 147 # Return: true on success;
 148 #         false on error or if the file already exists
 149
 150 sub file_create($)
 151 {
 152  my $file = shift;
 153  local *FILE;
 154
 155  return if(-e $file);
 156
 157  sysopen(FILE,$file,O_RDONLY | O_CREAT) or return;
 158  close(FILE)                            or return;
 159
 160  return 1;
 161 }
 162
 163 # file_lock()
 164 #
 165 # System independent wrapper function for flock()
 166 # On systems where flock() is not available, this function
 167 # always returns true.
 168 #
 169 # Params: 1. Filehandle
 170 #         2. Locking mode
 171 #
 172 # Return: Status code (Boolean)
 173
 174 sub file_lock(*$)
 175 {
 176  my ($handle,$mode) = @_;
 177
 178  return 1 unless($has_flock);
 179  return flock($handle,$mode);
 180 }
 181
 182 # file_read()
 183 #
 184 # Read out a file completely
 185 #
 186 # Params: 1. File
 187 #         2. true  => open in binary mode
 188 #            false => open in normal mode (default)
 189 #
 190 # Return: Contents of the file (Scalar Reference)
 191
 192 sub file_read($;$)
 193 {
 194  my ($file,$binary) = @_;
 195  local *FILE;
 196
 197  sysopen(FILE,$file,O_RDONLY) or return;
 198  file_lock(FILE,LOCK_SH)      or do { close(FILE); return };
 199  binmode(FILE) if($binary);
 200
 201  read(FILE, my $content, -s $file);
 202
 203  close(FILE)                  or return;
 204
 205  return \$content;
 206 }
 207
 208 # file_save()
 209 #
 210 # Save a file
 211 #
 212 # Params: 1. File
 213 #         2. File content as Scalar Reference
 214 #         3. true  => open in binary mode
 215 #            false => open in normal mode (default)
 216 #
 217 # Return: Status code (Boolean)
 218
 219 sub file_save($$;$)
 220 {
 221  my ($file,$content,$binary) = @_;
 222  local *FILE;
 223
 224  sysopen(FILE,$file,O_WRONLY | O_CREAT | O_TRUNC) or return;
 225  file_lock(FILE,LOCK_EX)                          or do { close(FILE); return };
 226  binmode(FILE) if($binary);
 227
 228  print FILE $$content                             or do { close(FILE); return };
 229
 230  close(FILE)                                      or return;
 231
 232  return 1;
 233 }
 234
 235 # it's true, baby ;-)
 236
 237 1;
 238
 239 #
 240 ### End ###