ar

#!/usr/bin/perl

=begin metadata

Name: ar
Description: create and maintain library archives
Author: dkulp
License: perl

=end metadata

=cut

use strict;

use POSIX qw(strftime);
use File::Basename;
use FileHandle;
use Getopt::Std qw(getopts);

use constant MAGIC => "!<arch>\n";

use vars qw($opt_d $opt_m $opt_p $opt_q $opt_r $opt_t $opt_x $opt_a $opt_b
    $opt_c $opt_i $opt_o $opt_u $opt_v);

# allow the first arg to not have a '-'.
if (@ARGV && $ARGV[0] !~ /^\-/) { $ARGV[0] = '-' . $ARGV[0]; }

getopts('dmpqrtxabciouv') or usage();

# take only one of the following major opts
my @major = map { $_ || () } ($opt_d, $opt_m, $opt_p, $opt_q, $opt_r,
    $opt_t, $opt_x);
usage() unless scalar(@major) == 1;

# -i is the same as -b
$opt_b |= $opt_i;

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

# 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;
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 {
	    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.
if (!@ARGV) {
    if ($opt_p || $opt_t || $opt_x) {
	for my $group (@$pNames) {
	    for my $name (@$group) {
		if ($opt_p) { printMember($name,$pAr,$opt_v); }
		elsif ($opt_t) { printList($name,$pAr,$opt_v); }
		elsif ($opt_x) { extractMember($name, $pAr, $opt_v,
					       $opt_o, $opt_u); }
	    }
	}
    }
    else {
	die "$0: no archive members specified\n";
    }
}

# write to file if modified, updated, deleted
if ($opt_m || $opt_r || $opt_q || $opt_d) {
    writeAr($pAr, $pNames, $archive, $opt_q);
}

exit 0;

# dump an archive member as per -p option
sub printMember {
    my ($name, $pAr, $verbose) = @_;

    if (exists $pAr->{$name}) {
	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};
    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;
    read($arfh,$magic,8);
    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";

	# read the file
	my $data;
	($arfh->read($data, $sz) == $sz) or
	  die "$0: $archive: Inappropriate file type or format\n";

	# always an even number of bytes.  if odd, read another byte.
	if ($sz % 2 == 1) { getc($arfh); }

	# if name starts with #1/len, then read first len bytes as name
	if ($name =~ /\#1\/(\d+)/) {
	    $name = substr($data,0,$1);
	    $data = substr($data,$1);
	    $sz -= $1;
	}
	else {
	    # strip trailing spaces in name.  There's no way
	    # to distinguish spaces in a filename with padding.
	    $name =~ s/\s+$//;
	}

	# add to list of names and hash of header/data
	if (exists($Ar{$name})) {
	    # complain if dup entries.  no need to do anything about it
	    # since spec requires to work on first occurrence only.
	    warn "$0: $name exists more than once in the archive.\n";
	}
	else {
	    push(@Names, [ $name ] );
	    $Ar{$name} = [ $#Names, $modt, $uid, $gid, $mode, $sz, $data ];
	}
    }
    $arfh->close();
    return(\%Ar, \@Names);
}

# write an archive to $archive
sub writeAr {
    my ($pAr, $pNames, $archive, $append) = @_;

    my $mode = $append ? 'a' : 'w';
    my $putmagic = !$append || !-e $archive;
    my $arfh = FileHandle->new($archive, $mode)
      or die "$0: failed to open '$archive': $!\n";
    $arfh->print(MAGIC) if $putmagic;

    # loop through each member of the archive and write to filehandle
    for my $group (@$pNames) {
	for my $name (@$group) {
	    if ($pAr->{$name}) {
		my $attr = $pAr->{$name};
		my $sz = $attr->[5];
		if (length($name) > 16) {
		    $sz += length($name);
		    printf $arfh "#1/%-13d",length($name);
		    printf $arfh "%-12d%-6d%-6d%-8s%-10d", @$attr[1..4],$sz;
		    print $arfh "`\n$name";
		}
		else {
		    printf $arfh "%-16s",$name;
		    printf $arfh "%-12d%-6d%-6d%-8s%-10d`\n", @$attr[1..5];
		}

		print $arfh $attr->[6];

		# always even number of data bytes.  if odd, add a "\n"
		if ($sz % 2 == 1) {
		    $arfh->print("\n");
		}
	    }
	}
    }

    $arfh->close();
}

# converts a mode to an "ls -l" type string description.
# This isn't likely portable.
sub strmode {
    my ($mode) = @_;

    # just the RWX bits.
    $mode = oct($mode) & 0777;
    my @modemap = (0400 => 'r',    #  R for owner
		   0200 => 'w',    #  W for owner
		   0100 => 'x',    #  X for owner

		   0040 => 'r',    #  R for group
		   0020 => 'w',    #  W for group
		   0010 => 'x',    #  X for group

		   0004 => 'r',    #  R for other
		   0002 => 'w',    #  W for other
		   0001 => 'x');   #  X for other

    my $modestr;
    while (@modemap) {
	my ($bit,$letter) = splice(@modemap,0,2);
	if ($mode & $bit) {
	    $modestr .= $letter;
	}
	else {
	    $modestr .= "-";
	}
    }
    return $modestr;
}

sub usage {
    print <<EOT ;
usage: ar -d [-v] archive file ...
   ar -m [-v] archive file ...
   ar -m [-abiv] position archive file ...
   ar -p [-v] archive [file ...]
   ar -q [-cv] archive file ...
   ar -r [-cuv] archive file ...
   ar -r [-abciuv] position archive file ...
   ar -t [-v] archive [file ...]
   ar -x [-ouv] archive [file ...]
EOT
  exit;
}

__END__

=pod

=head1 NAME

ar - create and maintain library archives

=head1 SYNOPSIS

     ar -d [-v] archive file ...
     ar -m [-v] archive file ...
     ar -m [-abiv] position archive file ...
     ar -p [-v] archive [file ...]
     ar -q [-cv] archive file ...
     ar -r [-cuv] archive file ...
     ar -r [-abciuv] position archive file ...
     ar -t [-v] archive [file ...]
     ar -x [-ouv] archive [file ...]

=head1 DESCRIPTION

The ar utility creates and maintains groups of files combined into an
archive.  Once an archive has been created, new files can be added and
existing files can be extracted, deleted, or replaced.

Files are named in the archive by a single component, i.e., if a file
referenced by a path containing a full pathname is archived it will be
named by the last component of that path.  When matching paths listed on
the command line against file names stored in the archive, only the last
component of the path will be compared.

If multiple files in the archive have the same name, and paths are listed
on the command line to ``select'' archive files for an operation, only
the first file with a matching name will be selected.

The normal use of ar is for the creation and maintenance of libraries
suitable for use with the loader (see ld(1)) although it is not
restricted to this purpose.

=head2 OPTIONS

I<ar> accepts the following options:

=over 4

=item -a

A positioning modifier used with the options -B<r> and -B<m>. The files
are entered or moved after the archive member position, which
must be specified.

=item -b

A positioning modifier used with the options -B<r> and -B<m>. The files
are entered or moved before the archive member position, which
must be specified.

=item -c

Whenever an archive is created, an informational message to that
effect is written to standard error.  If the -B<c> option is specified,
ar creates the archive silently.

=item -d

Delete the specified archive files.

=item -i

Identical to the -B<b> option.

=item -m

Move the specified archive files within the archive.  If one of
the options -B<a>, -B<b> or -B<i> is specified, the files are moved before
or after the position file in the archive.  If none of those options
are specified, the files are moved to the end of the
archive.

=item -o

Set the access and modification times of extracted files to the
modification time of the file when it was entered into the
archive.  This will fail if the user is not the owner of the extracted
file or the super-user.

=item -p

Write the contents of the specified archive files to the standard
output.  If no files are specified, the contents of all the files
in the archive are written in the order they appear in the
archive.

=item -q

(Quickly) append the specified files to the archive.  If the
archive does not exist a new archive file is created.  Much
faster than the -B<r> option, when creating a large archive piece-by-piece,
as no checking is done to see if the files already
exist in the archive.

=item -r

Replace or add the specified files to the archive.  If the
archive does not exist a new archive file is created.  Files that
replace existing files do not change the order of the files with-
in the archive.  New files are appended to the archive unless one
of the options -B<a>, -B<b> or -B<i> is specified.

=item -t

List the specified files in the order in which they appear in the
archive, each on a separate line.  If no files are specified, all
files in the archive are listed.

=item -u

Update files.  When used with the -B<r> option, files in the archive
will be replaced only if the disk file has a newer modification
time than the file in the archive.  When used with the -B<x> option,
files in the archive will be extracted only if the archive file
has a newer modification time than the file on disk.

=item -v

Provide verbose output.  When used with the -B<d>, -B<m>, -B<q> or -B<x> op-
tions, ar gives a file-by-file description of the archive modifi-
cation.  This description consists of three, white-space separat-
ed fields: the option letter, a dash (``-'') and the file name.
When used with the -B<r> option, ar displays the description as
above, but the initial letter is an ``a'' if the file is added to
the archive and an ``r'' if the file replaces a file already in
the archive.

When used with the -B<p> option, the name of each printed file,
enclosed in less-than (``<'') and greater-than (``>'') characters, is
written to the standard output before the contents of the file; it is
preceded by a single newline character, and followed by two newline
characters.

When used with the -B<t> option, ar displays an ``ls -C<l>'' style
listing of information about the members of the archive.  This
listing consists of eight, white-space separated fields: the file
permissions,  the decimal user and group ID's,
separated by a single slash (``/''), the file size (in bytes),
the file modification time (in the date(1) format ``%b %e %H:%M
%Y''), and the name of the file.

=item -x

Extract the specified archive members into the files named by the
command line arguments.  If no members are specified, all the
owner and group will be unchanged.  The file access and modifica-
tion times are the time of the extraction (but see the -B<o> op-
tion).  The file permissions will be set to those of the file
when it was entered into the archive; this will fail if the user
is not the owner of the extracted file or the super-user.

=back

I<ar> exits 0 on success, and >0 if an error occurs.

=head1 ENVIRONMENT

The working of I<ar> is not influenced by any environment variables.

=head1 BUGS

I<ar> uses POSIX::strftime(), which isn't part of the basic distribution.
The entire archive is loaded into memory, which could be slow or exhaust
memory.  The "-B<tv>" option does an "ls -C<l>"-style output, but the
interpretation of the mode bits is probably not portable.  I<ar> doesn't
check for bogus minor options that don't make sense with a major option --
they're just ignored.

=head1 COPYRIGHT and LICENSE

This program is copyright by dkulp 1999.

This program is free and open software. You may use, copy, modify, distribute
and sell this program (and any modified variants) in any way you wish,
provided you do not restrict others to do the same.

=cut