Ensure Zip files always unpack to a single subdirectory

[bbfu]

Category:

Utility Scripts

Description:

hardburn requested a utility that would ensure that Zip files did not "explode", or unpack files into the current directory, by extracting into a subdirectory if the Zip file was not already set up to do so.

#!/usr/bin/perl
use warnings;
use strict;

use Archive::Zip qw( :ERROR_CODES );

my $File = shift or die "Must supply a file name.\n";

Archive::Zip::setErrorHandler sub { die @_ };  # Make errors fatal

my $zip = Archive::Zip->new();

$zip->read($File);

my $flag;

# Flag if there is more than one "root item", be it file or subdir
my $first = ($zip->members())[0]->fileName() =~ m{^([^/]*)/} && $1;
for ($zip->members()) {
  if(
    # Flag if it's not under a subdir...
    $_->fileName() !~ m{/} or $_->fileName() =~ m{^\./[^/]+$} or
    # ...or if it's under a different subdir
    ($_->fileName() =~ m{^([^/]*)/} and $1 ne $first)
   ) {
     $flag = 1;
     last;
   }
}

# Alternatively, you could just...
# Flag if any files are not under a directory
# (you could still have multiple subdirs extracted)
#for ($zip->members()) {
#  if($_->fileName() !~ m{/} or $_->fileName() =~ m{^\./[^/]+$}) {
#    $flag = 1;
#    last;
#  }
#}

if($flag) {
  (my $folder = $File) =~ s/\.zip$//;

  # Relocate all members into a subdir who's name is based on the zip 
+file
  for my $member ($zip->members()) {
    $member->fileName($folder . '/' . $member->fileName());
  }
}

# Now that we know it's safe, go ahead and unpack it

# Normally, would just use $zip->extractTree() but there seems to
# be a bug that adds a single . to the begining of all the top-level
# files.  This, of course, makes them hidden (by default) under *nix.
$zip->extractMember($_) for $zip->members;

# Or, of course, you could just $zip->overwrite() to save it back.