view release on metacpan or  search on metacpan

bin/ar  view on Meta::CPAN

		print "\n<$name>\n\n" if $verbose;
		print $pAr->{$name}[6];
		}
	else {
		warn "entry not found in archive: '$name'\n";
		}
	}

# writes a directory-style listing for the specified archive member
sub printList {
	my ( $name, $pAr, $verbose ) = @_;

	my $attr = $pAr->{$name};
	unless ( defined $attr ) {
		warn "entry not found in archive: '$name'\n";
		return;
		}
	if ($verbose) {
		printf "%9s %7d/%-7d %7d %s %s\n",
			strmode( $attr->[4] ),
			$attr->[2],
			$attr->[3],
			$attr->[5],
			strftime( "%b %e %H:%M %Y", localtime( $attr->[1] ) ),
			$name;
		}
	else {
		print "$name\n";
		}
	}

# extracts $name from archive and writes to current working directory
sub extractMember {
	my ( $name, $pAr, $verbose, $settime, $update ) = @_;

	my $attr = $pAr->{$name};

	# get current uid/gid and mode
	my @stat = stat($name) if -e $name;
	my ( $uid, $gid, $mode, $modt );
	if (@stat) {
		( $uid, $gid, $mode, $modt ) = ( $stat[4], $stat[5], $stat[2], $stat[9] );

		# skip if -u and existing file is newer
		if ($update) {
			return if $modt >= $attr->[1];
			}

		}
	else {
		( $uid, $gid, $mode, $modt ) = ( int( $attr->[2] ), int( $attr->[3] ), oct( $attr->[4] ), int( $attr->[1] ) );
		}

	my $out = FileHandle->new( $name, 'w' ) or die "$name: $!\n";
	binmode($out);
	$out->print( $attr->[6] );
	$out->close();

	# these might fail, but that's OK
	chmod $mode, $name;
	chown $uid, $gid, $name;
	if ($settime) {
		utime $modt, $modt, $name;
		}

	print "x - $name\n" if $verbose;
	}

# read in a new file and return array ref of
# [ undef, $modt, $uid, $gid, $mode, $sz, $data ]
sub readFile {
	my ($file) = @_;
	my $in = FileHandle->new( $file, 'r' ) or die "$file: $!\n";
	binmode($in);

	# read the data in one swell foop
	undef $/;
	my $data = <$in>;

	# get some attributes
	my @stat = stat($file);

	# return an array ref of attrs and data
	return [ undef, $stat[9], $stat[4], $stat[5], sprintf( "%o", $stat[2] ), $stat[7], $data ];
	}

# try to read an archive from $archive.
# returns a ref to a hash of name => [ index, header, data ]
# and a ref to an array of names in order, i.e., [ [name1], [name2], etc. ]
sub readAr {
	my ($archive) = @_;

	# hash of header/data
	my %Ar;

	# names in order in file
	my @Names = (undef);

	my $arfh = FileHandle->new( $archive, 'r' ) or die "$0: $archive: $!\n";
	binmode($arfh);

	# read magic
	my $magic;
	my $nread = read $arfh, $magic, length(MAGIC);
	die "$0: $archive: $!\n" unless defined $nread;
	if ( $magic ne MAGIC ) {
		die "$0: $archive: Inappropriate file type or format\n";
		}

	while ( !$arfh->eof() ) {
		# read header
		my ( $name, $modt, $uid, $gid, $mode, $sz, $delim );
		(           $arfh->read( $name, 16 ) == 16
				and $arfh->read( $modt,  12 ) == 12
				and $arfh->read( $uid,   6 ) == 6
				and $arfh->read( $gid,   6 ) == 6
				and $arfh->read( $mode,  8 ) == 8
				and $arfh->read( $sz,    10 ) == 10
				and $arfh->read( $delim, 2 ) == 2
				and $delim eq "`\n" )
			or die "$0: $archive: Inappropriate file type or format\n";