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