#! /usr/bin/env perl

$VERSION = 0.2;

use Getopt::Long;
Getopt::Long::config qw(bundling no_getopt_compat);

my %opt;
GetOptions \%opt,
    't|table|list',
    'x|extract|get',
    'c|create',
    'd|createdata',
    'p|perl|perlcode',
    (($Getopt::Long::VERSION >= 2.17) ? 'h|help|?' : 'h|help') => sub {
	eval q{
	    use Pod::Usage;
	    pod2usage -output => \*STDERR;
	};
	exit;
    };

my $extractor = q{
while( <DATA> ) {
    chop;
    my $nl = 1;
    my( $dummy, $kind, $mode, $atime, $mtime, $name ) = split /\t/, $_, 6;
    if( $kind eq 'D' ) {
	mkdir $name, 0755 or die "mkdir $name: $!\n";
	$SPAR::mode{$name} = [oct( $mode ), $atime, $mtime];
	next;
    } elsif( $kind eq 'L' ) {
	chop( my $linkee = <DATA> );
	if( $mode eq 'S' ) { symlink $linkee, $name }
	else { link $linkee, $name }
	next;
    } elsif( $kind < 0 ) {
	$nl = 0;
	$kind = -1 - $kind;
    }
    open F, ">$name" or die ">$name: $!\n";
    for( 1..$kind ) { print F scalar <DATA> }
    if( !$nl ) { chop( $_ = <DATA> ); print F }
    close F;
    chmod oct( $mode ), $name;
    utime $atime, $mtime, $name;
}

for( keys %SPAR::mode ) {
    chmod shift @{$SPAR::mode{$_}}, $_;
    utime @{$SPAR::mode{$_}}, $_;
}
%SPAR::mode = ();
};

my $archive = shift;
if( $opt{c} || $opt{d} ) {
    open SPAR, ">$archive" or die ">$archive: $!\n";
    chmod 0755, $archive if $opt{c};
    print SPAR
	$opt{d} ?
	    "###	SPAR <http://www.cpan.org/scripts/>\n" :
	    <<EOH;
#! /usr/bin/env perl

# This file was generated by spar <http://www.cpan.org/scripts/>
# Run it with perl to unpack it.
$extractor
__DATA__
EOH

    use File::Find;
    find({ wanted => \&process, follow => 0 }, @ARGV ? @ARGV : '.');
    sub process {
	(my $name = $File::Find::name) =~ s!^\./!!;
	if( -l ) {
	    print SPAR "###	L	S	0	0	$name\n", readlink, "\n";
	    return;
	}
	($dev, $ino, $mode, $nlink, $atime, $mtime) = (stat)[0..3, 8, 9];
	$mode = sprintf "%o", $mode & 07777;
	if( $nlink > 1 ) {
	    if( -d ) {
		print SPAR "###	D	$mode	$atime	$mtime	$name\n";
		return;
	    } elsif( $seen{$dev, $ino} ) {
		print SPAR "###	L	H	0	0	$name\n$seen{$dev, $ino}\n";
		return;
	    } else {
		$seen{$dev, $ino} = $name;
	    }
	}
	open F, $_ or die "<$_: $!\n";
	my @file = <F>;
	close F;
	my $length = @file;
	if( $length and $file[-1] !~ /\n$/ ) {
	    $file[-1] .= "\n";
	    $length = -$length;
	}
	print SPAR "###	$length	$mode	$atime	$mtime	$name\n", @file;
    }
    close SPAR;
} elsif( $opt{x} ) {
    open DATA, $archive or die "$0: can't open $archive--$!\n";
    1 until <DATA> =~ /^###\tSPAR |^__DATA__$/;
    eval $extractor;
} elsif( $opt{t} ) {
    open DATA, $archive or die "$0: can't open $archive--$!\n";
    1 until <DATA> =~ /^###\tSPAR |^__DATA__$/;
    while( <DATA> ) {
	chop;
	my( $dummy, $kind, $mode, $atime, $mtime, $name ) = split /\t/, $_, 6;
	if( $kind eq 'D' ) {
	    print "directory 0$mode, '$name'\n";
	} elsif( $kind eq 'L' ) {
	    chop( my $linkee = <DATA> );
	    print +($mode eq 'S') ? 'symlink' : 'link   ', "   '$name' -> '$linkee'\n";
	} else {
	    $kind = abs $kind;
	    print "file      0$mode, $kind lines, ", scalar localtime $mtime, ", '$name'\n";
	    <DATA> for 1..$kind;
	}
    }
} elsif( $opt{p} ) {
    print '# spar extraction code <http://www.cpan.org/scripts/>
1 until <DATA> =~ /^###\tSPAR |^__DATA__$/;', $extractor;
}

__END__

=head1 NAME

spar -- Simple Perl ARchive manager


=head1 SYNOPSIS

    spar option ... archive[ file ...]

Creates or extracts a poor man's archive.  Especially when containing lots of
small files it can be by a factor smaller than a tar.

=head2 Options

=over

=item -t, --table, --list

Show a table of contents.

=item -c, --create

Creates the archive of all given files as a self unpacking Perl script.  If no
files are given, archives the current directory.

=item -d, --createdata

Like --create, but the file only contains the data.  It will require either
spar or the code output by C<spar --perlcode> to unpack it.

=item -x, --extract, --get

Extract all files and directories contained in the archive.

=item -p, --perl, --perlcode

Output code you can paste into your script to extract a spar archive.

=back


=head1 DESCRIPTION

Creates or extracts a poor man's archive.  Especially when containing lots of
small files it can be by a factor smaller than a tar.  But it is limited to
text files.

Unlike one of the two par utilities available on the internet, the content
here is completely separated from the extraction-code in Perl.  (The other par
is only a perl frontend to zip.)


=head1 FORMAT

The archive format is plain text.  Special characters within the files or
file names are not masked.  All metadata resides on lines starting with
C<###\t>.  There are the following kinds of metadata:

=over 4

=item C<SPAR> I<url>

This is the magic number on the first line of data-only spars.  The url is
from where you can download the spar program.

=item C<D\t>I<mode>C<\t>I<atime>C<\t>I<mtime>C<\t>I<name>

This creates the directory I<name>.  I<name> may contain any characters
except for a newline.  The I<mode> is octal and I<atime> and I<mtime> are as
in the C<utime> function.  The I<mode> is only set after extracting the
directory contents, so you can extract write-protected directories.

=item I<lines>C<\t>I<mode>C<\t>I<atime>C<\t>I<mtime>C<\t>I<name>

This marks the next I<lines> lines as the content of file I<name>.  Those
lines are directly followed by the end of file, or another metadata line. 
Due to the I<lines>-count, the file may istself contain lines matching
spar-metadata (i.e. an embedded spar) without confusing spar.  If I<lines> is
negative, the extracted file will not end with a newline.  The I<mode> is
octal and I<atime> and I<mtime> are as in the C<utime> function.

=item C<L\tH\t0\t0\t>I<name>

=item C<L\tS\t0\t0\t>I<name>

These create the link (H) or symlink (S) I<name>.  The name of the file
linked to is on the following line.  The mode and times of the links
themselves are whatever the system makes them.

=back

=head1 AUTHOR

Daniel Pfeiffer <occitan@esperanto.org>

=begin CPAN

=head1 README

Creates or extracts a poor man's archive in Perl.  With lots of small files
it can be by a factor smaller than a tar.  But it is limited to text files.

=pod SCRIPT CATEGORIES

UNIX/System_administration
VersionControl/CVS
Win32/Utilities