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: 2004-12-17
  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
  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)
  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: File
 138 #
 139 # Return: Contents of the file (Scalar Reference)
 140
 141 sub file_read($)
 142 {
 143  my $file = shift;
 144  local *FILE;
 145
 146  sysopen(FILE,$file,O_RDONLY) or return;
 147  file_lock(FILE,LOCK_SH)      or do { close(FILE); return };
 148
 149  read(FILE, my $content, -s $file);
 150
 151  file_lock(FILE,LOCK_UN)      or do { close(FILE); return };
 152  close(FILE)                  or return;
 153
 154  return \$content;
 155 }
 156
 157 # file_save()
 158 #
 159 # Save a file
 160 #
 161 # Params: 1. File
 162 #         2. File content as Scalar Reference
 163 #         3. true  => open in binary mode
 164 #            false => open in normal mode (default)
 165 #
 166 # Return: Status code (Boolean)
 167
 168 sub file_save($$;$)
 169 {
 170  my ($file,$content,$binary) = @_;
 171  local *FILE;
 172
 173  sysopen(FILE,$file,O_WRONLY | O_CREAT | O_TRUNC) or return;
 174  file_lock(FILE,LOCK_EX)                          or do { close(FILE); return };
 175  binmode(FILE) if($binary);
 176
 177  print FILE $$content                             or do { close(FILE); return };
 178
 179  file_lock(FILE,LOCK_UN)                          or do { close(FILE); return };
 180  close(FILE)                                      or return;
 181
 182  return 1;
 183 }
 184
 185 # file_unlock()
 186 #
 187 # Remove a file from the list of files in use
 188 #
 189 # Params: 1. File::UseList object
 190 #         2. File to remove
 191 #
 192 # Return: -nothing-
 193
 194 sub file_unlock($$)
 195 {
 196  my ($uselist,$file) = @_;
 197
 198  $uselist->remove_file($file);
 199  $uselist->save;
 200
 201  return;
 202 }
 203
 204 # it's true, baby ;-)
 205
 206 1;
 207
 208 #
 209 ### End ###