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