#!/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.
|