#!/usr/bin/perl -w

#############################################################################
#
# Program:
#    xtract
# Author:
#    Christian J. Robinson <infynity@onewest.net>
# Copyright:
#    GPL version 2
# Purpose:
#    Extract all acrhive files specified on the command line.  If directories
#    are specified, recursively traverse the directory tree and extract all
#    archive files found into a corresponding subdirectory
# Assumptions:
#    - The user really does want to extract /everything/ found in the
#      specified directories
#    - The extraction applications are installed and in the user's $PATH
# Exit values:
#    This script currently will always exit with a success value unless
#    there's an invocation usage problem
# Known Limitations:
#    - Not all archive file formats are supported
#    - Currently the return value of the archive extraction commands are
#      ignored
#    - Not enough diagnostic/status information is printed
# TODO:
#
#############################################################################
#
# $Id: xtract,v 1.7 2008/02/21 22:09:12 infynity Exp $
#
# $Log: xtract,v $
# Revision 1.7  2008/02/21 22:09:12  infynity
# *** empty log message ***
#
# Revision 1.6  2008/02/21 21:49:32  infynity
# Make it clear when a step is being skipped.
#
# Revision 1.5  2008/02/21 20:03:53  infynity
# Improved usage
#
# Revision 1.4  2008/02/21 19:35:35  infynity
# path resolving bug fixed
#
# Revision 1.3  2008/02/20 13:59:11  infynity
# More options, such as --no-recurse and --delete-archives.
# Other improvements.
#
# Revision 1.2  2008/02/19 17:25:02  infynity
# tweaks
#
# Revision 1.1  2008/02/19 17:02:18  infynity
# Initial revision
#
#############################################################################

use 5.008;
use strict;
use Cwd;
use File::Basename;
use Getopt::Long;

# Order is /important/ here!  Put the multiple extension patterns first (eg,
# .tar.gz before .gz).  The string "$file" will be replaced with the filename.
my @suffixes = (
	[qr/\.tar\.gpg$/i                 => 'gpg --decrypt "$file" | tar -vx'],
	[qr/\.tar\.bz2$/i                 => 'bunzip2 -c "$file" | tar -vx'],
	[qr/(\.tgz|\.tar\.gz|\.tar\.Z)$/i => 'tar -vzxf "$file"'],
	[qr/(\.rar|\.cbr)$/i              => 'rar x "$file"'],
	[qr/(\.zip|\.cbz|\.jar|\.xpi)$/i  => 'unzip "$file"'],
	[qr/\.zoo$/i                      => 'zoo x "$file"'],
	[qr/\.tar$/i                      => 'tar -vxf "$file"'],
	[qr/(\.gz|\.z)$/i                 => 'gunzip "$file"'],
	[qr/\.bz2$/i                      => 'bunzip2 "$file"'],
);


sub find_directories($);
sub extract_all_in_directory($);
sub extract($;$);
sub usage(;$);
sub verbose($;$);

my $basename = basename($0);
my $version = (split(' ', '$Revision: 1.7 $'))[1] . ' ALPHA';
my $copyright = <<'EOF';
Copyright February, 2008 by Christian J. Robinson <infynity@onewest.net>
Distributable under the terms of the GPL public license, version 2.
EOF
my (%args, @dirs, @suffix_patterns);

# Defaults for some arguments:
$args{'force_subdirs'}    = 0;
$args{'force_no_subdirs'} = 0;
$args{'verbose'}          = 0;

Getopt::Long::config qw/bundling/;
GetOptions(\%args,
	'version|V'   => sub{
		my $v = "$basename version $version";
		print "$v\n$copyright";
		exit 0;
	},
	'help|h'      => sub{usage(0);},
	'shorthelp|H' => sub{$args{$_[0]} = 1; usage(0);},
	'force_subdirs|force-subdirs|forcesubdirs|subdirs|s',
	'force_no_subdirs|force-no-subdirs|forcenosubdirs|no_subdirs|no-subdirs|nosubdirs|n',
	'no_recurse|no-recurse|norecurse|r',
	'delete_archives|delete-archives|deletearchives|d',
	'force_delete_archives|force_delete-archives|forcedeletearchives|D',
	'verbose|v+',
) or usage(1);

$args{'delete_archives'} = 1 if $args{'force_delete_archives'};

warn "Can't use the --force_subdirs and --force_no_subdirs options at the same time.\n\n"
	and usage(1) if $args{'force_no_subdirs'} && $args{'force_subdirs'};

warn "Argument required\n" and usage(1) unless @ARGV;

# Make all warnings from this script be prefixed by an identifiable string:
$SIG{'__WARN__'} = sub{warn('****** ' . $_[0]);};

foreach my $suffix (@suffixes)
{
	push(@suffix_patterns, $suffix->[0])
}

foreach my $file (@ARGV)
{
	if (-d $file)
	{
		push(@dirs, ($file, find_directories($file)));
	} else {
		extract($file, $args{'force_subdirs'});
	}
}

#@dirs = sort(@dirs);

unless ($args{'no_recurse'})
{
	foreach my $dir (@dirs)
	{
		extract_all_in_directory($dir);
	}
}

sub find_directories($)
{
	my @dirs = ();
	my $dir = shift;
	my $subdir;
	local *DIR;

	verbose("Searching for subdirectories in \"$dir\"\n", 1);

	unless (opendir(DIR, $dir))
	{
		warn "Can't open directory \"$dir\": $!\n";
		warn "Skipping...";
		return;
	}

	while ($subdir = readdir(DIR))
	{
		next if $subdir eq '.' or $subdir eq '..';
		next unless -d "$dir/$subdir";

		push(@dirs, "$dir/$subdir");
		push(@dirs, find_directories("$dir/$subdir"));
	}

	return @dirs;
}

sub extract($;$)
{
	my $file = shift;
	my $create_subdir = shift;
	my $cwd = getcwd;
	my ($cmd, $tmp);

	verbose("Determining whether \"$file\" can be extracted\n", 1);

	my @file_parsed = fileparse($file, @suffix_patterns);

	foreach my $suffix (@suffixes)
	{
		if ($file_parsed[2] =~ $suffix->[0])
		{
			if ($create_subdir)
			{
				verbose "Creating subdirectory \"$file_parsed[0]\"\n";
				unless (mkdir($file_parsed[0]))
				{
					warn "Can't create directory \"$file_parsed[0]\": $!\n";
					warn "Skipping...\n";
					return;
				}

				verbose "Entering subdirectory \"$file_parsed[0]\"\n";
				chdir($file_parsed[0]);
			}

			if ($create_subdir && $file !~ m#^/#)
			{
				$tmp = "../$file";
			} else {
				$tmp = $file;
			}

			($cmd = $suffix->[1]) =~ s/\$file/$tmp/g;

			verbose "Running command \"$cmd\"\n";
			my $rval = system("$cmd");
			#my $rval = system("false");

			if ($rval == 0)
			{
				if ($args{'delete_archives'})
				{
					verbose "Deleting archive file \"$tmp\"\n";
					unlink($tmp);
				}
			} else {
				warn "Extraction of \"$file\" failed with return value: " . ($? >> 8) . "\n";

				if ($args{'force_delete_archives'})
				{
					verbose "Deleting archive file \"$tmp\"\n";
					unlink($tmp)
						or warn "Cannot delete file \"$tmp\": $!\n";
				}

				if ($create_subdir)
				{
					chdir('..');
					verbose "Deleting empty directory \"$file_parsed[0]\"\n";
					rmdir($file_parsed[0])
						or warn "Cannot delete directory \"$file_parsed[0]\": $!\n";
				}
			}

			if ($create_subdir)
			{
				verbose "Leaving subdirectory \"$file_parsed[0]\"\n";
				chdir($cwd);
			}

			return;
		}
	}

	warn "Skipping file \"$file\"\n" unless $create_subdir;
}

sub extract_all_in_directory($)
{
	my $dir = shift;
	my $cwd = getcwd;
	my (@files, $file);

	verbose "Entering directory \"$dir\"\n";
	unless (chdir($dir))
	{
		warn "Can't chdir to $dir: $!\n";
		warn "Skipping...\n";
		return;
	}

	unless (opendir(DIR, '.'))
	{
		warn "Can't open directory \"$dir\": $!\n";
		return;
	}

	# Scan the directory before we start extracting, because extracting modifies
	# the current directory:
	while ($file = readdir(DIR))
	{
		next if $file eq '.' or $file eq '..';
		next if -d $file;

		push(@files, $file);
	}

	foreach $file (@files)
	{
		extract($file, ($args{'force_no_subdirs'} ? 0 : 1));
	}

	chdir($cwd);
}

sub usage(;$)
{
	my $rval = shift;
	my $pager = ($ENV{'PAGER'} ? $ENV{'PAGER'} : 'less');
	my ($where, @supported_formats, $out, $tmp);

	my %usage = (
		'--force-subdirs, -s' => "
    Force files specified on the command line to extracted in corresponding
    subdirectories.  This option only applies to filename arguments, not
    directories.",

		'--force-no-subdirs, -n' => "
    Force recursive extraction to not use corresponding subdirectories.  This
    option only applies to directory arguments, not filenames.",

		'--no-recurse, -r' => "
    Do not recurse into directories even if they're provided on the command
    line.",

		'--delete-archives, -d' => "
    Delete successfully extracted archives.  (Be careful!  If the archive
    command returns success even when there's been an error, it will still be
    removed!)",

		'--force-delete-archives, -D' => "
    Delete the archives even if extraction was unsuccessful.",

		'--verbose, -v' => "
    Increase verbosity level--this can be specified multiple times.",
	);


	foreach my $ext (@suffixes)
	{
		$tmp = $ext->[0];
		$tmp =~ s/^\([^:]+:(.*)\)/$1/g;
		$tmp =~ s/[\\\$\(\)]//g;
		push(@supported_formats, split('\|', $tmp));
	}

	$out .= "Usage: $basename [options] file/directory ...\n";

	$out .= <<"EOF" unless $rval || $args{'shorthelp'};
- For each non-directory specified on the command line, it will be extracted
  in place.
- For each directory specified on the command line, it will be recursively
  scanned for known archive files and they will be extracted into a
  subdirectory matching the archive filename, without the extension.

Recognized extensions:
EOF

	local $^A = '';
	local $| = 1;
	$tmp = join(', ', @supported_formats) . "\n";
	formline('  ^' . ('<' x 75) . "~~\n", $tmp);
	$out .= $^A . "\n" unless $rval || $args{'shorthelp'};

	$out .= "Options:\n";

	if ($rval || $args{'shorthelp'})
	{
		foreach my $key (sort {lc($a) cmp lc($b)} keys %usage)
		{
			$out .= "  $key\n";
		}

		$out .= "\n  --version, -V    Print version and copyright and exit.\n";
		$out .= "  --shorthelp, -H  Print this usage statement and exit.\n";
		$out .= "  --help, -h       Print a more detailed usage statement and exit.\n";
	} else {
		foreach my $key (sort {lc($a) cmp lc($b)} keys %usage)
		{
			$out .= "  $key" . $usage{$key} . "\n\n";
		}

		$out .= "  --version, -V\n    Print version and copyright and exit.\n\n";
		$out .= "  --shorthelp, -H\n    Print a short usage statement and exit.\n\n";
		$out .= "  --help, -h\n    Print this usage statement and exit.\n";
	}

	if ($rval)
	{
		$where = *STDERR;
	} elsif ($args{'shorthelp'})
	{
		$where = *STDOUT;
	} else {
		my $ttylines = (split(' ', `stty size 2>/dev/null`))[0] || 24;
		my $lines    = ($out =~ tr/\n//);

		if ($lines >= $ttylines)
		{
			require IO::File;
			$where = new IO::File "| $pager";
		} else {
			$where = *STDOUT;
		}
	}

	print $where $out;

	exit $rval;
}

sub verbose($;$)
{
	my $message = shift;
	my $level   = shift || 0;

	return unless $args{'verbose'} > $level;

	print "------ $message";
}