X-Git-Url: https://git.p6c8.net/devedit.git/blobdiff_plain/7bc8b322eb4d5fdf4b6edf0fcd711b2ad5483a3a..HEAD:/modules/File/Access.pm diff --git a/modules/File/Access.pm b/modules/File/Access.pm index 2727775..af219a7 100644 --- a/modules/File/Access.pm +++ b/modules/File/Access.pm @@ -3,27 +3,154 @@ package File::Access; # # Dev-Editor - Module File::Access # -# Some simple routines for doing things with files -# with only one command +# Some simple routines for doing things with files by +# using only one command # -# Author: Patrick Canterino -# Last modified: 2003-11-04 +# Author: Patrick Canterino +# Last modified: 2011-02-11 +# +# Copyright (C) 1999-2000 Roland Bluethgen, Frank Schoenmann +# Copyright (C) 2003-2011 Patrick Canterino +# All Rights Reserved. +# +# This file can be distributed and/or modified under the terms of +# of the Artistic License 2.0 (see also the LICENSE file found at +# the top level of the Dev-Editor distribution). # use strict; -use vars qw(@EXPORT); +use vars qw(@EXPORT + $has_flock + $has_archive_extract + $archive_extract_error); + +use Fcntl qw(:DEFAULT + :flock); -use Carp qw(croak); +use File::Copy; ### Export ### use base qw(Exporter); -@EXPORT = qw(dir_read +@EXPORT = qw(archive_unpack + dir_copy + dir_read file_create + file_lock file_read - file_save); + file_save + + LOCK_SH + LOCK_EX + LOCK_UN + LOCK_NB); + +# Check if flock() is available +# I found this piece of code somewhere in the internet + +$has_flock = eval { local $SIG{'__DIE__'}; flock(STDOUT,0); 1 }; + +# Check if Archive::Extract is available + +$has_archive_extract = eval { local $SIG{'__DIE__'}; require Archive::Extract; 1 }; + +# Predeclaration of dir_copy() + +sub dir_copy($$); + +# archive_unpack() +# +# Unpack an archive +# (archive type must be supported by Archive::Extract) +# +# Params: 1. Archive path +# 2. Path to extract (optional) +# +# Return: - Status code (Boolean) +# - undef if Archive::Extract is not available + +sub archive_unpack($;$) +{ + my ($archive,$path) = @_; + + return undef unless($has_archive_extract); + + return unless(-f $archive); + return if($path && not -d $path); + + my $ae = Archive::Extract->new(archive => $archive); + return unless($ae); + + if($path) + { + if($ae->extract(to => $path)) + { + return 1; + } + else + { + $archive_extract_error = $ae->error; + return; + } + } + else + { + if($ae->extract) + { + return 1; + } + else + { + $archive_extract_error = $ae->error; + return; + } + } +} + +# dir_copy() +# +# Copy a directory +# +# Params: 1. Directory to copy +# 2. Target +# +# Return: Status code (Boolean) + +sub dir_copy($$) +{ + my ($dir,$target) = @_; + + return unless(-d $dir); + + my $entries = dir_read($dir) or return; + + my $dirs = $entries->{'dirs'}; + my $files = $entries->{'files'}; + + mkdir($target,0777) unless(-d $target); + + foreach my $directory(@$dirs) + { + unless(-d $target.'/'.$directory) + { + mkdir($target.'/'.$directory,0777) or next; + } + + if(-r $target.'/'.$directory && -x $target.'/'.$directory) + { + dir_copy($dir.'/'.$directory,$target.'/'.$directory) or next; + } + } + + foreach my $file(@$files) + { + copy($dir.'/'.$file,$target.'/'.$file) or next; + } + + return 1; +} # dir_read() # @@ -32,7 +159,7 @@ use base qw(Exporter); # Params: Directory # # Return: Hash reference: dirs => directories -# files => files +# files => files and symbolic links sub dir_read($) { @@ -49,16 +176,16 @@ sub dir_read($) # Sort the entries - @entries = sort(@entries); + @entries = sort {uc($a) cmp uc($b)} @entries; my @files; my @dirs; foreach my $entry(@entries) { - next if($entry eq "." || $entry eq ".."); + next if($entry eq '.' || $entry eq '..'); - if(-d $dir."/".$entry) + if(-d $dir.'/'.$entry && not -l $dir.'/'.$entry) { push(@dirs,$entry); } @@ -73,7 +200,11 @@ sub dir_read($) # file_create() # -# Create a file +# Create a file, but only if it doesn't already exist +# +# (I wanted to use O_EXCL for this, but `perldoc -f sysopen` +# doesn't say that it is available on every system - so I +# created this workaround using O_RDONLY and O_CREAT) # # Params: File to create # @@ -87,28 +218,53 @@ sub file_create($) return if(-e $file); - open(FILE,">",$file) or return; - close(FILE) or return; + sysopen(FILE,$file,O_RDONLY | O_CREAT) or return; + close(FILE) or return; return 1; } +# file_lock() +# +# System independent wrapper function for flock() +# On systems where flock() is not available, this function +# always returns true. +# +# Params: 1. Filehandle +# 2. Locking mode +# +# Return: Status code (Boolean) + +sub file_lock(*$) +{ + my ($handle,$mode) = @_; + + return 1 unless($has_flock); + return flock($handle,$mode); +} + # file_read() # # Read out a file completely # -# Params: File +# Params: 1. File +# 2. true => open in binary mode +# false => open in normal mode (default) # # Return: Contents of the file (Scalar Reference) -sub file_read($) +sub file_read($;$) { - my $file = shift; + my ($file,$binary) = @_; local *FILE; - open(FILE,"<",$file) or return; + sysopen(FILE,$file,O_RDONLY) or return; + file_lock(FILE,LOCK_SH) or do { close(FILE); return }; + binmode(FILE) if($binary); + read(FILE, my $content, -s $file); - close(FILE) or return; + + close(FILE) or return; return \$content; } @@ -119,17 +275,23 @@ sub file_read($) # # Params: 1. File # 2. File content as Scalar Reference +# 3. true => open in binary mode +# false => open in normal mode (default) # # Return: Status code (Boolean) -sub file_save($$) +sub file_save($$;$) { - my ($file,$content) = @_; + my ($file,$content,$binary) = @_; local *FILE; - open(FILE,">",$file) or return; - print FILE $$content or do { close(FILE); return }; - close(FILE) or return; + sysopen(FILE,$file,O_WRONLY | O_CREAT | O_TRUNC) or return; + file_lock(FILE,LOCK_EX) or do { close(FILE); return }; + binmode(FILE) if($binary); + + print FILE $$content or do { close(FILE); return }; + + close(FILE) or return; return 1; }