libdigest-whirlpool-perl 1.09-1.1 / usr / bin / whirlpoolsum

#!/usr/bin/env perl
use v5.8;
use strict;
use warnings;

use Digest ();
use Pod::Usage ();
use Getopt::Long ();

my $name = 'whirlpoolsum';
my $VERSION = '1.00';

=head1 NAME

whirlpoolsum - Print or check WHIRLPOOL checksums

=head1 DESCRIPTION

Print or check WHIRLPOOL (512-bit) checksums. With no FILE, or when
FILE is -, read standard input.

=head1 SYNOPSIS

    whirlpoolsum [OPTION] [FILE]...

=head1 OPTIONS

=over

=item -b, --binary

read files in binary mode

=item -c, --check

read WHIRLPOOL sums from FILEs and check them

=item -t, --text

read files in text mode (default)

=item -s, --status

don't output anything, status code shows success

=item -h, --help

Print a usage message listing all available options

=item -v, --version

Print the version number, then exit successfully.

=back

=head1 AUTHOR

E<AElig>var ArnfjE<ouml>rE<eth> Bjarmason <avar@cpan.org>

=head1 LICENSE

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

#
# Get command line options
#

Getopt::Long::Parser->new(
	config => [ qw< bundling no_ignore_case no_require_order > ],
)->getoptions(
	'h|help' => \my $help,
	'v|version' => \my $version,

    'b|binary' => \my $binary,
    't|text' => \my $text,

    'c|check' => \my $check,
    'w|warn' => \my $warn,
    's|status' => \my $status,
) or help();

#
# Deal with --help, --version and incorrect usage
#

help( verbose => 1, exitval => 0 )
    if $help;
help( verbose => 0, exitval => 1 )
    if $binary and $text;

# Display version if requested
version( exitval => 0 )
    if $version;

#
# Set up various stuff
#

# Determine mode to read in
my $modesym = $binary ? '*' : ' ';

# read from stdin if no files are given
@ARGV = "-"
    unless @ARGV;

# rx: A line in a sum file
my $sumfmt = qr/
                      ^
                      # WHIRLPOOL sum
                      ([0-9a-f]{128})
                      # sp
                      [ ]
                      # What mode it was checked in
                      ([* ])
                      # Filename
                      (.*)
                      $
/x;

#
# Main loop
#

unless ( $check ) {
    my $err = 0;
    for my $file (@ARGV) {
        if (my $digest = sumfile($file)) {
            printf qq<%s %s%s\n>, $digest, $modesym, $file;
        } else {
            $err ||= 1;
        }
    }
    exit $err;
} else {
    my $err = 0;
    my ($num_files, $num_checksums) = (0, 0);

    # some of this is ripped from shasum(1)
    for my $sumfile (@ARGV) {
        my ($read_errs, $match_errs);
        my ($fh, $rsp);

        unless ( open my $fh, '<', $sumfile ) {
            die sprintf qq<%s: %s: %s\n>, $name, $sumfile, $!;
        } else {
            while (my $line = <$fh>) {
                # Just ignore invalid lines
                next unless $line =~ /$sumfmt/;

                my ($sum, $modesym, $file) = ($1, $2, $3);
                ($binary, $text) = map { $_ eq $modesym } ('*', ' ');

                $rsp = "$file: "; $num_files++;
                unless (my $digest = sumfile( $file )) {
                    $rsp .= "FAILED open or read\n";
                    $err ||= 1; $read_errs++;
                } else {
                    $num_checksums++;
                    if (lc $sum eq $digest) {
                        $rsp .= "OK\n";
                    } else {
                        $rsp .= "FAILED\n"; $err = 1; $match_errs++;
                    }
                }
                print $rsp
                    unless $status;
            }
            close $fh;
        }
        unless ($status) {
            warn sprintf qq<%s: WARNING: %d of %d listed files could not be read\n>,
                $name, $read_errs, $num_files
                if $read_errs;
            warn sprintf qq<%s: WARNING: %d of %d computed checksums did NOT match\n>,
                $name, $match_errs, $num_checksums
                if $match_errs;
        }

    }
	exit $err;
}

sub sumfile
{
    my ( $file ) = @_;

    my $digest;
    if ( $file eq '-' ) {
        $digest = Digest->new( 'Whirlpool' )->addfile( *STDIN );
    } else {
        eval {
            open my $fh, '<', $file;
            binmode $fh if $binary;
            $digest = Digest->new( 'Whirlpool' )->addfile( $fh );
        };
        if ($@) {
            warn sprintf qq<whirlpoolsum: %s: %s\n>, $file, $!;
            return;
        }
    }

    $digest->hexdigest;
}

sub help
{
    my %arg = @_;

    Pod::Usage::pod2usage(
        -verbose => $arg{ verbose },
        -exitval => $arg{ exitval } || 0,
    );
}

sub version
{
    my %arg = @_;
    # Spit out the same crap GNU utilities do, for the lack of something better..
    printf qq<whirlpoolsum %s\nCopyright (C) Ævar Arnfjörð Bjarmason\n>, $VERSION;
    print "This program is free software; you can redistribute it and/or\n";
    print "modify it under the same terms as Perl itself.\n";
    print "\n";
    print "Written by Ævar Arnfjörð Bjarmason <avar\@cpan.org>\n";
    exit $arg{ exitval } || 0;
}