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