#! /usr/bin/env perl

our $VERSION = 0.10;

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',
    'm|createmakepptest',
    'a|append',
    '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{
    (local $0 = $0) =~ s!.*/!!;
    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;
	} elsif( /^###\t(?!SPAR)/ ) {
	    ($kind, $mode, $atime, $mtime, $name) = (split /\t/, $_, 6)[1..5];
	    if( !$name ) {
	    } elsif( $kind eq 'D' ) {
		$name =~ s!/+$!!;
		-d $name or mkdir $name, 0700 or warn "$0: can't mkdir `$name': $!\n";
		$SPAR::mode{$name} = [oct( $mode ), $atime, $mtime];
	    } elsif( $kind ne 'L' ) {
		open F, ">$name" or warn "$0: can't open >`$name': $!\n";
		$lines = abs $kind;
		$nl = ($kind < 0) ? '' : "\n";
	    }
	} elsif( defined $mode ) {
	    warn "$0: $archive:$.: trailing garbage ignored\n";
	}			# else before beginning of spar
    } continue {
	if( !$lines-- ) {
	    close F;
	    chmod oct( $mode ), $name and
		utime $atime, $mtime, $name or
		warn "$0: $archive:$name: Failed to set file attributes: $!\n";
	}
    }

    for( keys %SPAR::mode ) {
	chmod shift @{$SPAR::mode{$_}}, $_ and
	    utime @{$SPAR::mode{$_}}, $_ or
	    warn "$0: $archive:$_: Failed to set directory attributes: $!\n";
    }
    %SPAR::mode = ();
};

my $archive = shift;
if( $opt{x} || $opt{t} ) {
    open DATA, $archive or die "$0: can't open `$archive': $!\n";
    eval $extractor, exit if $opt{x};
    while( <DATA> ) {
	next unless /^###\t(?!SPAR)/;
	chop;
	my( $kind, $mode, $atime, $mtime, $name ) = (split /\t/, $_, 6)[1..5];
	if( $kind eq 'D' ) {
	    print "directory 0$mode, ", scalar localtime $mtime, ", `$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, ", scalar localtime $mtime, ", `$name' ($kind line", ($kind == 1) ? '' : 's', ")\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 function
# assumes DATA to be opened to the spar
sub un_spar() {$extractor}\n";
} elsif( $opt{c} || $opt{d} || $opt{m} || $opt{a} || $archive eq '-' || !-f $archive ) {
    if( $opt{X} ) {
	open F, $opt{X};
	while( <F> ) {
	    chomp;
	    push @exclude, $_;
	}
    }
    for( @exclude ) {
	$exclude{$_} = 1 for glob;
    }
    if( $opt{a} && -s $archive ) {
	open SPAR, ">>$archive" or die "$0: can't open >>`$archive': $!\n";
    } else {
	open SPAR, ">$archive" or die "$0: can't open >`$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 => $opt{m} ? \&makepptestsort : sub { sort @_ } }, @ARGV ? @ARGV : '.');
    sub makepptestsort {
	my %files; @files{@_} = ();
	my $answers = exists $files{answers} and
	    delete $files{answers};
	my @files;
	for my $re (qr/(?:is_relevant|makepp_test_script)(?:\.pl)?/, qr/(?:Root)?[Mm]akep*file/, qr/.+\.mk/, qr/.+\.p[lm]/) {
	    for( sort keys %files ) {
		next if !/^$re$/;
		push @files, $_;
		delete $files{$_};
	    }
	}
	(@files, sort( keys %files ), $answers ? 'answers' : ());
    }
    sub process {
	(my $name = $File::Find::name) =~ s!^\./!!;
	return if $name eq '.';
	$File::Find::prune = 1, return if $exclude{$name} or $exclude{$_};
	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 "$0: can't open <$_: $!\n";
	my @file = <F>;
	close F;
	my $length = @file;
	if( $length and $file[-1] !~ /\n$/ ) {
	    $file[-1] .= "\n";
	    $length = -$length;
	}
	print SPAR join '', "###	$length	$mode	$atime	$mtime	$name\n", @file;
    }
    close SPAR;
} else {
    die "$0: no command given\n";
}

__END__

=begin Emacs

(setq auto-mode-alist `(("\\.spar$\\|/makepp.+\\.test$" . 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
      (outline-back-to-heading)
      (beginning-of-line 2)
      (setq buf (match-string-no-properties 1)
	    a (point))
      (outline-next-heading)
      (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-fix ()
  "Fix the number of lines declared in the heading of this subfile.
If this subfile is within a nested SPAR, the outer heading will
not be fixed."
  (interactive)
  (save-match-data
    (outline-back-to-heading)
    (if (looking-at "###	-?\\([0-9]+\\)	[0-9]+	[0-9]+	\\([0-9]+\\)")
	(let ((a (point))
	      n)
	  (save-match-data (outline-next-heading))
	  (setq n (prin1-to-string (1- (count-lines a (point)))))
	  (replace-match (format "%.0f" (float-time)) nil nil nil 2)
	  (unless (string= n (match-string-no-properties 1))
	    (replace-match n nil nil nil 1)))
      (error "Not on a normal file"))))

(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 subfile section.
Command \\[spar-fix] fixes the lenth of one subfile section.

Note that SPARs can contain other SPARs.  But this mode does not
recognize that.  Outline levels are the same for nested SPARs as
for outer ones, so you cannot normally hide a subtree containing
a nested SPAR."
  (set (make-local-variable 'outline-regexp)
       "^###	.+	\\(.+\\)")
  (set (make-local-variable 'outline-level) 'spar-level)
  (setq imenu-generic-expression
	      '(("links" "^###	[LS]	.+	\\(.+\\)" 1)
		("directories" "^###	D	.+	\\(.+\\)" 1)
		(nil "^###	.+	\\(.+\\)" 1))))

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

=end Emacs


=head1 NAME

spar -- Simple Perl ARchive manager


=head1 SYNOPSIS

    spar command[ option ...] archive[ file ...]
    spar utility

Creates or extracts a poor man's archive.  Especially when containing lots of
small files a I<spar> can be by a factor smaller than a tar.  And it can be
conveniently edited, especially in Emacs.

=head2 Commands

=over

=item -a, --append

This can add further files to an existing I<spar>.  If that is empty or
inexistant, this is the same as C<--createdata>.

=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 C<--create>, but the I<spar> contains only the data.  It will require
either C<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 -t, --table, --list

Show a table of contents.

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

Extract all files and directories contained in the archive.

=back


=head2 Options

Currently these options are only applicable to the C<--append>, C<--create>
and C<--createdata> commands.

=over

=item -E, --exclude=I<FILE>

Exclude file I<FILE>.  I<FILE> may be a full or relative path, or a simple
filename to exclude in every directory it is found.  I<FILE> may contain
Perl's wildcards C<?>, C<*> and C<{,}>.  In that case it stands for zero or
more actual files.  You should protect these wildcards from the shell, by
quoting them.

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

Exclude files listed in I<FILE>.  Each line is as in the C<--exclude> option,
except you must not protect wildcards.

=back


=head2 Utilities

=over

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

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

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

Output code you can paste into your script to extract a I<spar>.  This can
also be used for getting any files your script needs, right from the
C<__DATA__> section.

=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.  Newlines are extracted
in what Perl considers the local format.  Due to this, I<spar>s with binary
files are not portable to systems with different newline conventions.

Unlike C<tar> it does not strip a leading C</> from filenames.  If you want
to do that, you must call C<spar> in the root directory and give it relative
paths.

Since everything becomes one text, this can be used for renaming files along
with their content (refactoring).  Such a need may arise in programming,
where directory and file names will often reflect the packages or classes they
contain.  But from an operating system point of view, you modify these
aspects in very different ways (e.g. C<mv> and C<emacs>).

Unlike one of the two C<par> utilities available on the internet, the content
here is completely separated from the extraction-code in Perl.  (The other
C<par> is only a perl frontend to C<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> F<url>

This is the magic number on the first line of data-only spars.  The F<url> is
from where you can L<download|/DOWNLOAD> the C<spar> program.  This line is only
informative and actually gets ignored.

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

This creates the directory F<name>.  F<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>F<name>

This marks the next I<lines> lines as the content of file F<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 I<spar>) without confusing C<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>F<name>

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

These create the link (H) or symlink (S) F<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 DOWNLOAD

You can get the latest version of spar from L<http://www.cpan.org/scripts/>.
Because makepp was the first to use this, it is hosted on CVS at
L<http://makepp.cvs.sourceforge.net/makepp/makepp/t/> and the
subdirectory F<additional_tests/> contains a test-suite runnable by
C<run_tests.pl>, also from there.

=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 renaming files along with contents
B< · >self unpacking
B< · >embeddable unpacker
B< · >Emacs mode

=pod SCRIPT CATEGORIES

UNIX/System_administration
VersionControl/CVS
Win32/Utilities