Archive-Ar-2.02/0000755000175000017500000000000012360660323011475 5ustar jsbjsbArchive-Ar-2.02/lib/0000755000175000017500000000000012360660323012243 5ustar jsbjsbArchive-Ar-2.02/lib/Archive/0000755000175000017500000000000012360660323013624 5ustar jsbjsbArchive-Ar-2.02/lib/Archive/Ar.pm0000644000175000017500000005014712360657345014545 0ustar jsbjsb########################################################### # Archive::Ar - Pure perl module to handle ar achives # # Copyright 2003 - Jay Bonci # Copyright 2014 - John Bazik # Licensed under the same terms as perl itself # ########################################################### package Archive::Ar; use base qw(Exporter); our @EXPORT_OK = qw(COMMON BSD GNU); use strict; use File::Spec; use Time::Local; use Carp qw(carp longmess); use vars qw($VERSION); $VERSION = '2.02'; use constant CAN_CHOWN => ($> == 0 and $^O ne 'MacOS' and $^O ne 'MSWin32'); use constant ARMAG => "!\n"; use constant SARMAG => length(ARMAG); use constant ARFMAG => "`\n"; use constant AR_EFMT1 => "#1/"; use constant COMMON => 1; use constant BSD => 2; use constant GNU => 3; my $has_io_string; BEGIN { $has_io_string = eval { require IO::String; IO::String->import(); 1; } || 0; } sub new { my $class = shift; my $file = shift; my $opts = shift || 0; my $self = bless {}, $class; my $defopts = { chmod => 1, chown => 1, same_perms => ($> == 0) ? 1:0, symbols => undef, }; $opts = {warn => $opts} unless ref $opts; $self->clear(); $self->{opts} = {(%$defopts, %{$opts})}; if ($file) { return unless $self->read($file); } return $self; } sub set_opt { my $self = shift; my $name = shift; my $val = shift; $self->{opts}->{$name} = $val; } sub get_opt { my $self = shift; my $name = shift; return $self->{opts}->{$name}; } sub type { return shift->{type}; } sub clear { my $self = shift; $self->{names} = []; $self->{files} = {}; $self->{type} = undef; } sub read { my $self = shift; my $file = shift; my $fh = $self->_get_handle($file); local $/ = undef; my $data = <$fh>; close $fh; return $self->read_memory($data); } sub read_memory { my $self = shift; my $data = shift; $self->clear(); return unless $self->_parse($data); return length($data); } sub contains_file { my $self = shift; my $filename = shift; return unless defined $filename; return exists $self->{files}->{$filename}; } sub extract { my $self = shift; for my $filename (@_ ? @_ : @{$self->{names}}) { $self->extract_file($filename) or return; } return 1; } sub extract_file { my $self = shift; my $filename = shift; my $target = shift || $filename; my $meta = $self->{files}->{$filename}; return $self->_error("$filename: not in archive") unless $meta; open my $fh, '>', $target or return $self->_error("$target: $!"); binmode $fh; syswrite $fh, $meta->{data} or return $self->_error("$filename: $!"); close $fh or return $self->_error("$filename: $!"); if (CAN_CHOWN && $self->{opts}->{chown}) { chown $meta->{uid}, $meta->{gid}, $filename or return $self->_error("$filename: $!"); } if ($self->{opts}->{chmod}) { my $mode = $meta->{mode}; unless ($self->{opts}->{same_perms}) { $mode &= ~(oct(7000) | (umask | 0)); } chmod $mode, $filename or return $self->_error("$filename: $!"); } utime $meta->{date}, $meta->{date}, $filename or return $self->_error("$filename: $!"); return 1; } sub rename { my $self = shift; my $filename = shift; my $target = shift; if ($self->{files}->{$filename}) { $self->{files}->{$target} = $self->{files}->{$filename}; delete $self->{files}->{$filename}; for (@{$self->{names}}) { if ($_ eq $filename) { $_ = $target; last; } } } } sub chmod { my $self = shift; my $filename = shift; my $mode = shift; # octal string or numeric return unless $self->{files}->{$filename}; $self->{files}->{$filename}->{mode} = $mode + 0 eq $mode ? $mode : oct($mode); return 1; } sub chown { my $self = shift; my $filename = shift; my $uid = shift; my $gid = shift; return unless $self->{files}->{$filename}; $self->{files}->{$filename}->{uid} = $uid if $uid >= 0; $self->{files}->{$filename}->{gid} = $gid if defined $gid && $gid >= 0; return 1; } sub remove { my $self = shift; my $files = ref $_[0] ? shift : \@_; my $nfiles_orig = scalar @{$self->{names}}; for my $file (@$files) { next unless $file; if (exists($self->{files}->{$file})) { delete $self->{files}->{$file}; } else { $self->_error("$file: no such member") } } @{$self->{names}} = grep($self->{files}->{$_}, @{$self->{names}}); return $nfiles_orig - scalar @{$self->{names}}; } sub list_files { my $self = shift; return wantarray ? @{$self->{names}} : $self->{names}; } sub add_files { my $self = shift; my $files = ref $_[0] ? shift : \@_; for my $path (@$files) { if (open my $fd, $path) { my @st = stat $fd or return $self->_error("$path: $!"); local $/ = undef; binmode $fd; my $content = <$fd>; close $fd; my $filename = (File::Spec->splitpath($path))[2]; $self->_add_data($filename, $content, @st[9,4,5,2,7]); } else { $self->_error("$path: $!"); } } return scalar @{$self->{names}}; } sub add_data { my $self = shift; my $path = shift; my $content = shift; my $params = shift || {}; return $self->_error("No filename given") unless $path; my $filename = (File::Spec->splitpath($path))[2]; $self->_add_data($filename, $content, $params->{date} || timelocal(localtime()), $params->{uid} || 0, $params->{gid} || 0, $params->{mode} || 0100644) or return; return $self->{files}->{$filename}->{size}; } sub write { my $self = shift; my $filename = shift; my $opts = {(%{$self->{opts}}, %{shift || {}})}; my $type = $opts->{type} || $self->{type} || COMMON; my @body = ( ARMAG ); my %gnuindex; my @filenames = @{$self->{names}}; if ($type eq GNU) { # # construct extended filename index, if needed # if (my @longs = grep(length($_) > 15, @filenames)) { my $ptr = 0; for my $long (@longs) { $gnuindex{$long} = $ptr; $ptr += length($long) + 2; } push @body, pack('A16A32A10A2', '//', '', $ptr, ARFMAG), join("/\n", @longs, ''); push @body, "\n" if $ptr % 2; # padding } } for my $fn (@filenames) { my $meta = $self->{files}->{$fn}; my $mode = sprintf('%o', $meta->{mode}); my $size = $meta->{size}; my $name; if ($type eq GNU) { $fn = '' if defined $opts->{symbols} && $fn eq $opts->{symbols}; $name = $fn . '/'; } else { $name = $fn; } if (length($name) <= 16 || $type eq COMMON) { push @body, pack('A16A12A6A6A8A10A2', $name, @$meta{qw/date uid gid/}, $mode, $size, ARFMAG); } elsif ($type eq GNU) { push @body, pack('A1A15A12A6A6A8A10A2', '/', $gnuindex{$fn}, @$meta{qw/date uid gid/}, $mode, $size, ARFMAG); } elsif ($type eq BSD) { $size += length($name); push @body, pack('A3A13A12A6A6A8A10A2', AR_EFMT1, length($name), @$meta{qw/date uid gid/}, $mode, $size, ARFMAG), $name; } else { return $self->_error("$type: unexpected ar type"); } push @body, $meta->{data}; push @body, "\n" if $size % 2; # padding } if ($filename) { my $fh = $self->_get_handle($filename, '>'); print $fh @body; close $fh; my $len = 0; $len += length($_) for @body; return $len; } else { return join '', @body; } } sub get_content { my $self = shift; my ($filename) = @_; unless ($filename) { $self->_error("get_content can't continue without a filename"); return; } unless (exists($self->{files}->{$filename})) { $self->_error( "get_content failed because there is not a file named $filename"); return; } return $self->{files}->{$filename}; } sub get_data { my $self = shift; my $filename = shift; return $self->_error("$filename: no such member") unless exists $self->{files}->{$filename}; return $self->{files}->{$filename}->{data}; } sub get_handle { my $self = shift; my $filename = shift; my $fh; return $self->_error("$filename: no such member") unless exists $self->{files}->{$filename}; if ($has_io_string) { $fh = IO::String->new($self->{files}->{$filename}->{data}); } else { my $data = $self->{files}->{$filename}->{data}; open $fh, '<', \$data or return $self->_error("in-memory file: $!"); } return $fh; } sub error { my $self = shift; return shift() ? $self->{longmess} : $self->{error}; } # # deprecated # sub DEBUG { my $self = shift; my $debug = shift; $self->{opts}->{warn} = 1 unless (defined($debug) and int($debug) == 0); } sub _parse { my $self = shift; my $data = shift; unless (substr($data, 0, SARMAG, '') eq ARMAG) { return $self->_error("Bad magic number - not an ar archive"); } my $type; my $names; while ($data =~ /\S/) { my ($name, $date, $uid, $gid, $mode, $size, $magic) = unpack('A16A12A6A6A8A10a2', substr($data, 0, 60, '')); unless ($magic eq "`\n") { return $self->_error("Bad file header"); } if ($name =~ m|^/|) { $type = GNU; if ($name eq '//') { $names = substr($data, 0, $size, ''); substr($data, 0, $size % 2, ''); next; } elsif ($name eq '/') { $name = $self->{opts}->{symbols}; unless (defined $name && $name) { substr($data, 0, $size + $size % 2, ''); next; } } else { $name = substr($names, int(substr($name, 1))); $name =~ s/\n.*//; chop $name; } } elsif ($name =~ m|^#1/|) { $type = BSD; $name = substr($data, 0, int(substr($name, 3)), ''); $size -= length($name); } else { if ($name =~ m|/$|) { $type ||= GNU; # only gnu has trailing slashes chop $name; } } $uid = int($uid); $gid = int($gid); $mode = oct($mode); my $content = substr($data, 0, $size, ''); substr($data, 0, $size % 2, ''); $self->_add_data($name, $content, $date, $uid, $gid, $mode, $size); } $self->{type} = $type || COMMON; return scalar @{$self->{names}}; } sub _add_data { my $self = shift; my $filename = shift; my $content = shift || ''; my $date = shift; my $uid = shift; my $gid = shift; my $mode = shift; my $size = shift; if (exists($self->{files}->{$filename})) { return $self->_error("$filename: entry already exists"); } $self->{files}->{$filename} = { name => $filename, date => defined $date ? $date : timelocal(localtime()), uid => defined $uid ? $uid : 0, gid => defined $gid ? $gid : 0, mode => defined $mode ? $mode : 0100644, size => defined $size ? $size : length($content), data => $content, }; push @{$self->{names}}, $filename; return 1; } sub _get_handle { my $self = shift; my $file = shift; my $mode = shift || '<'; if (ref $file) { return $file if eval{*$file{IO}} or $file->isa('IO::Handle'); return $self->_error("Not a filehandle"); } else { open my $fh, $mode, $file or return $self->_error("$file: $!"); binmode $fh; return $fh; } } sub _error { my $self = shift; my $msg = shift; $self->{error} = $msg; $self->{longerror} = longmess($msg); if ($self->{opts}->{warn} > 1) { carp $self->{longerror}; } elsif ($self->{opts}->{warn}) { carp $self->{error}; } return; } 1; __END__ =head1 NAME Archive::Ar - Interface for manipulating ar archives =head1 SYNOPSIS use Archive::Ar; my $ar = Archive::Ar->new; $ar->read('./foo.ar'); $ar->extract; $ar->add_files('./bar.tar.gz', 'bat.pl') $ar->add_data('newfile.txt','Some contents'); $ar->chmod('file1', 0644); $ar->chown('file1', $uid, $gid); $ar->remove('file1', 'file2'); my $filehash = $ar->get_content('bar.tar.gz'); my $data = $ar->get_data('bar.tar.gz'); my $handle = $ar->get_handle('bar.tar.gz'); my @files = $ar->list_files(); my $archive = $ar->write; my $size = $ar->write('outbound.ar'); $ar->error(); =head1 DESCRIPTION Archive::Ar is a pure-perl way to handle standard ar archives. This is useful if you have those types of archives on the system, but it is also useful because .deb packages for the Debian GNU/Linux distribution are ar archives. This is one building block in a future chain of modules to build, manipulate, extract, and test debian modules with no platform or architecture dependence. You may notice that the API to Archive::Ar is similar to Archive::Tar, and this was done intentionally to keep similarity between the Archive::* modules. =head1 METHODS =head2 new $ar = Archive::Ar->new() $ar = Archive::Ar->new($filename) $ar = Archive::Ar->new($filehandle) Returns a new Archive::Ar object. Without an argument, it returns an empty object. If passed a filename or an open filehandle, it will read the referenced archive into memory. If the read fails for any reason, returns undef. =head2 set_opt $ar->set_opt($name, $val) Assign option $name value $val. Possible options are: =over 4 =item * warn Warning level. Levels are zero for no warnings, 1 for brief warnings, and 2 for warnings with a stack trace. Default is zero. =item * chmod Change the file permissions of files created when extracting. Default is true (non-zero). =item * same_perms When setting file permissions, use the values in the archive unchanged. If false, removes setuid bits and applies the user's umask. Default is true for the root user, false otherwise. =item * chown Change the owners of extracted files, if possible. Default is true. =item * type Archive type. May be GNU, BSD or COMMON, or undef if no archive has been read. Defaults to the type of the archive read, or undef. =item * symbols Provide a filename for the symbol table, if present. If set, the symbol table is treated as a file that can be read from or written to an archive. It is an error if the filename provided matches the name of a file in the archive. If undefined, the symbol table is ignored. Defaults to undef. =back =head2 get_opt $val = $ar->get_opt($name) Returns the value of option $name. =head2 type $type = $ar->type() Returns the type of the ar archive. The type is undefined until an archive is loaded. If the archive displays characteristics of a gnu-style archive, GNU is returned. If it looks like a bsd-style archive, BSD is returned. Otherwise, COMMON is returned. Note that unless filenames exceed 16 characters in length, bsd archives look like the common format. =head2 clear $ar->clear() Clears the current in-memory archive. =head2 read $len = $ar->read($filename) $len = $ar->read($filehandle) This reads a new file into the object, removing any ar archive already represented in the object. The argument may be a filename, filehandle or IO::Handle object. Returns the size of the file contents or undef if it fails. =head2 read_memory $len = $ar->read_memory($data) Parses the string argument as an archive, reading it into memory. Replaces any previously loaded archive. Returns the number of bytes read, or undef if it fails. =head2 contains_file $bool = $ar->contains_file($filename) Returns true if the archive contains a file with $filename. Returns undef otherwise. =head2 extract $ar->extract() $ar->extract_file($filename) Extracts files from the archive. The first form extracts all files, the latter extracts just the named file. Extracted files are assigned the permissions and modification time stored in the archive, and, if possible, the user and group ownership. Returns non-zero upon success, or undef if failure. =head2 rename $ar->rename($filename, $newname) Changes the name of a file in the in-memory archive. =head2 chmod $ar->chmod($filename, $mode); Change the mode of the member to C<$mode>. =head2 chown $ar->chown($filename, $uid, $gid); $ar->chown($filename, $uid); Change the ownership of the member to user id C<$uid> and (optionally) group id C<$gid>. Negative id values are ignored. =head2 remove $ar->remove(@filenames) $ar->remove($arrayref) Removes files from the in-memory archive. Returns the number of files removed. =head2 list_files @filenames = $ar->list_files() Returns a list of the names of all the files in the archive. If called in a scalar context, returns a reference to an array. =head2 add_files $ar->add_files(@filenames) $ar->add_files($arrayref) Adds files to the archive. The arguments can be paths, but only the filenames are stored in the archive. Stores the uid, gid, mode, size, and modification timestamp of the file as returned by C. Returns the number of files successfully added, or undef if failure. =head2 add_data $ar->add_data("filename", $data) $ar->add_data("filename", $data, $options) Adds a file to the in-memory archive with name $filename and content $data. File properties can be set with $optional_hashref: $options = { 'data' => $data, 'uid' => $uid, #defaults to zero 'gid' => $gid, #defaults to zero 'date' => $date, #date in epoch seconds. Defaults to now. 'mode' => $mode, #defaults to 0100644; } You cannot add_data over another file however. This returns the file length in bytes if it is successful, undef otherwise. =head2 write $data = $ar->write() $len = $ar->write($filename) Returns the archive as a string, or writes it to disk as $filename. Returns the archive size upon success when writing to disk. Returns undef if failure. =head2 get_content $content = $ar->get_content($filename) This returns a hash with the file content in it, including the data that the file would contain. If the file does not exist or no filename is given, this returns undef. On success, a hash is returned: $content = { 'name' => $filename, 'date' => $mtime, 'uid' => $uid, 'gid' => $gid, 'mode' => $mode, 'size' => $size, 'data' => $file_contents, } =head2 get_data $data = $ar->get_data("filename") Returns a scalar containing the file data of the given archive member. Upon error, returns undef. =head2 get_handle $handle = $ar->get_handle("filename")> Returns a file handle to the in-memory file data of the given archive member. Upon error, returns undef. This can be useful for unpacking nested archives. Uses IO::String if it's loaded. =head2 error $errstr = $ar->error($trace) Returns the current error string, which is usually the last error reported. If a true value is provided, returns the error message and stack trace. =head1 BUGS See https://github.com/jbazik/Archive-Ar/issues/ to report and view bugs. =head1 SOURCE The source code repository for Archive::Ar can be found at http://github.com/jbazik/Archive-Ar/. =head1 COPYRIGHT Copyright 2009-2014 John Bazik Ejbazik@cpan.orgE. Copyright 2003 Jay Bonci Ejaybonci@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Archive-Ar-2.02/MANIFEST0000644000175000017500000000071312360660323012627 0ustar jsbjsb.travis.yml Archive-Ar-2.00.tar.gz CHANGES lib/Archive/Ar.pm Makefile.PL MANIFEST This list of files README.md t/05_class.t t/10_object.t t/10objects.t t/15_compat.t t/20_add_data.t t/20new.t t/25_add_files.t t/30_empty.t t/30write.t t/35_list.t t/40_mode.t t/40mode.t t/45_content.t t/50_remove.t t/50empty.t t/55_write.t t/60_extract.t t/65_gnu.t t/66_gnu_symtab.t t/70_bsd.t META.yml Module meta-data (added by MakeMaker) Archive-Ar-2.02/CHANGES0000644000175000017500000000361312357147114012477 0ustar jsbjsbVersion 2.02 - Jul 9, 2014 - John Bazik * Handle GNU format symbol tables (closes #5). * Added "symbols" option. * Fixed missing padding on GNU format extended names data section. * Added a test for all of this. Version 2.01 - Jun 18, 2014 - John Bazik * Rewritten, many new methods, support for bsd and gnu ar formats. Version 1.17 - Mar 14, 2014 - John Bazik * Fixed MANIFEST goof. Doh! Version 1.16 - Mar 14, 2014 - John Bazik * Set size to zero, not the empty string, in the case of empty member files (thanks to Michael J. Mestnik). Version 1.15 - May 14, 2013 - John Bazik * Use binmode for portability. Closes RT #81310 (thanks to Stanislav Meduna). Version 1.14 - October 14, 2009 - John Bazik * Fix list_files to return a list in list context, to match doc. * Fixed improper use of /m modifier in anchored match. * Pad odd-size archives to an even number of bytes. Closes RT #18383 (thanks to David Dick). * Fixed broken file perms (decimal mode stored as octal string). Closes RT #49987 (thanks to Stephen Gran - debian bug #523515). * Added tests for padding and permission fixes. Dropped unnecessary BEGIN clauses from some tests. Version 1.13b - May 7th, 2003 Fixes to the Makefile.PL file. Ar.pm wasn't being put into /blib Style fix to a line with non-standard unless parenthesis Version 1.13 - April 30th, 2003 Removed unneeded exports. Thanks to pudge for the pointer. Version 1.12 - April 14th, 2003 Found podchecker. CPAN HTML documentation should work right now. Version 1.11 - April 10th, 2003 Trying to get the HTML POD documentation to come out correctly Version 1.1 - April 10th, 2003 Documentation cleanups Added a C function Version 1.0 - April 7th, 2003 This is the initial public release for CPAN, so everything is new. Archive-Ar-2.02/Makefile.PL0000644000175000017500000000147212350175035013453 0ustar jsbjsbuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Archive::Ar', 'VERSION_FROM' => 'lib/Archive/Ar.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => '0', 'Test::MockObject' => '0', 'File::Spec' => '0', 'File::Temp' => '0', }, 'dist' => { COMPRESS => 'gzip -9', SUFFIX => '.gz', DIST_DEFAULT => 'all tardist', }, ($] >= 5.005 ? ## Add these new keywords supported since 5.005 ( ABSTRACT_FROM => 'lib/Archive/Ar.pm', # retrieve abstract from module AUTHOR => 'Jay Bonci ') : ()), META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/jbazik/Archive-Ar.git', web => 'https://github.com/jbazik/Archive-Ar', }, }, }, ); Archive-Ar-2.02/t/0000755000175000017500000000000012360660323011740 5ustar jsbjsbArchive-Ar-2.02/t/60_extract.t0000644000175000017500000000252312350175035014106 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 11; use File::Temp qw(tempdir); use Cwd; my $wd = cwd; END { chdir $wd; } use Archive::Ar; my $dir = tempdir(CLEANUP => 1); my $content = do {local $/ = undef; }; umask 0; my $ar = Archive::Ar->new(); ok $ar->read_memory($content), 'read_memory' or diag $ar->error; chdir $dir or die; ok $ar->extract, 'extract'; my @st = lstat 'foo.txt'; ok @st, 'stat'; SKIP: { skip "permission mode not reliable on MSWin32", 1 if $^O eq 'MSWin32'; is $st[2], 0100644, 'mode 1 matches'; } is $st[7], 9, 'size 1 matches'; is $st[9], 1384344423, 'mtime 1 matches'; if (open my $fd, 'foo.txt') { local $/ = undef; my $content = <$fd>; is $content, "hi there\n", 'content 1 matches'; } else { fail "open 'foo.txt'"; } @st = lstat 'bar.txt'; SKIP: { skip "permission mode not reliable on MSWin32", 1 if $^O eq 'MSWin32'; is $st[2], 0100750, 'mode 2 matches'; } is $st[7], 31, 'size 2 matches'; is $st[9], 1384344423, 'mtime 2 matches'; if (open my $fd, 'bar.txt') { local $/ = undef; my $content = <$fd>; is $content, "this is the content of bar.txt\n", 'content 2 matches'; } else { fail "open 'bar.txt'"; } __DATA__ ! foo.txt 1384344423 1000 1000 100644 9 ` hi there bar.txt 1384344423 1000 1000 100750 31 ` this is the content of bar.txt Archive-Ar-2.02/t/35_list.t0000644000175000017500000000424312350175035013412 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 4; use File::Temp qw( tempdir ); use File::Spec; use Archive::Ar; my $dir = tempdir( CLEANUP => 1 ); my $fn = File::Spec->catfile($dir, 'foo.ar'); note "fn = $fn"; my $content = do {local $/ = undef; }; open my $fh, '>', $fn or die "$fn: $!\n"; binmode $fh; print $fh $content; close $fh; my $filenames = [ qw(foo.txt bar.txt baz.txt) ]; subtest 'filename' => sub { plan tests => 3; my $ar = Archive::Ar->new($fn); isa_ok $ar, 'Archive::Ar'; is_deeply scalar $ar->list_files, $filenames, "scalar context"; is_deeply [$ar->list_files], $filenames, "list context"; }; subtest 'glob' => sub { plan tests => 3; open my $fh, '<', $fn; my $ar = Archive::Ar->new($fh); isa_ok $ar, 'Archive::Ar'; is_deeply scalar $ar->list_files, $filenames, "scalar context"; is_deeply [$ar->list_files], $filenames, "list context"; }; subtest 'memory' => sub { plan tests => 4; open my $fh, '<', $fn; my $data = do { local $/ = undef; <$fh> }; close $fh; my $ar = Archive::Ar->new; isa_ok $ar, 'Archive::Ar'; is $ar->read_memory($data), 242, "size matches"; is_deeply scalar $ar->list_files, $filenames, "scalar context"; is_deeply [$ar->list_files], $filenames, "list context"; }; subtest 'rename' => sub { plan tests => 6; open my $fh, '<', $fn; my $data = do { local $/ = undef; <$fh> }; close $fh; my $ar = Archive::Ar->new; isa_ok $ar, 'Archive::Ar'; is $ar->read_memory($data), 242, "size matches"; my $renames = $filenames; $renames->[1] = 'goo.txt'; $ar->rename('bar.txt', 'goo.txt'); is_deeply scalar $ar->list_files, $filenames, "scalar context"; is_deeply [$ar->list_files], $filenames, "list context"; $renames->[2] = 'zoo.txt'; $ar->rename('baz.txt', 'zoo.txt'); is_deeply scalar $ar->list_files, $filenames, "scalar context"; is_deeply [$ar->list_files], $filenames, "list context"; }; __DATA__ ! foo.txt 1384344423 1000 1000 100644 9 ` hi there bar.txt 1384344423 1000 1000 100644 31 ` this is the content of bar.txt baz.txt 1384344423 1000 1000 100644 11 ` and again. Archive-Ar-2.02/t/30_empty.t0000644000175000017500000000056712350175035013575 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 2; use Archive::Ar; my $content = do {local $/ = undef; }; my $a = Archive::Ar->new(); $a->read_memory($content); my $d = $a->get_content('zero'); isnt "$d->{size}", '', 'size is not empty string'; is "$d->{size}", "0", 'size is zero'; __DATA__ ! zero 1394762259 1000 1000 100644 0 ` Archive-Ar-2.02/t/25_add_files.t0000644000175000017500000000217312350175035014350 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 2; use File::Temp qw( tempdir ); use File::Spec; use Archive::Ar; my $dir = tempdir( CLEANUP => 1 ); note "dir = $dir"; my %data = ( foo => "something completely different", bar => "something the same", baz => "Truck, not monkey", ); for my $name (keys %data) { open(my $fh, '>', File::Spec->catfile($dir, "$name.txt")); print $fh $data{$name}; close $fh; } subtest 'add list' => sub { plan tests => 4; my $ar = Archive::Ar->new; my $count = $ar->add_files(map { File::Spec->catfile($dir, "$_.txt") } qw( foo bar baz )); is $count, 3, 'add_files'; for my $name (qw( foo bar baz )) { is $ar->get_content("$name.txt")->{data}, $data{$name}, "data for $name"; } }; subtest 'add ref' => sub { plan tests => 4; my $ar = Archive::Ar->new; my $count = $ar->add_files(map { File::Spec->catfile($dir, "$_.txt") } qw( foo bar baz )); is $count, 3, 'add_files'; for my $name (qw( foo bar baz )) { is $ar->get_content("$name.txt")->{data}, $data{$name}, "data for $name"; } }; Archive-Ar-2.02/t/20_add_data.t0000644000175000017500000000243312350175035014151 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 2; use Archive::Ar; subtest defaults => sub { plan tests => 11; my $ar = Archive::Ar->new; is $ar->add_data("1", 'one'), 3, 'add_data'; is $ar->add_data("foo.txt", 'bar'), 3, 'add_data'; is $ar->add_data("2", 'two'), 3, 'add_data'; my $data = $ar->get_content('foo.txt'); is $data->{name}, 'foo.txt', 'name'; like $data->{date}, qr{^[1-9]\d*$}, 'date'; is $data->{uid}, 0, 'uid'; is $data->{gid}, 0, 'gid'; is $data->{mode}, 0100644, 'mode'; is $data->{data}, 'bar', 'data'; is $data->{size}, 3, 'size'; is $ar->get_content('goose'), undef, 'not found'; }; subtest 'non default values' => sub { my $ar = Archive::Ar->new; is $ar->add_data("1", 'one'), 3, 'add_data'; is $ar->add_data("foo.txt", 'barbaz', { uid => 101, gid => 201, mode => 0644, }), 6, 'add_data'; is $ar->add_data("2", 'two'), 3, 'add_data'; my $data = $ar->get_content('foo.txt'); is $data->{name}, 'foo.txt', 'name'; like $data->{date}, qr{^[1-9]\d*$}, 'date'; is $data->{uid}, 101, 'uid'; is $data->{gid}, 201, 'gid'; is $data->{mode}, 0644, 'mode'; is $data->{data}, 'barbaz', 'data'; is $data->{size}, 6, 'size'; is $ar->get_content('goose'), undef, 'not found'; }; Archive-Ar-2.02/t/55_write.t0000644000175000017500000000060312350175035013567 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 2; use strict; use Archive::Ar; my $ar; $ar = Archive::Ar->new(); $ar->add_data("test.txt", "here\n"); my $content = $ar->write(); ok length($content) == 74, 'odd size archive padded'; $ar = new Archive::Ar(); $ar->add_data("test.txt", "here1\n"); $content = $ar->write(); ok length($content) == 74, 'even size archive not padded'; Archive-Ar-2.02/t/15_compat.t0000644000175000017500000000062012350175035013713 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 5; use Archive::Ar; my $ar; can_ok 'Archive::Ar', 'DEBUG'; $ar = Archive::Ar->new(); is $ar->get_opt('warn'), 0, 'warn off by default'; $ar->DEBUG(); is $ar->get_opt('warn'), 1, 'DEBUG method sets warn'; eval { $ar = Archive::Ar->new(undef, 1) }; is $@, '', 'debug option to new'; is $ar->get_opt('warn'), 1, 'debug option to new sets warn'; Archive-Ar-2.02/t/70_bsd.t0000644000175000017500000000073412350175035013207 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 3; use Archive::Ar qw(BSD); my $content = do {local $/ = undef; }; my $ar = Archive::Ar->new(); ok $ar->read_memory($content) or diag $ar->error; is $ar->type, BSD; my $regurg = $ar->write; is $regurg, $content; __DATA__ ! foo.txt 1396073800 1000 1000 100644 16 ` contents of foo #1/20 1396073800 1000 1000 100644 49 ` verylongfilename.txtcontents of verylongfilename Archive-Ar-2.02/t/40_mode.t0000644000175000017500000000351712350175035013362 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 20; use File::Temp qw(tempfile); use Archive::Ar; my ($fh, $file) = tempfile(UNLINK => 1); my $content = do {local $/ = undef; }; print $fh $content; close $fh; my $ar = Archive::Ar->new($file); isa_ok $ar, 'Archive::Ar', 'object'; is_deeply [$ar->list_files], [qw(odd even)], 'list_files'; my $filedata = $ar->get_content('odd'); is $filedata->{name}, 'odd', 'file1, filedata/name'; is $filedata->{uid}, 2202, 'file1, filedata/uid'; is $filedata->{gid}, 2988, 'file1, filedata/gid'; is $filedata->{mode}, 0100644, 'file1, filedata/mode'; is $filedata->{date}, 1255532835, 'file1, filedata/date'; is $filedata->{size}, 11, 'file1, filedata/size'; is $filedata->{data}, "oddcontent\n", 'file1, filedata/data'; $filedata = $ar->get_content('even'); is $filedata->{name}, 'even', 'file2, filedata/name'; is $filedata->{uid}, 2202, 'file2, filedata/uid'; is $filedata->{gid}, 2988, 'file2, filedata/gid'; is $filedata->{mode}, 0100644, 'file2, filedata/mode'; is $filedata->{date}, 1255532831, 'file2, filedata/date'; is $filedata->{size}, 12, 'file2, filedata/size'; is $filedata->{data}, "evencontent\n", 'file2, filedata/data'; my ($nfh, $nfile) = tempfile(UNLINK => 1); my $size = $ar->write($nfh); is $size, 152, 'write size'; close $nfh; my $nar = Archive::Ar->new($nfile); is_deeply [$ar->list_files], [$nar->list_files], 'write/read, list_files'; is_deeply $ar->get_content('odd'), $nar->get_content('odd'), 'write/read, file1 compare'; is_deeply $ar->get_content('even'), $nar->get_content('even'), 'write/read, file2 compare'; __DATA__ ! odd 1255532835 2202 2988 100644 11 ` oddcontent even 1255532831 2202 2988 100644 12 ` evencontent Archive-Ar-2.02/t/65_gnu.t0000644000175000017500000000103212350175035013224 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 3; use Archive::Ar qw(GNU); my $content = do {local $/ = undef; }; my $ar = Archive::Ar->new(); ok $ar->read_memory($content) or diag $ar->error; is $ar->type, GNU; my $regurg = $ar->write; is $regurg, $content; __DATA__ ! // 22 ` verylongfilename.txt/ foo.txt/ 1396584498 1000 1000 100644 16 ` contents of foo /0 1396584491 1000 1000 100644 29 ` contents of verylongfilename Archive-Ar-2.02/t/10_object.t0000644000175000017500000000142112350175035013671 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 6; use Test::MockObject; use IO::Handle; use Archive::Ar; my $mock = new Test::MockObject; my $ar; $mock->set_false('read'); local *Archive::Ar::read; *Archive::Ar::read = sub { return $mock->read(); }; $ar = Archive::Ar->new(); isa_ok $ar, 'Archive::Ar', 'object'; ok !$mock->called('read'), 'read not called if new with no options'; $ar = Archive::Ar->new('myfilename'); is $ar, undef, 'new fails if read fails'; ok $mock->called('read'), 'read called if new with filename'; $mock->clear(); $ar = new Archive::Ar(*STDIN); ok $mock->called('read'), 'read called if new with file glob'; $mock->clear(); $ar = new Archive::Ar(IO::Handle->new()); ok $mock->called('read'), 'read called if new with file handle'; $mock->clear(); Archive-Ar-2.02/t/45_content.t0000644000175000017500000000336312350175035014114 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 13; use File::Temp qw( tempdir ); use File::Spec; use Archive::Ar; my $dir = tempdir( CLEANUP => 1 ); my $fn = File::Spec->catfile($dir, 'foo.ar'); note "fn = $fn"; my $content = do {local $/ = undef; }; open my $fh, '>', $fn or die "$fn: $!\n"; binmode $fh; print $fh $content; close $fh; my $ar = Archive::Ar->new($fn); isa_ok $ar, 'Archive::Ar'; is $ar->get_content("foo.txt")->{data}, "hi there\n", 'get content 1'; is $ar->get_content("bar.txt")->{data}, "this is the content of bar.txt\n", 'get content 2'; is $ar->get_content("baz.txt")->{data}, "and again.\n", 'get content 3'; is $ar->get_data("foo.txt"), "hi there\n", 'get data 1'; is $ar->get_data("bar.txt"), "this is the content of bar.txt\n", 'get data 2'; is $ar->get_data("baz.txt"), "and again.\n", 'get data 3'; my $h = $ar->get_handle("foo.txt"); diag $ar->error() unless $h; ok defined fileno($h) || $h->can('read'), 'get handle 1'; my $data = do {local $/ = undef; <$h>}; is $data, "hi there\n", 'handle data 1'; $h = $ar->get_handle("bar.txt"); diag $ar->error() unless $h; ok defined fileno($h) || $h->can('read'), 'get handle 2'; $data = do {local $/ = undef; <$h>}; is $data, "this is the content of bar.txt\n", 'handle data 2'; $h = $ar->get_handle("baz.txt"); diag $ar->error() unless $h; ok defined fileno($h) || $h->can('read'), 'get handle 3'; $data = do {local $/ = undef; <$h>}; is $data, "and again.\n", 'handle data 3'; __DATA__ ! foo.txt 1384344423 1000 1000 100644 9 ` hi there bar.txt 1384344423 1000 1000 100644 31 ` this is the content of bar.txt baz.txt 1384344423 1000 1000 100644 11 ` and again. Archive-Ar-2.02/t/66_gnu_symtab.t0000644000175000017500000000157312357146564014632 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 7; use Archive::Ar qw(GNU); my $content = do {local $/ = undef; }; my $ar = Archive::Ar->new(); ok $ar->read_memory($content) or diag $ar->error; is $ar->type, GNU; is_deeply scalar $ar->list_files, [qw(foo.txt verylongfilenam.txt)]; my $regurg = $ar->write; isnt $regurg, $content; $ar->set_opt('symbols', '_symtab'); ok $ar->read_memory($content) or diag $ar->error; is_deeply scalar $ar->list_files, [qw(_symtab foo.txt verylongfilenam.txt)]; $regurg = $ar->write; is $regurg, $content; __DATA__ ! // 21 ` verylongfilenam.txt/ / 0 0 0 0 16 ` iamasymboltable foo.txt/ 1396584498 1000 1000 100644 16 ` contents of foo /0 1396584491 1000 1000 100644 28 ` contents of verylongfilenam Archive-Ar-2.02/t/05_class.t0000644000175000017500000000116712350175035013543 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 23; my $mod = 'Archive::Ar'; use_ok $mod; can_ok $mod, 'new'; can_ok $mod, 'set_opt'; can_ok $mod, 'get_opt'; can_ok $mod, 'type'; can_ok $mod, 'clear'; can_ok $mod, 'read'; can_ok $mod, 'read_memory'; can_ok $mod, 'contains_file'; can_ok $mod, 'extract'; can_ok $mod, 'extract_file'; can_ok $mod, 'rename'; can_ok $mod, 'chmod'; can_ok $mod, 'chown'; can_ok $mod, 'remove'; can_ok $mod, 'list_files'; can_ok $mod, 'add_files'; can_ok $mod, 'add_data'; can_ok $mod, 'write'; can_ok $mod, 'get_content'; can_ok $mod, 'get_data'; can_ok $mod, 'get_handle'; can_ok $mod, 'error'; Archive-Ar-2.02/t/50_remove.t0000644000175000017500000000223612350175035013731 0ustar jsbjsbuse strict; use warnings; use Test::More tests => 2; use File::Temp qw( tempdir ); use File::Spec; use Archive::Ar; my $dir = tempdir( CLEANUP => 1 ); my $fn = File::Spec->catfile($dir, 'foo.ar'); note "fn = $fn"; my $content = do {local $/ = undef; }; open my $fh, '>', $fn or die "$fn: $!\n"; binmode $fh; print $fh $content; close $fh; subtest 'remove list' => sub { plan tests => 3; my $ar = Archive::Ar->new($fn); isa_ok $ar, 'Archive::Ar'; my $count = eval { $ar->remove('foo.txt', 'baz.txt') }; is $count, 2, 'count = 2'; diag $@ if $@; is_deeply scalar $ar->list_files, ['bar.txt'], "just bar"; }; subtest 'remove ref' => sub { plan tests => 3; my $ar = Archive::Ar->new($fn); isa_ok $ar, 'Archive::Ar'; my $count = eval { $ar->remove(['foo.txt', 'baz.txt']) }; is $count, 2, 'count = 2'; diag $@ if $@; is_deeply scalar $ar->list_files, ['bar.txt'], "just bar"; }; __DATA__ ! foo.txt 1384344423 1000 1000 100644 9 ` hi there bar.txt 1384344423 1000 1000 100644 31 ` this is the content of bar.txt baz.txt 1384344423 1000 1000 100644 11 ` and again. Archive-Ar-2.02/README.md0000644000175000017500000000276012350175035012761 0ustar jsbjsb# Archive::Ar [![Build Status](https://secure.travis-ci.org/jbazik/Archive-Ar.png)](http://travis-ci.org/jbazik/Archive-Ar) Interface for manipulating ar archives ## INSTALL The usual way perl Makefile.PL make make test make install ## SYNOPSIS use Archive::Ar; my $ar = Archive::Ar->new; $ar->read('./foo.ar'); $ar->extract; $ar->add_files('./bar.tar.gz', 'bat.pl') $ar->add_data('newfile.txt','Some contents'); $ar->chmod('file1', 0644); $ar->chown('file1', $uid, $gid); $ar->remove('file1', 'file2'); my $filehash = $ar->get_content('bar.tar.gz'); my $data = $ar->get_data('bar.tar.gz'); my $handle = $ar->get_handle('bar.tar.gz'); my @files = $ar->list_files(); my $archive = $ar->write; my $size = $ar->write('outbound.ar'); $ar->error(); ## DESCRIPTION Archive::Ar is a pure-perl way to handle standard ar archives. This is useful if you have those types of archives on the system, but it is also useful because .deb packages for the Debian GNU/Linux distribution are ar archives. This is one building block in a future chain of modules to build, manipulate, extract, and test debian modules with no platform or architecture dependence. ## COPYRIGHT Copyright 2009-2014 John Bazik . Copyright 2003 Jay Bonci . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html Archive-Ar-2.02/META.yml0000644000175000017500000000142012360660323012743 0ustar jsbjsb--- #YAML:1.0 name: Archive-Ar version: 2.02 abstract: Interface for manipulating ar archives author: - Jay Bonci license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: File::Spec: 0 File::Temp: 0 Test::MockObject: 0 Test::More: 0 resources: repository: type: git url: https://github.com/jbazik/Archive-Ar.git web: https://github.com/jbazik/Archive-Ar no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 2 Archive-Ar-2.02/.travis.yml0000644000175000017500000000010112350175035013576 0ustar jsbjsblanguage: perl perl: - "5.14" - "5.12" - "5.10" - "5.8"