Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #!/usr/bin/perl
- # Copyright (c) 2010, Ilya Strukov (iley@iley.ru)
- # All rights reserved.
- #
- # Redistribution and use in source and binary forms, with or without
- # modification, are permitted provided that the following conditions are met:
- # * Redistributions of source code must retain the above copyright
- # notice, this list of conditions and the following disclaimer.
- # * Redistributions in binary form must reproduce the above copyright
- # notice, this list of conditions and the following disclaimer in the
- # documentation and/or other materials provided with the distribution.
- # * The name of the author nor the may not be used to endorse or promote products
- # derived from this software without specific prior written permission.
- #
- # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
- # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
- # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
- # DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDER BE LIABLE FOR ANY
- # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
- # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
- # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
- # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
- # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
- # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- # This script automatically detects archive type by file's extension and extracts
- # archive content. If there are several files in the archive and they are not
- # placed in a directory, script automatically creates directory for this files
- # before extracting. In case of directory name collision the scripts gives new
- # directories names like dirname_1, dirname_2 etc.
- use Cwd 'abs_path';
- use strict;
- use warnings;
- my %magic = ( '\.tar' => 'tar -xvf',
- '\.tar\.gz' => 'tar -xzvf',
- '\.tgz' => 'tar -xzvf',
- '\.gz' => 'gunzip',
- '\.tar\.bz2' => 'tar -xjvf',
- '\.zip' => 'unzip',
- '\.rar' => 'rar x',
- '\.7z' => '7z x'
- );
- # check file for existance; generate new name if such file's already exists
- sub new_name {
- my ($file) = @_;
- if (-e $file) {
- my $i;
- $i = 1;
- (++$i) while -e "$file\_$i";
- $file = "$file\_$i";
- }
- return $file;
- }
- sub file_info {
- my ($file) = @_;
- my ($cmd,$basename,$shortname) = ('','','');
- foreach my $ex (keys %magic) {
- if ($file =~ /(([^\/]*)$ex)$/i) {
- $cmd = "$magic{$ex} " . abs_path($file);
- $basename = $1;
- $shortname = $2;
- last;
- }
- }
- return ($cmd,$basename,$shortname);
- }
- sub extract_file {
- my ($file) = @_;
- my $level = 0;
- my ($cmd,$basename,$shortname);
- while (1) {
- ($cmd,$basename,$shortname) = &file_info($file);
- unless ($cmd) {
- die "File '$file' has unknow archive format" if $level == 0;
- last;
- }
- my $tmpdir = &new_name(".extract_$basename");
- (mkdir $tmpdir) or die "Cannot create temporary directory '$tmpdir'";
- chdir $tmpdir;
- print "Executing '$cmd'";
- system $cmd;
- die "Child process exited abnormally" if $?;
- chdir '..';
- my $result = "";
- my @files = split(/\n/, `ls $tmpdir`);
- if (scalar(@files) == 1) {
- #if there was only one file in the archive, just move it to the destination directory
- $result = &new_name($files[0]);
- (rename "$tmpdir/$files[0]", $result) or die "Cannot rename file '$tmpdir/$files[0]' to '$result'";
- (rmdir $tmpdir) or die "Cannot remove temporary directory '$tmpdir'";
- } else {
- #if we have several files, rename temporary directory according to archive's name
- $result = &new_name($shortname);
- (rename $tmpdir, $result) or die "Cannot rename temporary directory '$tmpdir' to '$result'";
- }
- print "Archive '$file' was extracted to '$result'\n";
- unlink $file if $level++ > 0;
- if (-f $result) {
- $file = $result;
- } else {
- last;
- }
- }
- }
- die "Usage: extract file" unless scalar(@ARGV) > 0;
- foreach my $param (@ARGV) {
- #TODO: process arguments
- &extract_file($param);
- }
Add Comment
Please, Sign In to add comment