#!/usr/bin/perl

=begin metadata

Name: par
Description: create a Perl archive of files
Author: Tim Gim Yee, tim.gim.yee@gmail.com
License: perl

=end metadata

=cut


#
# par - create a Perl archive of files
#

my $VERSION = '0.08';

use File::Find;
use File::Basename;
use Cwd;

eval 'use Stat::lsMode';
my $stat_lsmode = not $@;

use strict;
use vars qw/$size $mode $name/;

$|++;
binmode STDIN;
binmode STDOUT;

# Are we 'par' or 'shar'?
($0) = $0 =~ /(\w+)$/;

# Check for arguments.
@ARGV or die "usage: $0 [-s submitter] [-STBqvz] file [files...]\n";

# Get options.
my %opts;
while (@ARGV && $ARGV[0] =~ s/^-//) {
    local $_ = shift;
    while (/([sSTBVqvz])/g) {
        if ($1 eq 's') {
            $opts{'s'} = /\G(.*)/g && $1 ? $1 : shift;
        } else {
            $opts{$1}++;
        }
    }
}

# Print version.
if ($opts{'v'}) {
    print "$0 $VERSION\n";
    exit;
}

# Want shar output.
$0 = 'shar' if $opts{'z'};

# Read STDIN for filenames.
if ($opts{'S'}) {
    chomp(my @files = <STDIN>);
    push @ARGV, @files;
}

# Work quietly.
local $SIG{__WARN__} = sub {} if $opts{'q'};

# Header info.
my $date = localtime;
my $cwd  = cwd;
my $user = $opts{'s'} || do {
    require Sys::Hostname;
    (getlogin || getpwuid($<) || $ENV{USER} || $ENV{LOGNAME} || 'nobody')
    . '@'
    . Sys::Hostname::hostname();
};

# Header.
print $0 eq 'shar' ? <<INTRO_SHAR : <<INTRO_PAR;
#!/bin/sh
# This is a shell archive (produced by par $VERSION).
# To extract the files from this archive, save it to some FILE, remove
# everything before the '#!/bin/sh' line above, then type 'sh FILE'.
INTRO_SHAR
#!/usr/bin/perl
# This is a Perl archive (produced by par $VERSION).
# To extract the files from this archive, save it to some FILE, remove
# everything before the '#!/usr/bin/perl' line above, then type 'perl FILE'.
INTRO_PAR

# More header.
print <<INTRO;
#
# Made on $date by <$user>.
# Source directory was '$cwd'.
#
# Existing files will *not* be overwritten unless '-c' is specified.
#
# This $0 contains:
# length mode       name
# ------ ---------- ------------------------------------------
INTRO

# Format for index of files.
format INDEX =
@ @>>>>> @>>>>>>>>> @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'#', $size, $mode, $name
.

# Store file stats here.
my %index;

# Stat files and directories, and print out an index.
find sub {
    $name = $File::Find::name;
    my %stat;
    @stat{'mode', 'size', 'atime', 'mtime'} = (stat)[2,7,8,9];
    ($mode, $size) = @stat{'mode', 'size'};
    my $oct = (join '' => 0, ($mode&0700)>>6, ($mode&0070)>>3, ($mode&0007));
    $mode = $stat_lsmode ? format_mode($mode) : $oct;
    $stat{mode} = $oct;
    if ($0 eq 'shar') {
        for ('atime', 'mtime') {
            my ($sec,$min,$hour,$mday,$mon,$year) = localtime $stat{$_};
            $stat{$_} = sprintf '%02d%02d%02d%02d.%02d',
                $mon + 1, $mday, $hour, $min, $sec;
        }
    }
    $index{$name} = \%stat;
    local $~ = 'INDEX';
    write;
}, @ARGV;

print "#\n";

# List of template names and values.
my %par;

# Fill in template and print.
sub printc {
    my $mark = $0 eq 'shar' ? ':' : '|';
    local $_ = join "\n", shift(@_) =~ /^\s*\Q$mark\E(.*)/mog, '';
    s/%(\w+)%/$par{$1}/g;
    print;
}

# Break path into component directories:
#   print map ">$_\n", path 'i/want/a/moogle/stuffy'
#   >i
#   >i/want
#   >i/want/a
#   >i/want/a/moogle
sub path {
    my $path = shift;
    my @path;
    while (1) {
        my $was = $path;
        $path = dirname $path;  # File::Basename
        last if $path eq $was;
        unshift @path, $path;
    }
    shift @path;
    @path;
}

# Print code that will create a directory.
sub create_dir {
    $par{dir} = shift;
    printc <<'    DIR';
        |# ============= %dir% ==============
        |unless (-d '%dir%') {
        |  warn "x - creating directory %dir%\n";
        |  mkdir '%dir%', 0777 or die "Couldn't mkdir '%dir%': $!";
        |}
        :# ============= %name% ==============
        :if ! test -d '%dir%'; then
        :  echo "x - creating directory %dir%"
        :  mkdir '%dir%'
        :fi
    DIR
}

# Print code to create all directories in file paths.
my %saw;
for (@ARGV) {
    for (path $_) {
        create_dir $_ unless $saw{$_}++;
    }
}

# Print code to create each file.
find sub {
    my $name = $File::Find::name;

    # Create directory.
    if (-d) {
        create_dir $name unless $saw{$_}++;
        return;
    }

    # Set up template values.
    %par = %{$index{$name}};
    $par{name} = $name;
    my $bin = $opts{'T'} ? 0 :
              $opts{'B'} ? 1 :
              -B;
    $par{type}  = $bin ? 'binary' : 'text';
    $par{redir} = $bin ? '| uudecode' : "> $par{name}";

    warn "$0: Saving $name ($par{type})\n";

    # Code to start here-doc.
    printc <<'    FILE';
        |# ============= %name% ==============
        |if (-e '%name%' && $ARGV[0] ne '-c') {
        |  warn "x - skipping %name% (file already exists)\n";
        |} else  {
        |  warn "x - extracting %name% (%type%)\n";
        |  $_ = <<'PAR_EOF';
        :# ============= %name% ==============
        :if test -f '%name%' && test X"$1" != X"-c"; then
        :  echo 'x - skipping %name% (file already exists)'
        :else
        :  echo 'x - extracting %name% (%type%)'
        :  sed 's/^X//' << 'SHAR_EOF' %redir%
    FILE

    # Inline file as here-doc.
    open F, "< $_" or die "Couldn't open '$_': $!";
    binmode F;
    if ($bin) {
        local $_;
        my $block;
        print "begin $index{$name}{mode} $name\n" if $0 eq 'shar';
        print pack 'u', $block while read F, $block, 45;
        print "end\n" if $0 eq 'shar';
    } else {
        local $_;
        print "X$_" while <F>;
    }
    close F;

    # Code to extract file.
    printc <<'    FILE';
        |PAR_EOF
        |  open F, "> %name%" or die "Couldn't open '%name%': $!";
        |  binmode F;
    FILE
    printc $bin ? <<'    BINARY' : <<'    TEXT';
        |  $len = 0;
        |  for (split /^/gm) {
        |    my $line = unpack 'u', $_;
        |    $len += length $line;
        |    print F $line;
        |  }
    BINARY
        |  s/^X//gm;
        |  $len = length;
        |  print F $_;
    TEXT

    # Code to chmod and touch.
    printc <<'    FILE';
        |  close F;
        |  %size% == $len
        |    or warn "%name%: original size %size%, current size $len";
        |  utime %atime%, %mtime%, '%name%' or die "Couldn't touch '%name%': $!";
        |  chmod %mode%, '%name%' or die "Couldn't chmod '%name%': $!";
        |}
        :SHAR_EOF
        :  shar_size=`wc -c < '%name%'`
        :  if test %size% -ne $shar_size; then
        :    echo "%name%: original size %size%, current size $shar_size"
        :  fi
        :  touch -at %atime% '%name%'
        :  touch -mt %mtime% '%name%'
        :  chmod %mode% '%name%'
        :fi
    FILE
}, @ARGV;

# The end.
printc <<'END';
    |__END__
    :exit 0
END

__END__

=head1 NAME

par - create a Perl archive of files

=head1 SYNOPSIS

B<par> [-s submitter] [-STBqvz] file [files...]

=head1 DESCRIPTION

B<par> creates a Perl archive of the I<files> on the command line. The Perl
archive is a Perl script, and executing it will recreate the I<files>. If any of
the I<files> include a path, directories in that path will also be recreated. If
any of the I<files> is a directory, the contents of that directory will be
archived.

=head1 OPTIONS

B<par> automatically determines if files are text or binary unless B<-B> or
B<-T> is used.

=over

=item -B

All files are binary.  Encode files with B<uuencode>.  B<uudecode> will be
required to recover the files.

=item -S

Read standard input for files, one file per line, as though they were included
on the command line.  For example:

    find . -name 'chapter[1-9].txt' -print | par -S > story.par

=item -T

All files are text.  No encoding necessary.

=item -s submitter

Use I<submitter> for the email address included in the B<par> header.

=item -q

Shhh!

=item -v

Print version info and exit.

=item -z

Mimic B<shar>.  Create a shell archive instead of a Perl archive.

=back

=head1 NOTES

Renaming or linking B<par> to C<shar> will cause it to create shell scripts:

    ln par shar
    shar moogle.txt > moogle.shar

=head1 SEE ALSO

B<shar>, B<unpar>, B<uuencode>

=head1 AUTHOR

This implementation of I<par> was written by Tim Gim Yee,
I<tim.gim.yee@gmail.com>.

=head1 COPYRIGHT and LICENSE

This program is copyright (c) Tim Gim Yee 1999.

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

=cut

