view release on metacpan or  search on metacpan

bin/ar  view on Meta::CPAN

# extract position offset
my $position;
if ( $opt_a || $opt_b ) {
	my $val = shift;
	usage() unless defined $val;
	$position = basename($val);
	}

# the archive filename
my $archive = shift;
unless ( defined $archive ) {
	warn "$0: archive file required\n";
	usage();
	}
my $pAr    = {};    # the archive is just a hash of name => [ header, data ]
my $pNames = [];    # a ref to an array of names in the order they appear

# read the archive
if ( $opt_d || $opt_m || $opt_p || $opt_t || $opt_x || ( -e $archive && $opt_r ) ) {
	( $pAr, $pNames ) = readAr($archive);
	}

# if positional param, then get array index to specified name
my $idx;
if ( $opt_b || $opt_a ) {
	if ( $pAr->{$position} ) {
		$idx = $pAr->{$position}[0];
		if ($opt_b) { $idx--; }
		}
	else {
		die "$0: $position: archive member not found.\n";
		}
	}

# loop through each file, adding, moving, extracting, etc.
for my $file (@ARGV) {
	my $name = basename($file);

	# do the task
	if ($opt_d) {
		# delete
		if ( defined( $pAr->{$name} ) ) {
			undef $pAr->{$name};
			print "d - $name\n" if $opt_v;
			}
		else {
			warn "$0: $name: not found in archive\n";
			}
		}
	elsif ($opt_m) {
		# move
		my $putpos = $idx;

		# if no positional parameter, then append
		if ( !defined($idx) ) { $putpos = @$pNames; }

		# remove from current position
		@{ $pNames->[ $pAr->{$name}[0] ] } = grep( !/^$name$/, @{ $pNames->[ $pAr->{$name}[0] ] } );

		# relocate to $putpos
		$pAr->{$name}[0] = $putpos;
		push( @{ $pNames->[$putpos] }, $name );
		print "m - $name\n" if $opt_v;
		}
	elsif ($opt_p) {
		# print
		printMember( $name, $pAr, $opt_v );
		}
	elsif ($opt_q) {
		# quick append
		my $desc = readFile($file);
		push( @$pNames, [$name] );
		$desc->[0] = $#$pNames;
		$pAr->{$name} = $desc;
		print "a - $name\n" if $opt_v;
		}
	elsif ($opt_r) {
		# replace or add
		my $putpos = $idx;

		# append if no positional param
		if ( !defined($idx) ) { $putpos = @$pNames; }

		my $desc = readFile($file);

		if ( $pAr->{$name} ) {
			# replace
			if ($opt_u) {
				# only replace if mod time is newer
				my @stat = stat($name);
				next if ( $desc->[1] <= $pAr->{$name}[1] );
				}
			$pAr->{$name} = $desc;
			print "r - $name\n" if $opt_v;
			}
		else {
			# add
			$desc->[0] = $putpos;
			push( @{ $pNames->[$putpos] }, $name );
			$pAr->{$name} = $desc;
			print "a - $name\n" if $opt_v;
			}
		}
	elsif ($opt_t) {
		# table of contents
		printList( $name, $pAr, $opt_v );
		}
	elsif ($opt_x) {
		# extract
		if ( defined( $pAr->{$name} ) ) {
			extractMember( $name, $pAr, $opt_v, $opt_o, $opt_u );
			}
		else {
			warn "$0: $name: not found in archive\n";
			}
		}
	}

# no files given.  -p, -t, and -x will apply to all in archive.
if ( !@ARGV ) {