File Coverage

blib/lib/Crypt/Rhash.pm

Criterion	Covered	Total	%
statement	192	202	95.0
branch	19	40	47.5
condition	11	22	50.0
subroutine	59	60	98.3
pod	14	16	87.5
total	295	340	86.7

package Crypt::Rhash;

use 5.006001;
use strict;
use warnings;

require Exporter;
our @ISA = (qw(Exporter));

# possible tags for export
our %EXPORT_TAGS = (
	Functions => [qw(raw2hex raw2base32 raw2base64)],
	Constants => [qw(RHASH_CRC32 RHASH_CRC32C RHASH_MD4 RHASH_MD5
		RHASH_SHA1 RHASH_TIGER RHASH_TTH RHASH_BTIH RHASH_ED2K
		RHASH_AICH RHASH_WHIRLPOOL RHASH_RIPEMD160 RHASH_GOST94
		RHASH_GOST94_CRYPTOPRO RHASH_GOST12_256 RHASH_GOST12_512
		RHASH_SHA224 RHASH_SHA256 RHASH_SHA384 RHASH_SHA512
		RHASH_SHA3_224 RHASH_SHA3_256 RHASH_SHA3_384 RHASH_SHA3_512
		RHASH_BLAKE2S RHASH_BLAKE2B RHASH_EDONR256 RHASH_EDONR512
		RHASH_HAS160 RHASH_SNEFRU128 RHASH_SNEFRU256 RHASH_ALL)]
);

Exporter::export_tags( );
Exporter::export_ok_tags( qw(Functions Constants) );

our $VERSION = '1.05';

require XSLoader;
XSLoader::load('Crypt::Rhash', $VERSION);

##############################################################################
# identifiers of hash functions
use constant RHASH_CRC32 => 0x01;
use constant RHASH_MD4   => 0x02;
use constant RHASH_MD5   => 0x04;
use constant RHASH_SHA1  => 0x08;
use constant RHASH_TIGER => 0x10;
use constant RHASH_TTH   => 0x20;
use constant RHASH_BTIH  => 0x40;
use constant RHASH_ED2K  => 0x80;
use constant RHASH_AICH  => 0x100;
use constant RHASH_WHIRLPOOL => 0x200;
use constant RHASH_RIPEMD160 => 0x400;
use constant RHASH_GOST94    => 0x800;
use constant RHASH_GOST94_CRYPTOPRO => 0x1000;
use constant RHASH_HAS160    => 0x2000;
use constant RHASH_GOST12_256 => 0x4000;
use constant RHASH_GOST12_512 => 0x8000;
use constant RHASH_SHA224    => 0x10000;
use constant RHASH_SHA256    => 0x20000;
use constant RHASH_SHA384    => 0x40000;
use constant RHASH_SHA512    => 0x80000;
use constant RHASH_EDONR256  => 0x100000;
use constant RHASH_EDONR512  => 0x200000;
use constant RHASH_SHA3_224  => 0x0400000;
use constant RHASH_SHA3_256  => 0x0800000;
use constant RHASH_SHA3_384  => 0x1000000;
use constant RHASH_SHA3_512  => 0x2000000;
use constant RHASH_CRC32C    => 0x4000000;
use constant RHASH_SNEFRU128 => 0x8000000;
use constant RHASH_SNEFRU256 => 0x10000000;
use constant RHASH_BLAKE2S   => 0x20000000;
use constant RHASH_BLAKE2B   => 0x40000000;
use constant RHASH_ALL       => 0x7FFFFFFF;

##############################################################################
# Rhash class methods

# Rhash object constructor
sub new($$@)
{
	my ($class, @hash_ids) = @_;

	# validate @hash_ids to be an array of hash identifiers
	scalar(@_) > 0 or die "hash_id not specified\n";
	for my $id (@hash_ids) {
		if (ref($id) || !scalar($id) || (scalar($id) & RHASH_ALL) != $id) {
			die "bad hash_id = " . scalar($id) . " " . ref($id) . "\n";
		}
	}
	# handle legacy initialization by a single bitmask
	if (scalar(@hash_ids) == 1 && ($hash_ids[0] & ($hash_ids[0] - 1)) != 0) {
		# Split the bit mask into the array of single bits
		for (my $mask = shift(@hash_ids); $mask; $mask = $mask & ($mask - 1)) {
			push(@hash_ids, $mask & -$mask);
		}
	}
	my $context = rhash_init_multi_wrapper(\@hash_ids) or return undef;
	my $self = {
		context => $context,
	};
	return bless $self, $class;
}

# destructor
sub DESTROY($)
{
	my $self = shift;
	# the 'if' added as workaround for perl 'global destruction' bug
	# ($self->{context} can disappear on global destruction)
	rhash_free($self->{context}) if $self->{context};
}

sub update($$)
{
	my $self = shift;
	my $message = shift;
	rhash_update($self->{context}, $message);
	return $self;
}

sub update_fd($$;$$)
{
	my ($self, $fd, $start, $size) = @_;
	my $res = 0;
	my $num = 0;

	binmode($fd);
	if(defined($start)) {
		seek($fd, scalar($start), 0) or return undef;
	}

	my $data;
	if(defined($size)) {
		for(my $left = scalar($size); $left > 0; $left -= 8192) {
			($res = read($fd, $data,
				($left < 8192 ? $left : 8192))) || last;
			rhash_update($self->{context}, $data);
			$num += $res;
		}
	} else {
		while( ($res = read($fd, $data, 8192)) ) {
			rhash_update($self->{context}, $data);
			$num += $res;
		}
	}

	return (defined($res) ? $num : undef); # return undef on read error
}

sub update_file($$;$$)
{
	my ($self, $file, $start, $size) = @_;
	open(my $fd, "<", $file) or return undef;
	my $res = $self->update_fd($fd, $start, $size);
	close($fd);
	return $res;
}

sub final($)
{
	my $self = shift;
	rhash_final($self->{context});
	return $self;
}

sub reset($)
{
	my $self = shift;
	rhash_reset($self->{context});
	return $self;
}

sub hashed_length($)
{
	my $self = shift;
	return rhash_get_hashed_length($self->{context});
}

sub hash_id($)
{
	my $self = shift;
	return rhash_get_hash_id($self->{context});
}

##############################################################################
# Message digest formatting functions

# printing constants
use constant RHPR_DEFAULT   => 0x0;
use constant RHPR_RAW       => 0x1;
use constant RHPR_HEX       => 0x2;
use constant RHPR_BASE32    => 0x3;
use constant RHPR_BASE64    => 0x4;
use constant RHPR_UPPERCASE => 0x8;
use constant RHPR_REVERSE   => 0x10;

sub hash($;$$)
{
	my $self = shift;
	my $hash_id = scalar(shift) || 0;
	my $print_flags = scalar(shift) || RHPR_DEFAULT;
	return rhash_print_wrapper($self->{context}, $hash_id, $print_flags);
}

sub hash_base32($;$)
{
	hash($_[0], $_[1], RHPR_BASE32);
}

sub hash_base64($;$)
{
	hash($_[0], $_[1], RHPR_BASE64);
}

sub hash_hex($;$)
{
	hash($_[0], $_[1], RHPR_HEX);
}

sub hash_rhex($;$)
{
	hash($_[0], $_[1], RHPR_HEX | RHPR_REVERSE);
}

sub hash_raw($;$)
{
	hash($_[0], $_[1], RHPR_RAW);
}

sub magnet_link($;$@)
{
	my ($self, $filename, @hash_ids) = @_;
	my $hash_mask = 0;
	if (scalar(@hash_ids)) {
		for my $id (@hash_ids) {
			if (ref($id) || !scalar($id) || (scalar($id) & RHASH_ALL) != $id) {
				die "bad hash_id = " . scalar($id) . " " . ref($id) . "\n";
			}
			$hash_mask = $hash_mask | scalar($id);
		}
	} else {
		$hash_mask = undef;
	}
	return rhash_print_magnet_wrapper($self->{context}, $filename, $hash_mask);
}

our $AUTOLOAD;

# report error if a script called unexisting method/field
sub AUTOLOAD
{
	my ($self, $field, $type, $pkg) = ($_[0], $AUTOLOAD, undef, __PACKAGE__);
	$field =~ s/.*://;
	die "function $field does not exist\n" if $field =~ /^(rhash_|raw2)/;
	die "no arguments specified to $field()\n" if !@_;
	die "the $field() argument is undefined\n" if !defined $self;

	($type = ref($self)) && $type eq $pkg || die "the $field() argument is not a $pkg reference\n";
	my $text = (exists $self->{$field} ? "is not accessible" : "does not exist");
	die "the method $field() $text in the class $pkg\n";
}

# static functions

sub msg($$)
{
	my ($hash_id, $msg) = @_;
	my $raw = rhash_msg_wrapper($hash_id, $msg); # get a binary message digest
	return (is_base32($hash_id) ? raw2base32($raw) : raw2hex($raw));
}

1;
__END__