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