/tmp/lib/0000755000076500000000000000000010467261037011653 5ustar cmoorewheel/tmp/lib/Archive/0000755000076500000000000000000010467261263013235 5ustar cmoorewheel/tmp/lib/Archive/Any/0000755000076500000000000000000010467261243013762 5ustar cmoorewheel/tmp/lib/Archive/Any/Tar.pm0000644000076500000000000000153510467261037015053 0ustar cmoorewheelpackage Archive::Any::Tar; use strict; use Archive::Tar; use Cwd; =head1 NAME Archive::Any::Tar - Archive::Any wrapper around Archive::Tar =head1 SYNOPSIS B Use Archive::Any instead. =head1 DESCRIPTION Wrapper around Archive::Tar for Archive::Any. =cut sub can_handle { return ( [ 'tar','tar.gz','tgz' ] ); } sub files { my( $self, $file ) = @_; my $t = Archive::Tar->new( $file ); $t->list_files; } sub extract { my ( $self, $file, $dir ) = @_; my $t = Archive::Tar->new( $file ); my $orig_dir; if ($dir) { $orig_dir = getcwd; chdir $dir; } my $success = $t->extract; if ($dir) { chdir $orig_dir; } return $success; } =head1 AUTHOR Michael G Schwern Eschwern@pobox.comE =head1 SEE ALSO Archive::Any, Archive::Tar =cut 1; /tmp/lib/Archive/Any/Zip.pm0000644000076500000000000000163210467261037015065 0ustar cmoorewheel package Archive::Any::Zip; use strict; use vars qw($VERSION @ISA); $VERSION = 0.03; use Archive::Zip qw(:ERROR_CODES); use Cwd; =head1 NAME Archive::Any::Zip - Archive::Any wrapper around Archive::Zip =head1 SYNOPSIS B Use Archive::Any instead. =head1 DESCRIPTION Wrapper around Archive::Zip for Archive::Any. =cut sub can_handle { return( [ 'zip','pk3','jar' ] ); } sub files { my( $self, $file ) = shift; my $z = Archive::Zip->new( $file ); $z->memberNames; } sub extract { my($self, $file, $dir) = @_; my $z = Archive::Zip->new( $file ); my $orig_dir; if( $dir ) { $orig_dir = getcwd; chdir $dir; } warn( "in $dir" ); $z->extractTree; if( $dir) { chdir $orig_dir; } return 1; } =head1 AUTHOR Michael G Schwern Eschwern@pobox.comE =head1 SEE ALSO Archive::Any, Archive::Zip =cut 1; /tmp/lib/Archive/Any.pm0000644000076500000000000001106710467262704014330 0ustar cmoorewheel =head1 NAME Archive::Any - Single interface to deal with zips and tarballs =head1 SYNOPSIS use Archive::Any; my $archive = Archive::Any->new($archive_file); my @files = $archive->files; $archive->extract; my $type = $archive->type; $archive->is_impolite; $archive->is_naughty; =head1 DESCRIPTION This module is a single interface for manipulating different archive formats. Tarballs, zip files, etc... Currently only tar (with or without gzip) and zip are supported. Currently only supports unpacking. =over 4 =item B ` my $archive = Archive::Any->new($archive_file); my $archive = Archive::Any->new($archive_file, $type); Creates an Archive::Any object representing $file, but don't do anything with it yet. $type is optional. It lets you force the file type in-case Archive::Any can't figure it out. 'tar' or 'zip' is currently accepted. =item B my $type = $archive->type; Returns the type of archive this is. Currently 'zip' or 'tar'. =item B my $is_impolite = $archive->is_impolite; Checks to see if this archive is going to unpack into the current directory rather than create its own. =item B my $is_naughty = $archive->is_naughty; Checks to see if this archive is going to unpack B the current directory. =back =head1 AUTHOR Michael G Schwern Eschwern@pobox.comE =cut package Archive::Any; use Carp::Always; use strict; use warnings; use vars qw($VERSION @ISA); $VERSION = 0.06; use File::Spec::Functions qw(rel2abs splitpath splitdir); use File::Type; use MIME::Types; use Module::Find; use Data::Dumper; # my $a = Archive::Any->new( '/tmp/file.zip', 'zip' ); # # Pick a plugin. # sub new { my ( $proto, $file, $type ) = @_; return undef unless -f $file; my $available; my @plugins = findsubmod Archive::Any; foreach my $plugin ( @plugins ) { eval "require $plugin"; next if $@; my $a = $plugin->can_handle(); if ( ref($a) eq 'ARRAY' ) { foreach my $h ( @{$a} ) { next if exists( $available->{$h} ); $available->{$h} = $plugin; } } else { $available->{$a} = $plugin; } } my $handler; if ( $type ) { my $mime_type = MIME::Types->new()->mimeTypeOf( $type ); do { die( "No handler available for type $type" ); } unless exists( $available->{$type} ); $handler = $available->{$type}; } else { my $mime_type = File::Type->new()->checktype_filename( $file ); # MIME::Types has a funky interface. # it's not immediately apparent until you try it in the debugger. my $mo = new MIME::Types; my MIME::Types $lol_wtf = $mo->type( $mime_type ); print Dumper( $lol_wtf->extensions() ); my @x = $lol_wtf->extensions(); print Dumper( @x ); my $extension = $x[0]; do { die( "Can't determine the file extension for mime type: $mime_type" ); } unless $extension; do { warn( Dumper( $available ) ); die( "No handler available for type extension '$extension'" ); } unless exists( $available->{$extension} ); $handler = $available->{$extension}; } return bless { file => $file, handler => $handler, }, $proto; } =item B $archive->extract; $archive->extract($directory); Extracts the files in the archive to the given $directory. If no $directory is given, it will go into the current working directory. =cut sub extract { my $self = shift; my $dir = shift; if ( defined( $self->{forced} ) ) { print( "Forced\n" ); } else { print( "Not forced.\n" ); } if ( exists( $self->{mime} ) ) { print( "Mime looks good.\n" ); } my $plugin = $self->{available}->{$self->{mime}}; defined( $dir ) ? return $plugin->extract( $self->{file}, $dir ) : $plugin->extract( $self->{file} ); } =item B my @file = $archive->files; A list of files in the archive. =cut sub files { my( $self, $file ) = @_; return undef unless $self->{mime}; return $self->{handler}->files( $self->{file} ); } sub is_impolite { my ($self) = shift; my @files = $self->files; my $first_file = $files[0]; my ($first_dir) = splitdir($first_file); return grep( !/^\Q$first_dir\E/, @files ) ? 1 : 0; } sub is_naughty { my ($self) = shift; return ( grep { m{^(?:/|(?:\./)*\.\./)} } $self->files ) ? 1 : 0; } sub handler { my $self = shift; return $self->{handler}; } 1;