#! /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{c} || $opt{d} ) {
    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};
    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!^\./!!;
	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;
} elsif( $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;"
}

__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 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 --exclude=I<FILE>

exclude file I<FILE>

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

exclude files listed in I<FILE>

=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


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


=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<·> a factor smaller than a I<tar> for small files
B<·> best for text files
B<·> help for renaming files along with contents
B<·> embeddable unpacker
B<·> Emacs mode
012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789

=pod SCRIPT CATEGORIES

UNIX/System_administration
VersionControl/CVS
Win32/Utilities