#!/usr/bin/perl -w
###############################################################################
# Copyright 2000, Michael Conrad Tilstra <tadpol@tadpol.org>
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions, and the following disclaimer.
# 
# 2. 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.
# 
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR 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 is my attempt to build an emulation of the extractor from
# BeOS in perl/Tk.  This way I can use it with dfm....
# It is intended to be unix only.
#
# To add support for more archive types, you just need to edit this script.
# Jump to the end of the script, and there is the information that describes
# how to use different archive tools.  The format is simple, the file
# extension you want to be recognised, tab, the command to expand it, tab,
# the command to list the contents.  So for .tar.gz the entry looks like
# this:  .tar.gz	zcat %s | tar xf -	zcat %s | tar tf -

use Tk;
use Tk::ErrorDialog;
use Tk::FileSelect;
use File::Basename;
use File::Path;
use Cwd;

# hande cmdine args in the future....



# load prefs, they're down at the end in the DATA section....
%expandhsh = ();
while(<DATA>) {
	chomp;
	next if /^#/;
	next unless s/^(.*?)\t//;
	$expandhsh{$1} = [split("\t",$_)];
}
# Make this look at some user defaults soon....

# setup globals
my $sourcefile = cwd() . '/';
my $destfolder = cwd();
if( defined $ARGV[0] ){
	if( $ARGV[0] =~ m!^/! ) {
		$sourcefile = $ARGV[0];
	} else {
		$sourcefile = cwd() .'/'. $ARGV[0];
	}
	$destfolder = dirname($sourcefile);
}
my $archivelistvisable = 'no';

# first build an interface.....

my $MW = MainWindow->new;

#The Source line....
my $srcfrm = $MW->Frame;
my $srcbtn = $srcfrm->Button(-text =>'Source',
                             -width => 11,
									  -command => \&getnewsourcefile );
my $srcntr = $srcfrm->Entry(-width => 50, -textvariable => \$sourcefile);
$srcbtn->pack(-side => 'left');
$srcntr->pack(-side => 'left', -fill => 'x');

#The Destination line....
my $dstfrm = $MW->Frame;
my $dstbtn = $dstfrm->Button(-text =>'Destination',
		-width => 11,
		-command => \&getnewdestfolder);
my $dstntr = $dstfrm->Entry(-width => 50, -textvariable => \$destfolder);
$dstbtn->pack(-side => 'left');
$dstntr->pack(-side => 'left', -fill => 'x');

# The buttons that sit on the bottom
my $bfrm = $MW->Frame();
my $ebtn = $bfrm->Button(-text => 'Expand', -command => \&ExpandIt);
my $cbtn = $bfrm->Button(-text => 'Cancel', -command => \&exit);
my $lbtn = $bfrm->Checkbutton(-text => 'List Contents',
		                        -variable => \$archivelistvisable,
										-offvalue => 'no',
										-onvalue => 'yes',
										-command => \&toggellistvis);
$ebtn->pack(-side => 'left');
$cbtn->pack(-side => 'left');
$lbtn->pack(-side => 'right');

# The mostly hidden archive contents list
my $arclist = $MW->Scrolled('Listbox', -scrollbars => 'osre');

# Now piece together the main window.
$srcfrm->pack(-side => 'top', -fill => 'x');
$dstfrm->pack(-side => 'top', -fill => 'x');
$bfrm->pack(-side => 'top', -fill => 'x');

# Now get everything running!
MainLoop;


# subroutines.

sub getnewsourcefile {
	my $fsel = $MW->FileSelect(-directory => dirname($sourcefile),
	                           -filter => '*.gz',
										);
	my $tmp =  $fsel->Show;
	if( defined $tmp ) {
		$sourcefile = $tmp;
	}
}

sub getnewdestfolder {
	my $fsel = $MW->FileSelect(-directory => $destfolder,
			                     -verify => ['-d'],
										-create => 'true',
										);
	my $tmp =  $fsel->Show;
	if( defined $tmp ) {
		$destfolder = $tmp;
	}
}

sub toggellistvis {
	if($archivelistvisable eq 'yes') {
# Run commands needed to get list of contents for this list.
		&fillListView;
		$arclist->pack(-side => 'top', -fill => 'both');
	} else {
		$arclist->packForget;
	}
}

# ok, now the function to do the expand.
# make the entire path stated be destfolder, switch to it, and expand the
# archive.
sub ExpandIt {
	$MW->Busy;
	my $suffix = getsuffix($sourcefile);

	if( $suffix ne '' ) {
		mkpath($destfolder);
		chdir $destfolder;
		my $cmd = replacecmd( $expandhsh{$suffix}[0], $sourcefile);
		open( RUNAPP, $cmd . " |")
			or displayError("Could not open pipe to $cmd: $!", 'yes');
		while(<RUNAPP>) {
# This is how I'll do visual feedback in the future.
		}
		close RUNAPP;
	} else {
		displayError("File type not supported, Ignoring command");
	}
	$MW->Unbusy;
}

# This function will clear out the contents of the archivelist, run the
# list cmd that matches the file type in source, and pipe the contents back
# into the list window.
sub fillListView {
	$MW->Busy;
	my $suffix = getsuffix($sourcefile);
	$arclist->delete(0,'end');
	
	if( $suffix ne "" ) {
		my $cmd = replacecmd( $expandhsh{$suffix}[1], $sourcefile);
		open( LISTAPP, $cmd . " |")
			or displayError("Could not open pipe to $cmd: $!", 'yes');
		while(<LISTAPP>) {
			chomp;
			$arclist->insert('end',$_);
		}
		close LISTAPP;
	} else {
		displayError("File type not supported, Ignoring command");
	}
	$MW->Unbusy;
}
	
# both gets the extension, and checks to see if we can handle that type.
# If it isn't know, returns nothing.
sub getsuffix {
	my $file = basename(shift);
	my @ktypes = keys %expandhsh;
	my ($name, $path, $suffix) = fileparse($file, @ktypes);
	return $suffix;
}

# takes the cmd, and source.  grabs all %s in cmd and replaces with
# source.
sub replacecmd {
	my $cmd = shift;
	my $src = shift;
	my $sq = '%s';
	$cmd =~ s/$sq/$src/g;

	return $cmd;
}

# Can't find a nice simeple error dialog. 
# Making one.
sub displayError {
	my $msg = shift;
	my $death = shift;

	my $d = $MW->Dialog(-title => 'Error',
					-text => $msg,
					);
	$d->Show;

	if(defined $death) {
		exit;
	}
}

##############################################################################
# default extension type handling is here.
# format is as follows:
# <file extension><tab><expand cmd><tab><list cmd>
# lines starting with `#' are ignored.
# assume a cd <destination> before each expand cmd.
# the `%s' is replaced with the source line.
__DATA__
#tar, gzip
.tar.gz	zcat %s | tar xf -	zcat %s | tar tf -
# damn dos.
.tgz	zcat %s | tar xf -	zcat %s | tar tf -
.taz	zcat %s | tar xf -	zcat %s | tar tf -
#zip
.zip	unzip %s	unzip -l %s
#gzip
.gz	gunzip -c %s	gunzip -l %s
#binhex
# The redirection on the list for hexbin scares me.  I will bet its not
# very portable....
.hqx	hexbin -U %s	hexbin -i %s 2>&1
#lha
.lha	lha x %s	lha v %s
.lzh	lha x %s	lha v %s
#rar
.rar	unrar e %s	unrar l %s
#unarj
.arj	unarj e %s	unarj l %s