#! /usr/bin/env perl

$VERSION = 0.4;

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',
    'E|exclude=s' => \@exclude,
    'X|exclude-from=s',
    'e|emacs|emacsmode',
    '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{
print "1\n" until <DATA> =~ /^###\tSPAR |^__DATA__/;
my( $lines, $kind, $mode, $atime, $mtime, $name, $nl ) = (-1, 0);
while( <DATA> ) {
    s/\r?\n$//;			# cross-plattform chomp
    if( $lines >= 0 ) {
	print F $_, $lines ? "\n" : $nl;
    } elsif( $kind eq 'L' ) {
	if( $mode eq 'S' ) { symlink $_, $name }
	else { link $_, $name }
	$kind = 0;
    } else {
	($kind, $mode, $atime, $mtime, $name) = (split /\t/, $_, 6)[1..5];
	if( $kind eq 'D' ) {
	    mkdir $name, 0700 or die "mkdir $name: $!\n";
	    $SPAR::mode{$name} = [oct( $mode ), $atime, $mtime];
	} elsif( $kind ne 'L' ) {
	    open F, ">$name" or die ">$name: $!\n";
	    $lines = abs $kind;
	    $nl = ($kind < 0) ? '' : "\n";
	}
    }
} continue {
    if( !$lines-- ) {
	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{x} ) {
    open DATA, $archive or die "$0: can't open $archive--$!\n";
    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( $kind, $mode, $atime, $mtime, $name ) = (split /\t/, $_, 6)[1..5];
	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{e} ) {
    $/ = "\n=";
    while( <DATA> ) {
	print, last if s/^begin Emacs\n+// && s/\n=$//s;
    }
} elsif( $opt{p} ) {
    print "# spar <http://www.cpan.org/scripts/> extraction code\n$extractor;"
} elsif( $opt{c} || $opt{d} || $archive eq '-' || !-f $archive ) {
    if( $opt{X} ) {
	open F, $opt{X};
	while( <F> ) {
	    chomp;
	    push @exclude, $_;
	}
    }
    $exclude{$_} = 1 for @exclude;
    open SPAR, ">$archive" or die ">$archive: $!\n";
    chmod 0755, $archive if $opt{c} and $archive ne '-';
    print SPAR
	$opt{c} ? <<EOH : "###	SPAR <http://www.cpan.org/scripts/>\n";
#! /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, preprocess => sub { sort @_ } }, @ARGV ? @ARGV : '.');
    sub process {
	(my $name = $File::Find::name) =~ s!^\./!!;
	return if $name eq '.';
	$File::Find::prune = 1, return if $exclude{$name};
	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;
} else {
    die "$0: no command given\n";
}

__END__

=begin Emacs

(setq auto-mode-alist `(("\\.spar$" . spar-mode)
			,@auto-mode-alist))

(defun spar-show ()
  "Show this subfile in an indirect buffer with right mode.
It is in fact the same buffer as the SPAR, so be careful not to
change the number of lines, or the SPAR will become inconsistent."
  (interactive)
  (let ((obuf (current-buffer))
	(fl font-lock-mode)
	a z buf)
    (save-excursion
      (end-of-line)
      (re-search-backward outline-regexp)
      (beginning-of-line 2)
      (setq a (point)
	    buf (match-string-no-properties 1))
      (re-search-forward "^###	" nil 'eof)
      (beginning-of-line)
      (setq z (point)))
    (switch-to-buffer (make-indirect-buffer (current-buffer) buf t))
    (narrow-to-region a z)
    (let ((buffer-file-name buf))
      (set-auto-mode))
    (and fl (not font-lock-mode)
	 (set-buffer obuf)
	 (font-lock-mode fl))))

(defun spar-level ()
  (let ((z (1- (match-end 1)))
	(n 1))
    (save-excursion
      (goto-char (match-beginning 1))
      (while (search-forward "/" z t)
	(setq n (1+ n))))
    n))

(define-derived-mode spar-mode outline-mode "Spar"
  "Major mode for editing Simple Perl ARchives.
Command \\[spar-show] allows editing one file section."
  (set (make-local-variable 'outline-regexp)
       "^###	.+	\\(.+\\)")
  (set (make-local-variable 'outline-level) 'spar-level))

(define-key spar-mode-map "\C-cs" 'spar-show)

=end Emacs

=head1 NAME

spar -- Simple Perl ARchive manager


=head1 SYNOPSIS

    spar command[ 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 Commands

=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.  This is the
default if the archive doesn't exist or is C<->, i.e. stdout.

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

Extract all files and directories contained in the archive.

=item -e, --emacs, --emacsmode

Output an Emacs mode you can paste into your F<~/.emacs> for editing SPARs.

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

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

=back


=head2 Options

=over

=item --exclude=I<FILE>

exclude file I<FILE>

=item -X, --exclude-from=I<FILE>

exclude files listed in I<FILE>

=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.  Newlines are extracted in what Perl considers the local format.

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.)

This has also proven useful for renaming files along with their contents, when
moving classes in a big hierarchy (refactoring).


=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

B<Simple Perl ARchive manager>
B< · >much smaller than I<tar> for small files
B< · >best for text files
B< · >helps to rename files along with contents
B< · >self unpacking
B< · >embeddable unpacker
B< · >Emacs mode

=pod SCRIPT CATEGORIES

UNIX/System_administration
VersionControl/CVS
Win32/Utilities