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-07-05
  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 # dir_copy()
  45 #
  46 # Copy a directory
  47 #
  48 # Params: 1. Directory to copy
  49 #         2. Target
  50 #
  51 # Return: Status code (Boolean)
  52
  53 sub dir_copy($$)
  54 {
  55  my ($dir,$target) = @_;
  56
  57  return unless(-d $dir);
  58
  59  my $entries = dir_read($dir) or return;
  60
  61  my $dirs    = $entries->{'dirs'};
  62  my $files   = $entries->{'files'};
  63
  64  mkdir($target,0777) unless(-d $target);
  65
  66  foreach my $directory(@$dirs)
  67  {
  68   unless(-d $target.'/'.$directory)
  69   {
  70    mkdir($target.'/'.$directory,0777) or next;
  71   }
  72
  73   if(-r $target.'/'.$directory && -x $target.'/'.$directory)
  74   {
  75    dir_copy($dir.'/'.$directory,$target.'/'.$directory) or next;
  76   }
  77  }
  78
  79  foreach my $file(@$files)
  80  {
  81   copy($dir.'/'.$file,$target.'/'.$file) or next;
  82  }
  83
  84  return 1;
  85 }
  86
  87 # dir_read()
  88 #
  89 # Collect the files and directories in a directory
  90 #
  91 # Params: Directory
  92 #
  93 # Return: Hash reference: dirs  => directories
  94 #                         files => files and symbolic links
  95
  96 sub dir_read($)
  97 {
  98  my $dir = shift;
  99  local *DIR;
 100
 101  return unless(-d $dir);
 102
 103  # Get all the entries in the directory
 104
 105  opendir(DIR,$dir) or return;
 106  my @entries = readdir(DIR);
 107  closedir(DIR) or return;
 108
 109  # Sort the entries
 110
 111  @entries = sort {uc($a) cmp uc($b)} @entries;
 112
 113  my @files;
 114  my @dirs;
 115
 116  foreach my $entry(@entries)
 117  {
 118   next if($entry eq '.' || $entry eq '..');
 119
 120   if(-d $dir.'/'.$entry && not -l $dir.'/'.$entry)
 121   {
 122    push(@dirs,$entry);
 123   }
 124   else
 125   {
 126    push(@files,$entry);
 127   }
 128  }
 129
 130  return {dirs => \@dirs, files => \@files};
 131 }
 132
 133 # file_create()
 134 #
 135 # Create a file, but only if it doesn't already exist
 136 #
 137 # (I wanted to use O_EXCL for this, but `perldoc -f sysopen`
 138 # doesn't say that it is available on every system - so I
 139 # created this workaround using O_RDONLY and O_CREAT)
 140 #
 141 # Params: File to create
 142 #
 143 # Return: true on success;
 144 #         false on error or if the file already exists
 145
 146 sub file_create($)
 147 {
 148  my $file = shift;
 149  local *FILE;
 150
 151  return if(-e $file);
 152
 153  sysopen(FILE,$file,O_RDONLY | O_CREAT) or return;
 154  close(FILE)                            or return;
 155
 156  return 1;
 157 }
 158
 159 # file_lock()
 160 #
 161 # System independent wrapper function for flock()
 162 # On systems where flock() is not available, this function
 163 # always returns true.
 164 #
 165 # Params: 1. Filehandle
 166 #         2. Locking mode
 167 #
 168 # Return: Status code (Boolean)
 169
 170 sub file_lock(*$)
 171 {
 172  my ($handle,$mode) = @_;
 173
 174  return 1 unless($has_flock);
 175  return flock($handle,$mode);
 176 }
 177
 178 # file_read()
 179 #
 180 # Read out a file completely
 181 #
 182 # Params: 1. File
 183 #         2. true  => open in binary mode
 184 #            false => open in normal mode (default)
 185 #
 186 # Return: Contents of the file (Scalar Reference)
 187
 188 sub file_read($;$)
 189 {
 190  my ($file,$binary) = @_;
 191  local *FILE;
 192
 193  sysopen(FILE,$file,O_RDONLY) or return;
 194  file_lock(FILE,LOCK_SH)      or do { close(FILE); return };
 195  binmode(FILE) if($binary);
 196
 197  read(FILE, my $content, -s $file);
 198
 199  close(FILE)                  or return;
 200
 201  return \$content;
 202 }
 203
 204 # file_save()
 205 #
 206 # Save a file
 207 #
 208 # Params: 1. File
 209 #         2. File content as Scalar Reference
 210 #         3. true  => open in binary mode
 211 #            false => open in normal mode (default)
 212 #
 213 # Return: Status code (Boolean)
 214
 215 sub file_save($$;$)
 216 {
 217  my ($file,$content,$binary) = @_;
 218  local *FILE;
 219
 220  sysopen(FILE,$file,O_WRONLY | O_CREAT | O_TRUNC) or return;
 221  file_lock(FILE,LOCK_EX)                          or do { close(FILE); return };
 222  binmode(FILE) if($binary);
 223
 224  print FILE $$content                             or do { close(FILE); return };
 225
 226  close(FILE)                                      or return;
 227
 228  return 1;
 229 }
 230
 231 # it's true, baby ;-)
 232
 233 1;
 234
 235 #
 236 ### End ###