Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

Ensure Zip files always unpack to a single subdirectory

by bbfu (Curate)
on Jan 07, 2003 at 08:28 UTC ( [id://224907]=sourcecode: print w/replies, xml ) Need Help??
Category: Utility Scripts
Author/Contact Info /msg bbfu
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.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://224907]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (4)
As of 2025-07-08 01:16 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found

    Notices?
    erzuuliAnonymous Monks are no longer allowed to use Super Search, due to an excessive use of this resource by robots.