#!/usr/bin/perl

# NEXT STEPS:
#       - remove 'no_chdir' from File::Find, and then JUST before unpacking a file, chdir into the
#         newly-created subdir, and run the unpacker (on "../filename") from there, and then RIGHT AFTER,
#         chdir("..")
#       - major goal: get SOME unpacking working...  if it's working just a little bit, we'll finally
#         be able to see the light at the end of the tunnel
#
# TODO:
#	- get command-line parsing working
#	- is there a way to detect if .exes have .zip files embedded inside them?
#		- maybe just run "7z l" on EVERY file we come across?  Or is that excessive?



# extracts files from container packages, recursively
#
#       $ expando slax.iso
#       expanding slax.iso
#       expanding slax.iso!/boot/initrd.gz
#       expanding slax.iso!/slax/slaxsave.zip
#       expanding slax.iso!/slax/modules/1-001-core.lzm
#
#
# This isn't designed to be compatible with Windows-based Perl.  It relies on magic(5), and availability of many Linux-specific extractors

	use strict;
	use warnings;

	use File::Find;





find({
	wanted => sub {check_one_file($File::Find::name)},
	no_chdir => 1,
	}, ".");


sub check_one_file {
	my $filename = shift;

        # we only care about container files, which means we don't care about directories
	return if (!-f $filename);

        # is this a container file?
	my ($container_type, $is_compressed) = get_container_type($filename);
        return unless $container_type;

        # have we processed this in a previous lifetime?
        if (-d $filename . "!") {
                print "DONE:  $filename\n";
                return;
        }

        unpack_file($filename, $is_compressed, $container_type);
}


## how many ways are there to unpack a container file?  too many.
sub unpack_file {
        my $filename = shift;
        my $is_compressed = shift;
        my $container_type = shift;

        # does a specialized unpacker function exist for this?
        if (exists $::{"unpack_$container_type"} 
                && defined(&{$::{"unpack_$container_type"}}))
        {
                return $::{"unpack_$container_type"}->($filename, $is_compressed);
        } else {
                printf "CANT YET UNPACK:  %s  [%s]\n", $filename, $container_type;
        }

}

sub unpack_cab {
        my $filename = shift;
        my $is_compressed = shift;

        die "Don't know how to handle compressed files yet\n\t" if ($is_compressed);

        if (is_program_available("cabextract")) {
                readpipe_args("cabextract", 
                print "yay:  $filename\n";
        }
        #if ($< == 0) {          # are we root?
        #}
}


BEGIN {
        my %program_available_cache = ();

# check if the given program is available in the path somewhere
sub is_program_available {
        my $program = shift;

        if (exists $program_available_cache{$program}) {
                return $program_available_cache{$program};
        }

        my ($out) = readpipe_args("which", $program);
        $program_available_cache{$program} = ($out =~ /\S/);
}
}

# use magic(5)  (/usr/share/file/magic)  to figure out what filetype the specified file is, based on its
# contents, ignoring its filename
sub get_container_type {
	my $filename = shift;

	my ($filetype) = readpipe_args("file", "--brief", $filename);

        my $is_compressed = '';
	if ($filetype =~ /^gzip compressed data|^bzip2 compressed data/) {
                ($is_compressed) = (split ' ', $filetype)[0];
		($filetype) = readpipe_args("file", "--brief", "--uncompress", $filename);
	}

        my $type = '';
	$filetype =~ /^Microsoft Cabinet archive/	&& ($type = 'cab');
	$filetype =~ /^POSIX tar archive/		&& ($type = 'tar');
	$filetype =~ /FAT filesystem|FAT \((?:12|16|32) bit\)|FAT(?:12|16|32)/		&& ($type = 'fs:vfat');
	$filetype =~ /^ISO 9660 CD-ROM/			&& ($type = 'fs:iso9660');
	$filetype =~ /cpio archive/			&& ($type = 'cpio');
	$filetype =~ /^Zip archive/			&& ($type = 'zip');
	$filetype =~ /^UHA UHarc archive/		&& ($type = 'uha');

        if (wantarray) {
                return ($type, $is_compressed);
        } else {
                return $type;
        }
}


# like qx// or readpipe(), BUT it allows you to give explicitely delimited args, so you don't have to worry about escaping quotes
sub readpipe_args {
	my @args = @_;

	local *STDOUT_PIPE;
	my $pid = open(STDOUT_PIPE, "-|");
	defined($pid) or die "Unable to fork: $!\n\t";
	if (!$pid) {
		# child's STDOUT is parent's STDOUT_PIPE
		exec {$args[0]} @args;
		die "Unable to exec $args[0]: $!";
	}

	my $stdout = do {local $/=undef; <STDOUT_PIPE>} || "";
	close STDOUT_PIPE;
	waitpid($pid, 0);
        my $retval = $?;

	return ($stdout, $retval);
}