view release on metacpan or  search on metacpan

lib/Archive/Ar/Ng.pm  view on Meta::CPAN

###########################################################
#    Archive::Ar - Pure perl module to handle ar achives
#
#    Copyright 2003 - Jay Bonci <jaybonci@cpan.org>
#    Copyright 2014 - John Bazik <jbazik@cpan.org>
#    Copyright 2019 - Varadi Gabor <varadi@mithrandir.hu>
#    Copyright 2019 - Fazekas Balint <fazekas.balint@mithrandir.hu>
#    Licensed under the same terms as perl itself
#
###########################################################
package Archive::Ar::Ng;

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 Fcntl qw( SEEK_SET SEEK_END );

use vars qw( $VERSION );
$VERSION = '2.04';

use constant CAN_CHOWN => ( $> == 0 and $^O ne 'MacOS' and $^O ne 'MSWin32' );

use constant ARMAG    => "!<arch>\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;

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 clear {
  my $self = shift;
  $self->{names} = [];
  $self->{files} = {};
  $self->{type}  = undef;
  if ( defined $self->{fh} ) {
    close( $self->{fh} );
  }
  $self->{fh} = undef;
}

sub myread {
  my $self = shift;
  my $fpos = shift;
  my $rlen = shift;
  my $dvar = undef;
  sysseek( $self->{fh}, $fpos, SEEK_SET );
  sysread( $self->{fh}, $dvar, $rlen );
  return $dvar;
}

sub read {
  my $self = shift;
  my $file = shift;
  open my $fh, '<', $file or return $self->_error( "$file: $!" );
  binmode $fh;
  $self->{fh} = $fh;
  my $x = $self->_parse();
  return $x;
}

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 write {

lib/Archive/Ar/Ng.pm  view on Meta::CPAN

      }
    } else {
      print $tmpfn $self->myread( $fpos, $size );
    }
    $fpos += $size + ( $size % 2 );
    print $tmpfn "\n" if $size % 2;    # padding
  }
  if ( $filename ) {
    my $len      = 0;
    my @filestat = stat $tmpfn;
    $len = $filestat[7];
    close $tmpfn;
    return $len;
  } else {
    seek $tmpfn, 0, 0;
    binmode( $tmpfn );
    my $out = <$tmpfn>;
    close $tmpfn;
    unlink $tmpfn;
    return $out;
  }
}

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 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;
##--
  sysseek( $self->{fh}, $meta->{fpos}, SEEK_SET );
  my $rpos = 0;
  my $rbuf;
  while ( $rpos < $meta->{size} ) {
    my $blk_size = ( $meta->{size} - $rpos );
    if ( $blk_size > 16384 ) {
      $blk_size = 16384;
    }
    $rpos += sysread( $self->{fh}, $rbuf, $blk_size ) or return $self->_error( "$filename: $!" );
    syswrite( $fh, $rbuf, $blk_size ) or return $self->_error( "$filename: $!" );
  }
  undef $rbuf;
##--
  close $fh or return $self->_error( "$filename: $!" );
  if ( CAN_CHOWN && $self->{opts}->{chown} ) {
    chown $meta->{fuid}, $meta->{fgid}, $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 list_files {
  my $self = shift;
  return wantarray ? @{$self->{names}} : $self->{names};
}

sub _parse {
  my $self = shift;
  my $fpos = 0;
  my $type;
  my $names;
  my $flen = sysseek( $self->{fh}, 0, SEEK_END );
  sysseek( $self->{fh}, 0, SEEK_SET );
  unless ( $self->myread( $fpos, SARMAG ) eq ARMAG ) {
    return $self->_error( "Bad magic number - not an ar archive" );
  }
  $fpos += SARMAG;
  while ( $fpos < $flen ) {
    my ( $name, $date, $uid, $gid, $mode, $size, $magic ) = unpack( 'A16A12A6A6A8A10a2', $self->myread( $fpos, 60 ) );
    $fpos += 60;
    unless ( $magic eq "`\n" ) {
      return $self->_error( "Bad file header" );
    }
    if ( $name =~ m|^/| ) {
      $type = GNU;
      if ( $name eq '//' ) {
        $names = $self->myread( $fpos, $size );
        $fpos += $size + ( $size % 2 );
        next;
      } elsif ( $name eq '/' ) {
        $name = $self->{opts}->{symbols};
        unless ( defined $name && $name ) {
          $fpos += $size + ( $size % 2 );
          next;
        }
      } else {
        $name = substr( $names, int( substr( $name, 1 ) ) );
        $name = substr( $name, 0, index( $name, "\n" ) );
        chop $name;
      }
    } elsif ( $name =~ m|^#1/| ) {
      $type = BSD;
      my $l = int( substr( $name, 3 ) );
      $name = $self->myread( $fpos, $l );
      $fpos += $l;
      $size -= length( $name );
    } else {
      if ( $name =~ m|/$| ) {
        $type ||= GNU;    # only gnu has trailing slashes