X-Git-Url: https://git.p6c8.net/devedit.git/blobdiff_plain/85de18899b48fe39a79a265bff4b1fd0478c5842..71dce6c526b5f0c1617313dacf173f0c75f8183d:/modules/File/Access.pm diff --git a/modules/File/Access.pm b/modules/File/Access.pm index 248eb35..5521ebf 100644 --- a/modules/File/Access.pm +++ b/modules/File/Access.pm @@ -7,13 +7,23 @@ package File::Access; # using only one command # # Author: Patrick Canterino -# Last modified: 2005-08-01 +# Last modified: 2011-01-05 +# +# 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 1.0 (see also the LICENSE file found at +# the top level of the Dev-Editor distribution). # use strict; use vars qw(@EXPORT - $has_flock); + $has_flock + $has_archive_extract + $archive_extract_error); use Fcntl qw(:DEFAULT :flock); @@ -24,7 +34,8 @@ use File::Copy; use base qw(Exporter); -@EXPORT = qw(dir_copy +@EXPORT = qw(archive_unpack + dir_copy dir_read file_create file_lock @@ -41,10 +52,63 @@ use base qw(Exporter); $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