view release on metacpan or  search on metacpan

src/ar/ar.kulp  view on Meta::CPAN

# just ignore minor opts that don't apply to a major opt 

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

# the archive filename
my $archive = shift;
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.
my $file;
foreach $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 {
	    die "$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 {
	    die "$0: $name: not found in archive\n";
	}
    }
}

# no files given.  -p, -t, and -x will apply to all in archive.