File Coverage

blib/lib/Archive/Ar.pm

Criterion	Covered	Total	%
statement	279	312	89.4
branch	87	144	60.4
condition	32	49	65.3
subroutine	39	43	90.7
pod	21	23	91.3
total	458	571	80.2

###########################################################
#    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__