Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl-Sensitive Sunglasses
 
PerlMonks  

Ensure Zip files always unpack to a single subdirectory

by bbfu (Curate)
on Jan 07, 2003 at 08:28 UTC ( #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.

Comment on Ensure Zip files always unpack to a single subdirectory
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (7)
As of 2015-07-28 06:17 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (252 votes), past polls