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: 2010-12-27
  11 #
  12 # Copyright (C) 1999-2000 Roland Bluethgen, Frank Schoenmann
  13 # Copyright (C) 2003-2009 Patrick Canterino
  14 # All Rights Reserved.
  15 #
  16 # This file can be distributed and/or modified under the terms of
  17 # of the Artistic License 1.0 (see also the LICENSE file found at
  18 # the top level of the Dev-Editor distribution).
  19 #
  20
  21 use strict;
  22
  23 use vars qw(@EXPORT
  24             $has_flock
  25             $has_archive_extract);
  26
  27 use Fcntl qw(:DEFAULT
  28              :flock);
  29
  30 use File::Copy;
  31
  32 ### Export ###
  33
  34 use base qw(Exporter);
  35
  36 @EXPORT = qw(archive_unpack
  37              dir_copy
  38              dir_read
  39              file_create
  40              file_lock
  41              file_read
  42              file_save
  43
  44              LOCK_SH
  45              LOCK_EX
  46              LOCK_UN
  47              LOCK_NB);
  48
  49 # Check if flock() is available
  50 # I found this piece of code somewhere in the internet
  51
  52 $has_flock = eval { local $SIG{'__DIE__'}; flock(STDOUT,0); 1 };
  53
  54 # Check if Archive::Extract is available
  55
  56 $has_archive_extract = eval { local $SIG{'__DIE__'}; require Archive::Extract; 1 };
  57
  58 # Predeclaration of dir_copy()
  59
  60 sub dir_copy($$);
  61
  62 # archive_unpack()
  63 #
  64 # Unpack an archive
  65 # (archive type must be supported by Archive::Extract)
  66 #
  67 # Params: 1. Archive path
  68 #         2. Path to extract (optional)
  69 #
  70 # Return: - Status code (Boolean)
  71 #         - undef if Archive::Extract is not available
  72
  73 sub archive_unpack($;$)
  74 {
  75  my ($archive,$path) = @_;
  76
  77  return undef unless($has_archive_extract);
  78
  79  return unless(-f $archive);
  80  return if($path && not -d $path);
  81
  82  my $ae = Archive::Extract->new(archive => $archive);
  83  return unless($ae);
  84
  85  if($path)
  86  {
  87   return $ae->extract(to => $path);
  88  }
  89  else
  90  {
  91   return $ae->extract;
  92  }
  93 }
  94
  95 # dir_copy()
  96 #
  97 # Copy a directory
  98 #
  99 # Params: 1. Directory to copy
 100 #         2. Target
 101 #
 102 # Return: Status code (Boolean)
 103
 104 sub dir_copy($$)
 105 {
 106  my ($dir,$target) = @_;
 107
 108  return unless(-d $dir);
 109
 110  my $entries = dir_read($dir) or return;
 111
 112  my $dirs    = $entries->{'dirs'};
 113  my $files   = $entries->{'files'};
 114
 115  mkdir($target,0777) unless(-d $target);
 116
 117  foreach my $directory(@$dirs)
 118  {
 119   unless(-d $target.'/'.$directory)
 120   {
 121    mkdir($target.'/'.$directory,0777) or next;
 122   }
 123
 124   if(-r $target.'/'.$directory && -x $target.'/'.$directory)
 125   {
 126    dir_copy($dir.'/'.$directory,$target.'/'.$directory) or next;
 127   }
 128  }
 129
 130  foreach my $file(@$files)
 131  {
 132   copy($dir.'/'.$file,$target.'/'.$file) or next;
 133  }
 134
 135  return 1;
 136 }
 137
 138 # dir_read()
 139 #
 140 # Collect the files and directories in a directory
 141 #
 142 # Params: Directory
 143 #
 144 # Return: Hash reference: dirs  => directories
 145 #                         files => files and symbolic links
 146
 147 sub dir_read($)
 148 {
 149  my $dir = shift;
 150  local *DIR;
 151
 152  return unless(-d $dir);
 153
 154  # Get all the entries in the directory
 155
 156  opendir(DIR,$dir) or return;
 157  my @entries = readdir(DIR);
 158  closedir(DIR) or return;
 159
 160  # Sort the entries
 161
 162  @entries = sort {uc($a) cmp uc($b)} @entries;
 163
 164  my @files;
 165  my @dirs;
 166
 167  foreach my $entry(@entries)
 168  {
 169   next if($entry eq '.' || $entry eq '..');
 170
 171   if(-d $dir.'/'.$entry && not -l $dir.'/'.$entry)
 172   {
 173    push(@dirs,$entry);
 174   }
 175   else
 176   {
 177    push(@files,$entry);
 178   }
 179  }
 180
 181  return {dirs => \@dirs, files => \@files};
 182 }
 183
 184 # file_create()
 185 #
 186 # Create a file, but only if it doesn't already exist
 187 #
 188 # (I wanted to use O_EXCL for this, but `perldoc -f sysopen`
 189 # doesn't say that it is available on every system - so I
 190 # created this workaround using O_RDONLY and O_CREAT)
 191 #
 192 # Params: File to create
 193 #
 194 # Return: true on success;
 195 #         false on error or if the file already exists
 196
 197 sub file_create($)
 198 {
 199  my $file = shift;
 200  local *FILE;
 201
 202  return if(-e $file);
 203
 204  sysopen(FILE,$file,O_RDONLY | O_CREAT) or return;
 205  close(FILE)                            or return;
 206
 207  return 1;
 208 }
 209
 210 # file_lock()
 211 #
 212 # System independent wrapper function for flock()
 213 # On systems where flock() is not available, this function
 214 # always returns true.
 215 #
 216 # Params: 1. Filehandle
 217 #         2. Locking mode
 218 #
 219 # Return: Status code (Boolean)
 220
 221 sub file_lock(*$)
 222 {
 223  my ($handle,$mode) = @_;
 224
 225  return 1 unless($has_flock);
 226  return flock($handle,$mode);
 227 }
 228
 229 # file_read()
 230 #
 231 # Read out a file completely
 232 #
 233 # Params: 1. File
 234 #         2. true  => open in binary mode
 235 #            false => open in normal mode (default)
 236 #
 237 # Return: Contents of the file (Scalar Reference)
 238
 239 sub file_read($;$)
 240 {
 241  my ($file,$binary) = @_;
 242  local *FILE;
 243
 244  sysopen(FILE,$file,O_RDONLY) or return;
 245  file_lock(FILE,LOCK_SH)      or do { close(FILE); return };
 246  binmode(FILE) if($binary);
 247
 248  read(FILE, my $content, -s $file);
 249
 250  close(FILE)                  or return;
 251
 252  return \$content;
 253 }
 254
 255 # file_save()
 256 #
 257 # Save a file
 258 #
 259 # Params: 1. File
 260 #         2. File content as Scalar Reference
 261 #         3. true  => open in binary mode
 262 #            false => open in normal mode (default)
 263 #
 264 # Return: Status code (Boolean)
 265
 266 sub file_save($$;$)
 267 {
 268  my ($file,$content,$binary) = @_;
 269  local *FILE;
 270
 271  sysopen(FILE,$file,O_WRONLY | O_CREAT | O_TRUNC) or return;
 272  file_lock(FILE,LOCK_EX)                          or do { close(FILE); return };
 273  binmode(FILE) if($binary);
 274
 275  print FILE $$content                             or do { close(FILE); return };
 276
 277  close(FILE)                                      or return;
 278
 279  return 1;
 280 }
 281
 282 # it's true, baby ;-)
 283
 284 1;
 285
 286 #
 287 ### End ###