#!/usr/bin/perl -w
#
# par - create a Perl archive of files
#
# mail tgy@chocobo.org < bug_reports
#
# Copyright (c) 1999 Moogle Stuffy Software. All rights reserved.
# You may play with this software in accordance with the Perl Artistic License.
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
Tim Gim Yee | tgy@chocobo.org | I want a moogle stuffy!
=head1 COPYRIGHT
Copyright (c) 1999 Moogle Stuffy Software. All rights reserved.
You may play with this software in accordance with the Perl Artistic License.
=cut