Archive-Ar-1.15/0000755000175000017500000000000012144564242011503 5ustar jsbjsbArchive-Ar-1.15/lib/0000755000175000017500000000000012144564242012251 5ustar jsbjsbArchive-Ar-1.15/lib/Archive/0000755000175000017500000000000012144564242013632 5ustar jsbjsbArchive-Ar-1.15/lib/Archive/Ar.pm0000644000175000017500000003677712144563156014561 0ustar jsbjsbpackage Archive::Ar; ########################################################### # Archive::Ar - Pure perl module to handle ar achives # # Copyright 2003 - Jay Bonci # Licensed under the same terms as perl itself # ########################################################### use strict; use Exporter; use File::Spec; use Time::Local; use vars qw($VERSION); $VERSION = '1.15'; use constant ARMAG => "!\n"; use constant SARMAG => length(ARMAG); use constant ARFMAG => "`\n"; sub new { my ($class, $filenameorhandle, $debug) = @_; my $this = {}; my $obj = bless $this, $class; $obj->{_verbose} = 0; $obj->_initValues(); if($debug) { $obj->DEBUG(); } if($filenameorhandle){ unless($obj->read($filenameorhandle)){ $obj->_dowarn("new() failed on filename or filehandle read"); return; } } return $obj; } sub read { my ($this, $filenameorhandle) = @_; my $retval; $this->_initValues(); if(ref $filenameorhandle eq "GLOB") { unless($retval = $this->_readFromFilehandle($filenameorhandle)) { $this->_dowarn("Read from filehandle failed"); return; } }else { unless($retval = $this->_readFromFilename($filenameorhandle)) { $this->_dowarn("Read from filename failed"); return; } } unless($this->_parseData()) { $this->_dowarn("read() failed on data structure analysis. Probable bad file"); return; } return $retval; } sub read_memory { my ($this, $data) = @_; $this->_initValues(); unless($data) { $this->_dowarn("read_memory() can't continue because no data was given"); return; } $this->{_filedata} = $data; unless($this->_parseData()) { $this->_dowarn("read_memory() failed on data structure analysis. Probable bad file"); return; } return length($data); } sub remove { my($this, $filenameorarray, @otherfiles) = @_; my $filelist; if(ref $filenameorarray eq "ARRAY") { $filelist = $filenameorarray; }else{ $filelist = [$filenameorarray]; if(@otherfiles) { push @$filelist, @otherfiles; } } my $filecount = 0; foreach my $file (@$filelist) { $filecount += $this->_remFile($file); } return $filecount; } sub list_files { my($this) = @_; return wantarray ? @{$this->{_files}} : $this->{_files}; } sub add_files { my($this, $filenameorarray, @otherfiles) = @_; my $filelist; if(ref $filenameorarray eq "ARRAY") { $filelist = $filenameorarray; }else { $filelist = [$filenameorarray]; if(@otherfiles) { push @$filelist, @otherfiles; } } my $filecount = 0; foreach my $filename (@$filelist) { my @props = stat($filename); unless(@props) { $this->_dowarn("Could not stat() filename. add_files() for this file failed"); next; } my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = @props; my $header = { "date" => $mtime, "uid" => $uid, "gid" => $gid, "mode" => $mode, "size" => $size, }; local $/ = undef; unless(open HANDLE, $filename) { $this->_dowarn("Could not open filename. add_files() for this file failed"); next; } binmode HANDLE; $header->{data} = ; close HANDLE; # fix the filename (undef, undef, $filename) = File::Spec->splitpath($filename); $header->{name} = $filename; $this->_addFile($header); $filecount++; } return $filecount; } sub add_data { my($this, $filename, $data, $params) = @_; unless ($filename) { $this->_dowarn("No filename given; add_data() can't proceed"); return; } $params ||= {}; $data ||= ""; (undef, undef, $filename) = File::Spec->splitpath($filename); $params->{name} = $filename; $params->{size} = length($data); $params->{data} = $data; $params->{uid} ||= 0; $params->{gid} ||= 0; $params->{date} ||= timelocal(localtime()); $params->{mode} ||= 0100644; unless($this->_addFile($params)) { $this->_dowarn("add_data failed due to a failure in _addFile"); return; } return $params->{size}; } sub write { my($this, $filename) = @_; my $outstr; $outstr= ARMAG; foreach(@{$this->{_files}}) { my $content = $this->get_content($_); unless($content) { $this->_dowarn("Internal Error. $_ file in _files list but no filedata"); next; } # For whatever reason, the uids and gids get stripped # if they are zero. We'll blank them here to emulate that $content->{uid} ||= ""; $content->{gid} ||= ""; $outstr.= pack("A16A12A6A6A8A10", @$content{qw/name date uid gid/}, sprintf('%o', $content->{mode}), # octal! $content->{size}); $outstr.= ARFMAG; $outstr.= $content->{data}; unless (((length($content->{data})) % 2) == 0) { # Padding to make up an even number of bytes $outstr.= "\n"; } } return $outstr unless $filename; unless(open HANDLE, ">$filename") { $this->_dowarn("Can't open filename $filename"); return; } binmode HANDLE; print HANDLE $outstr; close HANDLE; return length($outstr); } sub get_content { my ($this, $filename) = @_; unless($filename) { $this->_dowarn("get_content can't continue without a filename"); return; } unless(exists($this->{_filehash}->{$filename})) { $this->_dowarn("get_content failed because there is not a file named $filename"); return; } return $this->{_filehash}->{$filename}; } sub DEBUG { my($this, $verbose) = @_; $verbose = 1 unless(defined($verbose) and int($verbose) == 0); $this->{_verbose} = $verbose; return; } sub _parseData { my($this) = @_; unless($this->{_filedata}) { $this->_dowarn("Cannot parse this archive. It appears to be blank"); return; } my $scratchdata = $this->{_filedata}; unless(substr($scratchdata, 0, SARMAG, "") eq ARMAG) { $this->_dowarn("Bad magic header token. Either this file is not an ar archive, or it is damaged. If you are sure of the file integrity, Archive::Ar may not support this type of ar archive currently. Please report this as a bug"); return ""; } while($scratchdata =~ /\S/) { if($scratchdata =~ s/^(.{58})`\n//s) { my $headers = {}; @$headers{qw/name date uid gid mode size/} = unpack("A16A12A6A6A8A10", $1); for (values %$headers) { $_ ||= ""; $_ =~ s/\s*$//; } $headers->{mode} = oct($headers->{mode}); $headers->{data} = substr($scratchdata, 0, $headers->{size}, ""); # delete padding, if any substr($scratchdata, 0, $headers->{size} % 2, ""); $this->_addFile($headers); }else{ $this->_dowarn("File format appears to be corrupt. The file header is not of the right size, or does not exist at all"); return; } } return scalar($this->{_files}); } sub _readFromFilename { my ($this, $filename) = @_; my $handle; open $handle, $filename or return; binmode $handle; return $this->_readFromFilehandle($handle); } sub _readFromFilehandle { my ($this, $filehandle) = @_; return unless $filehandle; #handle has to be open return unless fileno $filehandle; local $/ = undef; $this->{_filedata} = <$filehandle>; close $filehandle; return length($this->{_filedata}); } sub _addFile { my ($this, $file) = @_; return unless $file; foreach(qw/name date uid gid mode size data/) { unless(exists($file->{$_})) { $this->_dowarn("Can't _addFile because virtual file is missing $_ parameter"); return; } } if(exists($this->{_filehash}->{$file->{name}})) { $this->_dowarn("Can't _addFile because virtual file already exists with that name in the archive"); return; } push @{$this->{_files}}, $file->{name}; $this->{_filehash}->{$file->{name}} = $file; return $file->{name}; } sub _remFile { my ($this, $filename) = @_; return unless $filename; if(exists($this->{_filehash}->{$filename})) { delete $this->{_filehash}->{$filename}; @{$this->{_files}} = grep(!/^$filename$/, @{$this->{_files}}); return 1; } $this->_dowarn("Can't remove file $filename, because it doesn't exist in the archive"); return 0; } sub _initValues { my ($this) = @_; $this->{_files} = []; $this->{_filehash} = {}; $this->{_filedata} =""; return; } sub _dowarn { my ($this, $warning) = @_; if($this->{_verbose}) { warn "DEBUG: $warning"; } return; } 1; __END__ =head1 NAME Archive::Ar - Interface for manipulating ar archives =head1 SYNOPSIS use Archive::Ar; my $ar = new Archive::Ar("./foo.ar"); $ar->add_data("newfile.txt","Some contents", $properties); $ar->add_files("./bar.tar.gz", "bat.pl") $ar->add_files(["./again.gz"]); $ar->remove("file1", "file2"); $ar->remove(["file1", "file2"); my $filedata = $ar->get_content("bar.tar.gz"); my @files = $ar->list_files(); $ar->read("foo.deb"); $ar->write("outbound.ar"); $ar->DEBUG(); =head1 DESCRIPTION Archive::Ar is a pure-perl way to handle standard ar archives. This is useful if you have those types of old 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 =head2 Class Methods =over 4 =item * C =item * C)> =item * C,I<$debug>)> Returns a new Archive::Ar object. Without a filename or glob, it returns an empty object. If passed a filename as a scalar or in a GLOB, it will attempt to populate from either of those sources. If it fails, you will receive undef, instead of an object reference. This also can take a second optional debugging parameter. This acts exactly as if C is called on the object before it is returned. If you have a C that keeps failing, this should help. =back =over 4 =item * C)> =item * C)>; This reads a new file into the object, removing any ar archive already represented in the object. Any calls to C are not lost by reading in a new file. Returns the number of bytes read, undef on failure. =back =over 4 =item * C)> This read information from the first parameter, and attempts to parse and treat it like an ar archive. Like C, it will wipe out whatever you have in the object and replace it with the contents of the new archive, even if it fails. Returns the number of bytes read (processed) if successful, undef otherwise. =back =over 4 =item * C This lists the files contained inside of the archive by filename, as an array. If called in a scalar context, returns a reference to an array. =back =over 4 =item * C, I<"filename2">)> =item * C)> Takes an array or an arrayref of filenames to add to the ar archive, in order. The filenames can be paths to files, in which case the path information is stripped off. Filenames longer than 16 characters are truncated when written to disk in the format, so keep that in mind when adding files. Due to the nature of the ar archive format, C will store the uid, gid, mode, size, and creation date of the file as returned by C; C returns the number of files successfully added, or undef on failure. =back =over 4 =item * C, I<$filedata>)> Takes an filename and a set of data to represent it. Unlike C, C is a virtual add, and does not require data on disk to be present. The data is a hash that looks like: $filedata = { "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. =back =over 4 =item * C =item * C)> This method will return the data as an .ar archive, or will write to the filename present if specified. If given a filename, C will return the length of the file written, in bytes, or undef on failure. If the filename already exists, it will overwrite that file. =back =over 4 =item * C)> This returns a hash with the file content in it, including the data that the file would naturally contain. If the file does not exist or no filename is given, this returns undef. On success, a hash is returned with the following keys: name - The file name date - The file date (in epoch seconds) uid - The uid of the file gid - The gid of the file mode - The mode permissions size - The size (in bytes) of the file data - The contained data =back =over 4 =item * C, I<"filename2">)> =item * C)> The remove method takes a filenames as a list or as an arrayref, and removes them, one at a time, from the Archive::Ar object. This returns the number of files successfully removed from the archive. =back =over 4 =item * C This method turns on debugging. Optionally this can be done by passing in a value as the second parameter to new. While verbosity is enabled, Archive::Ar will toss a C if there is a suspicious condition or other problem while proceeding. This should help iron out any problems you have while using the module. =back =head1 CHANGES =over 4 =item * B - May 14, 2013 Use binmode for portability. Closes RT #81310 (thanks to Stanislav Meduna). =item * B - October 14, 2009 Fix list_files to return a list in list context, to match doc. 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). =item * B - 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 =item * B - April 30th, 2003 Removed unneeded exports. Thanks to pudge for the pointer. =item * B - April 14th, 2003 Found podchecker. CPAN HTML documentation should work right now. =item * B - April 10th, 2003 Trying to get the HTML POD documentation to come out correctly =item * B - April 10th, 2003 Documentation cleanups Added a C function =item * B - April 7th, 2003 This is the initial public release for CPAN, so everything is new. =back =head1 TODO A better unit test suite perhaps. I have a private one, but a public one would be nice if there was good file faking module. Fix / investigate stuff in the BUGS section. =head1 BUGS To be honest, I'm not sure of a couple of things. The first is that I know of ar archives made on old AIX systems (pre 4.3?) that have a different header with a different magic string, etc. This module perfectly (hopefully) handles ar archives made with the modern ar command from the binutils distribution. If anyone knows of anyway to produce these old-style AIX archives, or would like to produce a few for testing, I would be much grateful. There's no really good reason why this module I run on Win32 platforms, but admittedly, this might change when we have a file exporting function that supports owner and permission writing. If you read in and write out a file, you get different md5sums, but it's still a valid archive. I'm still investigating this, and consider it a minor bug. =head1 COPYRIGHT Archive::Ar is 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. =cut Archive-Ar-1.15/MANIFEST0000644000175000017500000000030212144564242012627 0ustar jsbjsbCHANGES lib/Archive/Ar.pm Makefile.PL MANIFEST This list of files t/10objects.t t/20new.t t/30write.t t/40mode.t META.yml Module meta-data (added by MakeMaker) Archive-Ar-1.15/CHANGES0000644000175000017500000000243412144563431012500 0ustar jsbjsbVersion 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-1.15/Makefile.PL0000644000175000017500000000113112144560360013446 0ustar jsbjsbuse ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'Archive::Ar', 'VERSION_FROM' => 'lib/Archive/Ar.pm', # finds $VERSION 'PREREQ_PM' => { 'Test::More' => '0.45', 'File::Spec' => '0.83', 'Time::Local' => '1.04', 'Test::MockObject' => '0.12', '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 ') : ()), ); Archive-Ar-1.15/t/0000755000175000017500000000000012144564242011746 5ustar jsbjsbArchive-Ar-1.15/t/10objects.t0000644000175000017500000000060712144560360013725 0ustar jsbjsb#!/usr/bin/perl -w use Test::More tests => 13; my $mod = "Archive::Ar"; use_ok("File::Spec"); use_ok("Time::Local"); use_ok($mod); can_ok($mod, "new"); can_ok($mod, "list_files"); can_ok($mod, "read"); can_ok($mod, "read_memory"); 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, "DEBUG"); Archive-Ar-1.15/t/20new.t0000644000175000017500000000210212144560360013056 0ustar jsbjsb#!/usr/bin/perl -w use Test::More tests => 9; use Test::MockObject; my $mod = "Archive::Ar"; my $mock = new Test::MockObject; my $ar; use_ok($mod); can_ok($mod, "new"); $mock->set_false("read"); local *Archive::Ar::read; *Archive::Ar::read = sub { return $mock->read(); }; ok($ar = new Archive::Ar, "The new operator without any arguments should always succeed"); ok($ar = Archive::Ar->new(), "Class-method new() without any arguments"); ok(!$mock->called("read"), "Archive::Ar's read() shouldn't be called if there are no arguments"); $ar = new Archive::Ar("myfilename"); ok(!$ar, "The new operator with a filename should fail if read fails"); ok($mock->called("read"), "Object creation should call read() if it is given a filename"); $mock->clear(); my $GLOB = *STDIN; $ar = new Archive::Ar($GLOB); ok(!$ar, "The new operator with a GLOB should fail if read fails"); ok($mock->called("read"), "Object creation should call read() if it is given a file GLOB"); # The rest will have to be done with integration tests, as there is no good fake filesystem mod $mock->clear(); Archive-Ar-1.15/t/30write.t0000644000175000017500000000104412144560360013424 0ustar jsbjsb#!/usr/bin/perl -w use Test::More (tests => 2); use strict; use Archive::Ar(); my ($padding_archive) = new Archive::Ar(); $padding_archive->add_data("test.txt", "here\n"); my ($archive_results) = $padding_archive->write(); ok(length($archive_results) == 74, "Archive::Ar pads un-even number of bytes successfully\n"); $padding_archive = new Archive::Ar(); $padding_archive->add_data("test.txt", "here1\n"); $archive_results = $padding_archive->write(); ok(length($archive_results) == 74, "Archive::Ar pads even number of bytes successfully\n"); Archive-Ar-1.15/t/40mode.t0000644000175000017500000000354512144560360013227 0ustar jsbjsb#!/usr/bin/perl -w use Test::More tests => 19; use File::Temp qw(tempfile); use Archive::Ar; my ($fh, $file) = tempfile(UNLINK => 1); my $data; while () { next if /^#/; chomp; $data .= unpack('u', $_); } print $fh $data; 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); print $nfh $ar->write; 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'); __END__ # # Uuencoded ar archive produced by ar(1). # M(3QA license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: File::Spec: 0.83 File::Temp: 0 Test::MockObject: 0.12 Test::More: 0.45 Time::Local: 1.04 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: 1.4