#!/usr/bin/perl
#: extract a tar/tgz/zip file enforcedly into a subdirectory, not allowing it to extract into the current one.
#
# Assumes you have GNU tar, gzip, and Info-Zip unzip.
#  -- sburke@cpan.org
#======================================================================
# Last Modified Time-stamp: "2010-02-22 03:39:23 AKST sburke@cpan.org"

require 5; package Adumbrate;
#======================================================================

# TODO: 
#  Handle --, --version, --help
# Namely, use a proper getopt module.

my $own_name = 'adumbrate';

#======================================================================

use warnings;
use strict;
use constant WIN => defined &Win32::BuildNumber;
use constant DEBUG => 0;
use Cwd;
my $UNZIP = "unzip";
my $TAR   = "tar";
my $UNRAR = "unrar";
my $GZIP  = "gzip";
my $BZIP2 = "bzip2";
my $MVDIR = WIN ? "move.exe" : "mv";
my $RENAMEDIR = WIN ? "rename" : "mv";

my %How = (
  'zip' => \&unzip,
  'jar' => \&unzip,
  'xpi' => \&unzip,

  'tar' => \&untar,

  'tar.bz2' => \&untarbz2,

  'tar.gz' => \&untgz,
  'tgz'    => \&untgz,


  'rar'  => \&unrar,
  'jpeg' => \&unrar,
  'jpg'  => \&unrar,
  'gif'  => \&unrar,
  'png'  => \&unrar,


);

#======================================================================

my $TAR_UNGZ    = "--ungzip";
my $TAR_UNBZIP2 = "--bzip"  ;

#======================================================================

select STDERR; $|++; select STDOUT; $|++;
use File::Basename;

@ARGV = grep length($_), @ARGV;
shift @ARGV if @ARGV and $ARGV[0] eq '--';

my $in = $ARGV[0];
my($path, $base, $output_dir, $fullbase, $ext, $temp);

do_multiples(@ARGV) if @ARGV > 1;
die "Usage: $own_name [archivename]\n" unless @ARGV == 1 and length $ARGV[0];

prep();
handle();
dirfun();
exit;

#--------------------------------------------------------------------------

sub do_multiples {
  # calling myself is the only way to insulate against the chdirs
  my @error_adumbrations;

  foreach my $i (@ARGV) {
    DEBUG > -1 and print "% $own_name $i\n";
    unless(  0==system($own_name, "--", $i)  ) {
      push @error_adumbrations, $i;
    }
  }

  if(@error_adumbrations) {
    warn "Error in adumbrating:\n";
    foreach my $e (@error_adumbrations) {
      warn "\t$e\n";
    }
    exit 1;
  }
  exit;
}

#======================================================================

sub prep {
  die "No such file as $in\nAborting"     unless -e $in;
  die "Not a file: $in\nAborting"         unless -f $in;
  die "File $in isn't readable\nAborting" unless -r $in;
  
  $path = dirname(  $in );
  $base = basename( $in );
  
  die "Usage: $own_name archivefile [archivefile...]\n"
   unless defined $base and length $base;
  
  $fullbase = $base;
  
  if( $base =~ s{\.(tar\.gz|tar\.bz2|[a-zA-Z0-9]{1,4})$}{} ) {
    $ext = lc $1;
    #$ext = "tgz" if $ext eq "tar.gz";
  } else {
    die "no extension on $base?";
  }
  $output_dir = $base;

  die "I don't know how to adumbrate an \"$ext\" file.\n"
   unless $How{$ext};
  
  die "What, a 0-length basename?" unless length $base;
  
  $path = '' if !defined($path) or $path eq '.';
  $path =~ s{/}{\\} if WIN;
  
  
  if(length $path) {
    die "No such dir as $path" unless -e $path;
    die    "The path $path isn't a directory\nAborting"    unless -d _;
    die  "The directory $path isn't readable\nAborting"  unless -r _;
    die "The directory $path isn't writeable\nAborting" unless -w _;
    chdir( $path ) or die "adumbrate: Can't chdir to $path : $!\n";
  }
  
  -e $fullbase or die "Can't find $path somehow!?!?";
  
  $temp = devise_temp_dir_name();
  
  DEBUG and print "Ready: path{$path} base{$base} ext{$ext} tempdir{$temp}\n";
  
  DEBUG and print "mkdir $temp  # temp directory\n";
  mkdir $temp or die "Can't mkdir $temp: $!";
  die "What, can't find $temp?!" unless -e $temp and -d _ and -r _;
  die "What, $temp isn't writeable?" unless -w _;
  my $test_out = "$temp/thing.txt";
  open(TESTOUT, ">", $test_out) or die "Can't write-open a test file $test_out: $!";
  print TESTOUT "\n\n\n";
  close(TESTOUT);
  sleep 0;
  die "What, $test_out doesn't exist?!" unless -e $test_out and -s _;
  unlink $test_out or die "What, can't unlink $test_out !?";
 
  return;
}

#--------------------------------------------------------------------------

sub handle {
  if($How{$ext}) {
     $How{$ext}->($fullbase);
  } else {
    die "What, I don't know how to handle $ext?\n";
  }
  return;
}

#--------------------------------------------------------------------------

sub dirfun {

  DEBUG and print "Now seeing what got extracted...\n";

  my @files_in_temp = do {
    opendir(TEMPDIR, $temp) or die "What, can't opendir $temp : $! ";
    my @x = grep { $_ ne '.' and $_ ne '..' } readdir(TEMPDIR);
    closedir(TEMPDIR);
    @x;
  };
  
  DEBUG and print "Files in $temp\n  ", scalar(@files_in_temp),
    ": ", join(" ", map "[$_]", @files_in_temp), "\n";

  if( @files_in_temp == 0 ) {
    rmdir( $temp ) or warn "Can't unlink tempdir: $temp: $!";
    die "Hm, that produced no output files?\n";
  
  } elsif( @files_in_temp == 1 and -d "$temp/$files_in_temp[0]") {  # expected case
    
    my $there = $files_in_temp[0];
    if( $there eq $output_dir ) {
      # Exactly as expected, no need for comment
    } else {
      print "Extracted: $there\n";
    }
    
    my $from = bs("$temp/$there");
    touch($from);    

    if( -e $there ) {
      print "I would move $temp/$there up, but there's already a ../$there !\n";
    } else {
      moveup( $from, ".", bs("./$there") );
      rmdir( $temp ) or warn "Odd, I couldn't rmdir $temp: $!";
    }
  
  } else {
    touch($temp);
    if(-e $output_dir) {
      print "I would rename $temp to $output_dir, but $base already exists!!\n";
    } else {
      renamedir( $temp, $output_dir );
    }
  }
  return;
}

#========================================================================

sub devise_temp_dir_name {
  # Used to be:
  #  sprintf "temp_%x_%x", (WIN ? (Win32::GetTickCount(),0) : ($$, $^T))
  # But when that left a temp dir lying around, it would result in
  #  an ugly name in the error message, like:
  # "I would move temp_1015_48aa25f3/guh up, but there's already a ../guh !"

  # Now at least it's
  # I would move adumbrate_temp_2867/guh up, but there's already a ../guh !
  #              ^^^^^^^^^^^^^^^^^^^

  my $dirname;
  while(1) {
    # my super-friendly dirname maker:
    my $num = sprintf "%04o", int rand( 010000 ); # yes, octal 0 to 7777 !
    $num =~ tr[0-7][2-9]; # since 0 and 1 look like O and l, which is UNPRETTY.
    $dirname = "adumbrate_temp_$num";
    last unless -e $dirname;
  }
  return $dirname;
}

#======================================================================
sub touch {
  my $now = time();
  DEBUG and print "Touching @_ to now ($now)... ";
  my $success = utime($now, $now, @_);
  DEBUG and print " (", $success ? "S" : "Uns", "uccessfully)\n";
  return;
}
#========================================================================

sub shell {
  DEBUG and print " . Shelling to @_\n";
  if( 0 == system @_ ) {
    DEBUG and print " . Happily back from @_\n";
    sleep 0;
    return;
  }
  die "Error calling @_ : $?\nAborting";
}

sub bs {
  my $in = $_[0];
  $in =~ s{/}{\\}g if WIN;
  return $in;
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub untgz {
  if(WIN) {
    my $temptar = "$temp.tar";
    gunzip( $fullbase, $temptar );
    untar(  $temptar );
    unlink( $temptar );
  } else {
    untar($fullbase, $TAR_UNGZ);
  }
}

sub untarbz2 {
  if(WIN) {
    my $temptar = "$temp.tar";
    unbzip2( $fullbase, $temptar );
    untar(  $temptar );
    unlink( $temptar );
  } else {
    untar($fullbase, $TAR_UNBZIP2);
  }
}

sub untar {
  my($from, @switches) = @_;
  DEBUG and print "Calling tar [@_]...\n";
  shell $TAR, "--directory", $temp, "-x", "-f", $from, @switches;
}

sub unzip {
  my($from, @switches) = @_;
  DEBUG and print "Calling unzip...\n";
  shell $UNZIP, '-q', "-d", $temp, @switches, $from;
}

sub unrar {
  my($from, @switches) = @_;
  $output_dir =~ s<\.part1$><>s;
  DEBUG and print "Calling unrar...\n";
  my $here = getcwd;
  chdir($temp) or die "Can't chdir to $temp for unrarring!\n";
  shell $UNRAR, 'x', # was 'e'
           "../$from";
  chdir($here);
}

sub unbzip2 {
  my($from, @switches) = @_;
  DEBUG and print "Calling unbzip2...\n";
  shell $BZIP2, '-q', "-d", $temp, @switches, $from;
}

sub renamedir { # in current directory
  my($from, $to) = @_;
  shell $RENAMEDIR, $from, $to;
  if( -e $from ) {
    if( -e $to ) {
      print "The dir $from still exists, as well as $to ?!\n";
    } else {
      print "Couldn't rename $from to $to\n";
    }
  } else {
    # expected case
    DEBUG and print "OK, happily renamed $from to $to\n";
  }
}


sub moveup {
  my($from, $to, $then) = @_;
  shell $MVDIR, $from, $to;
  if( -e $then ) {
    if( -e $from ) {
      print "The dir $from still exists, as well as $then!\n";
    } else {
      # expected case
      DEBUG and print "OK, happily moved-up $then\n";
    }
  } else {
    print "Moving $from move seemed to fail, producing no $then\n";
  }
}

sub gunzip {
  my($fullbase, $temptar) = (@_);
  DEBUG and print "Calling gunzip $fullbase => $temptar ...\n";

  die "$fullbase is too weird a filename.\nAborting"
   if $fullbase =~ m/[\";\`\\\$]/;

  shell qq[$GZIP -d -c < "$fullbase" > "$temptar"];

  die "Can't find the $temptar I just made?!"
   unless -e $temptar and -f _ and -w _ and -s _;

  return;
}

#========================================================================

__END__