Improve and restructure t/op/pat.t and split out some unicode related tests into...

[p5sagit/p5-mst-13.2.git] / uupacktool.pl

#!perl

use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use File::Spec;

BEGIN {
    if ($^O eq 'VMS') {
        require VMS::Filespec;
        import VMS::Filespec;
    }
}

Getopt::Long::Configure('no_ignore_case');

our $LastUpdate = -M $0;

sub handle_file {
    my $opts    = shift;
    my $file    = shift or die "Need file\n". usage();
    my $outfile = shift || '';
    $file = vms_check_name($file) if $^O eq 'VMS';
    my $mode    = (stat($file))[2] & 07777;

    open my $fh, "<", $file
        or do { warn "Could not open input file $file: $!"; exit 0 };
    my $str = do { local $/; <$fh> };

    ### unpack?
    my $outstr;
    if( $opts->{u} ) {
        if( !$outfile ) {
            $outfile = $file;
            $outfile =~ s/\.packed\z//;
        }
        my ($head, $body) = split /__UU__\n/, $str;
        die "Can't unpack malformed data in '$file'\n"
            if !$head;
        $outstr = unpack 'u', $body;

    } else {
        $outfile ||= $file . '.packed';

        my $me = basename($0);

        $outstr = <<"EOFBLURB" . pack 'u', $str;
#########################################################################
This is a binary file that was packed with the 'uupacktool.pl' which
is included in the Perl distribution.

To unpack this file use the following command:

     $me -u $outfile $file

To recreate it use the following command:

     $me -p $file $outfile

Created at @{[scalar localtime]}
#########################################################################
__UU__
EOFBLURB
    }

    ### output the file
    if( $opts->{'s'} ) {
        print STDOUT $outstr;
    } else {
        $outfile = VMS::Filespec::vmsify($outfile) if $^O eq 'VMS';
        print "Writing $file into $outfile\n" if $opts->{'v'};
        open my $outfh, ">", $outfile
            or do { warn "Could not open $outfile for writing: $!"; exit 0 };
        binmode $outfh;
        ### $outstr might be empty, if the file was empty
        print $outfh $outstr if $outstr;
        close $outfh;

        chmod $mode, $outfile;
    }

    ### delete source file?
    if( $opts->{'D'} and $file ne $outfile ) {
        1 while unlink $file;
    }
}

sub bulk_process {
    my $opts = shift;
    my $Manifest = $opts->{'m'};

    open my $fh, "<", $Manifest or die "Could not open '$Manifest':$!";

    print "Reading $Manifest\n"
            if $opts->{'v'};

    my $count = 0;
    my $lines = 0;
    while( my $line = <$fh> ) {
        chomp $line;
        my ($file) = split /\s+/, $line;

        $lines++;

        next unless $file =~ /\.packed/;

        $count++;

        my $out = $file;
        $out =~ s/\.packed\z//;
        $out = vms_check_name($out) if $^O eq 'VMS';

        ### unpack
        if( !$opts->{'c'} ) {
            ( $out, $file ) = ( $file, $out ) if $opts->{'p'};
            if (-e $out) {
                my $changed = -M _;
                if ($changed < $LastUpdate and $changed < -M $file) {
                    print "Skipping '$file' as '$out' is up-to-date.\n"
                        if $opts->{'v'};
                    next;
                }
            }
            handle_file($opts, $file, $out);
            print "Converted '$file' to '$out'\n"
                if $opts->{'v'};

        ### clean up
        } else {

            ### file exists?
            unless( -e $out ) {
                print "File '$file' was not unpacked into '$out'. Can not remove.\n";

            ### remove it
            } else {
                print "Removing '$out'\n";
                1 while unlink $out;
            }
        }
    }
    print "Found $count files to process out of $lines in '$Manifest'\n"
            if $opts->{'v'};
}

sub usage {
    return qq[
Usage: $^X $0 [-d dir] [-v] [-c] [-D] -p|-u [orig [packed|-s] | -m [manifest]]

    Handle binary files in source tree. Can be used to pack or
    unpack files individiually or as specified by a manifest file.

Options:
    -u  Unpack files (defaults to -u unless -p is specified)
    -p  Pack files
    -c  Clean up all unpacked files. Implies -m

    -D  Delete source file after encoding/decoding

    -s  Output to STDOUT rather than OUTPUT_FILE
    -m  Use manifest file, if none is explicitly provided defaults to 'MANIFEST'

    -d  Change directory to dir before processing

    -v  Run verbosely
    -h  Display this help message
];
}

sub vms_check_name {

# Packed files tend to have multiple dots, which the CRTL may or may not handle
# properly, so convert to native format.  And depending on how the archive was
# unpacked, foo.bar.baz may be foo_bar.baz or foo.bar_baz.  N.B. This checks for
# existence, so is not suitable as-is to generate ODS-2-safe names in preparation
# for file creation.

    my $file = shift;

    $file = VMS::Filespec::vmsify($file);
    return $file if -e $file;

    my ($vol,$dirs,$base) = File::Spec->splitpath($file);
    my $tmp = $base;
    1 while $tmp =~ s/([^\.]+)\.(.+\..+)/$1_$2/;
    my $try = File::Spec->catpath($vol, $dirs, $tmp);
    return $try if -e $try;

    $tmp = $base;
    1 while $tmp =~ s/(.+\..+)\.([^\.]+)/$1_$2/;
    $try = File::Spec->catpath($vol, $dirs, $tmp);
    return $try if -e $try;

    return $file;
}

my $opts = {};
GetOptions($opts,'u','p','c', 'D', 'm:s','s','d=s','v','h');

die "Can't pack and unpack at the same time!\n", usage()
    if $opts->{'u'} && $opts->{'p'};
die usage() if $opts->{'h'};

if ( $opts->{'d'} ) {
    chdir $opts->{'d'}
        or die "Failed to chdir to '$opts->{'d'}':$!";
}
$opts->{'u'} = 1 if !$opts->{'p'};
binmode STDOUT if $opts->{'s'};
if ( exists $opts->{'m'} or exists $opts->{'c'} ) {
    $opts->{'m'} ||= "MANIFEST";
    bulk_process($opts);
    exit(0);
} else {
    if (@ARGV) {
        handle_file($opts, @ARGV);
    } else {
        die "No file to process specified!\n", usage();
    }
    exit(0);
}


die usage();