Authen::DecHpwd - DEC VMS password hashing

	use Authen::DecHpwd qw(
		UAI_C_AD_II UAI_C_PURDY UAI_C_PURDY_V UAI_C_PURDY_S
		lgi_hpwd
	);

	$hash = lgi_hpwd("JRANDOM", "PASSWORD", UAI_C_PURDY_S, 1234);

	use Authen::DecHpwd qw(vms_username vms_password);

	$username = vms_username($username);
	$password = vms_password($password);

package Authen::DecHpwd;

{ use 5.006; }
use warnings;
use strict;

use Digest::CRC 0.14 qw(crc32);

our $VERSION = "2.006";

use parent "Exporter";
our @EXPORT_OK = qw(
	UAI_C_AD_II UAI_C_PURDY UAI_C_PURDY_V UAI_C_PURDY_S
	lgi_hpwd
	vms_username vms_password
);

eval { local $SIG{__DIE__};
	require XSLoader;
	XSLoader::load(__PACKAGE__, $VERSION);
};

use constant UAI_C_AD_II => 0;
use constant UAI_C_PURDY => 1;
use constant UAI_C_PURDY_V => 2;
use constant UAI_C_PURDY_S => 3;

unless(defined &lgi_hpwd) { { local $SIG{__DIE__}; eval q{

use warnings;
use strict;

use Data::Integer 0.003 qw(
		natint_bits
		uint_shl uint_shr uint_rol
		uint_and uint_or
		uint_madd uint_cadd
);
use Scalar::String 0.000 qw(sclstr_is_downgraded sclstr_downgraded);

my $u32_mask = 0xffffffff;

sub _u32_shl($$) {
		if(natint_bits == 32) {
				return &uint_shl;
		} else {
				return uint_and(&uint_shl, $u32_mask);
		}
}

*_u32_shr = \&uint_shr;

*_u32_and = \&uint_and;

sub _u32_rol($$) {
		if(natint_bits == 32) {
				return &uint_rol;
		} else {
				return $_[0] if $_[1] == 0;
				return uint_and(uint_or(uint_shl($_[0], $_[1]),
										uint_shr($_[0], 32-$_[1])),
								$u32_mask);
		}
}

sub _u32_madd($$) { uint_and(&uint_madd, $u32_mask) }

sub _u32_cadd($$$) {
		if(natint_bits == 32) {
				return &uint_cadd;
		} else {
				my(undef, $val) = uint_cadd($_[0], $_[1], $_[2]);
				return (uint_and(uint_shr($val, 32), 1),
						uint_and($val, $u32_mask));
		}
}

my $u16_mask = 0xffff;

sub _u16_madd($$) { uint_and(&uint_madd, $u16_mask) }

my $u8_mask = 0xff;

sub _u8_madd($$) { uint_and(&uint_madd, $u8_mask) }

sub _addUnalignedWord($$) {
		$_[0] = pack("v", _u16_madd(unpack("v", $_[0]), $_[1]));
}

use constant _PURDY_USERNAME_LENGTH => 12;

use constant _A => 59;
use constant _DWORD_MAX => 0xffffffff;
use constant _P_D_LOW => _DWORD_MAX - _A + 1;
use constant _P_D_HIGH => _DWORD_MAX;

use constant _N0 => 0xfffffd;
use constant _N1 => 0xffffc1;
use constant _Na => 448;
use constant _Nb => 37449;

use constant _MASK => 7;

use constant _C1 => pack("VV", 0xffffffad, 0xffffffff);
use constant _C2 => pack("VV", 0xffffff4d, 0xffffffff);
use constant _C3 => pack("VV", 0xfffffeff, 0xffffffff);
use constant _C4 => pack("VV", 0xfffffebd, 0xffffffff);
use constant _C5 => pack("VV", 0xfffffe95, 0xffffffff);

sub _PQMOD_R0($) {
		my($low, $high) = unpack("VV", $_[0]);
		if($high == _P_D_HIGH && $low >= _P_D_LOW) {
				$_[0] = pack("VV", _u32_madd($low, _A), 0);
		}
}

sub _ROL1($) { $_[0] = pack("V", _u32_rol(unpack("V", $_[0]), 1)); }

sub _QROL1($) {
		_ROL1(substr($_[0], 0, 4));
		_ROL1(substr($_[0], 4, 4));
}

sub _EMULQ($$$) {
		my($a, $b, undef) = @_;
		my $hi = _u32_shr($a, 16) * _u32_shr($b, 16);
		my $lo = _u32_and($a, 0xffff) * _u32_and($b, 0xffff);
		my $carry;
		my $p = _u32_shr($a, 16) * _u32_and($b, 0xffff);
		($carry, $lo) = _u32_cadd($lo, _u32_shl($p, 16), 0);
		($carry, $hi) = _u32_cadd($hi, _u32_shr($p, 16), $carry);
		$p = _u32_and($a, 0xffff) * _u32_shr($b, 16);
		($carry, $lo) = _u32_cadd($lo, _u32_shl($p, 16), 0);
		($carry, $hi) = _u32_cadd($hi, _u32_shr($p, 16), $carry);
		$_[2] = pack("VV", $lo, $hi);
}

sub _PQADD_R0($$$) {
		my($u, $y, undef) = @_;
		my($ulo, $uhi) = unpack("VV", $u);
		my($ylo, $yhi) = unpack("VV", $y);
		my($carry, $rlo, $rhi);
		($carry, $rlo) = _u32_cadd($ulo, $ylo, 0);
		($carry, $rhi) = _u32_cadd($uhi, $yhi, $carry);
		while($carry) {
				($carry, $rlo) = _u32_cadd($rlo, _A, 0);
				($carry, $rhi) = _u32_cadd($rhi, 0, $carry);
		}
		$_[2] = pack("VV", $rlo, $rhi);
}

sub _COLLAPSE_R2($$$) {
		my($s, undef, $isPurdyS) = @_;
		for(my $p = length($s); $p != 0; $p--) {
				my $pp = $p & _MASK;
				substr($_[1], $pp, 1) = pack("C",
						_u8_madd(unpack("C", substr($_[1], $pp, 1)),
								unpack("C", substr($s, -$p, 1))));
				if($isPurdyS && $pp == _MASK) { _QROL1($_[1]); }
		}
}

sub _PQLSH_R0($$) {
		my($u, undef) = @_;
		my($ulo, $uhi) = unpack("VV", $u);
		my $stack = pack("VV", 0, 0);
		my $x = pack("VV", 0, 0);
		_EMULQ($uhi, _A, $stack);
		$x = pack("VV", 0, $ulo);
		_PQADD_R0($x, $stack, $_[1]);
}

sub _PQMUL_R2($$$) {
		my($u, $y, undef) = @_;
		my($ulo, $uhi) = unpack("VV", $u);
		my($ylo, $yhi) = unpack("VV", $y);
		my $stack = pack("VV", 0, 0);
		my $part1 = pack("VV", 0, 0);
		my $part2 = pack("VV", 0, 0);
		my $part3 = pack("VV", 0, 0);
		_EMULQ($uhi, $yhi, $stack);
		_PQLSH_R0($stack, $part1);
		_EMULQ($uhi, $ylo, $stack);
		_EMULQ($ulo, $yhi, $part2);
		_PQADD_R0($stack, $part2, $part3);
		_PQADD_R0($part1, $part3, $stack);
		_PQLSH_R0($stack, $part1);
		_EMULQ($ulo, $ylo, $stack);
		_PQADD_R0($part1, $stack, $_[2]);
}

sub _PQEXP_R3($$$) {
		my($u, $n, undef) = @_;
		my $y = pack("VV", 0, 0);
		my $z = pack("VV", 0, 0);
		my $z1 = pack("VV", 0, 0);
		my $yok = 0;
		$z = $u;
		while($n != 0) {
				if($n & 1) {
						if($yok) {
								_PQMUL_R2($y, $z, $_[2]);
						} else {
								$_[2] = $z;
								$yok = 1;
						}
						if($n == 1) { return; }
						$y = $_[2];
				}
				$n >>= 1;
				$z1 = $z;
				_PQMUL_R2($z1, $z1, $z);
		}
		$_[2] = pack("VV", 1, 0);
}

sub _Purdy($) {
		my $t1 = pack("VV", 0, 0);
		my $t2 = pack("VV", 0, 0);
		my $t3 = pack("VV", 0, 0);

		_PQEXP_R3($_[0], _Na, $t1);
		_PQEXP_R3($t1, _Nb, $t2);
		_PQEXP_R3($_[0], (_N0 - _N1), $t1);
		_PQADD_R0($t1, _C1, $t3);
		_PQMUL_R2($t2, $t3, $t1);

		_PQMUL_R2($_[0], _C2, $t2);
		_PQADD_R0($t2, _C3, $t3);
		_PQMUL_R2($_[0], $t3, $t2);
		_PQADD_R0($t2, _C4, $t3);

		_PQADD_R0($t1, $t3, $t2);
		_PQMUL_R2($_[0], $t2, $t1);
		_PQADD_R0($t1, _C5, $_[0]);

		_PQMOD_R0($_[0]);
}

sub lgi_hpwd($$$$) {
		my($username, $password, $alg, $salt) = @_;
		if($alg > UAI_C_PURDY_S) {
				die "algorithm value $alg is not recognised";
		}
		$salt = uint_and($salt, 0xffff);
		# This string downgrading is necessary for correct behaviour on
		# perl 5.6 and 5.8.  It is not necessary on 5.10, but will still
		# slightly improve performance.
		$username = sclstr_downgraded($username, 1);
		$password = sclstr_downgraded($password, 1);
		die "input must contain only octets"
				unless sclstr_is_downgraded($username) &&
						sclstr_is_downgraded($password);
		if($alg == UAI_C_AD_II) {
				return pack("VV", Digest::CRC::crc32($password)^0xffffffff, 0);
		}
		my $isPurdyS = $alg == UAI_C_PURDY_S;
		my $output = pack("VV", 0, 0);
		if($alg == UAI_C_PURDY) {
				$username .= " " x 12;
				$username = substr($username, 0, _PURDY_USERNAME_LENGTH);
		} elsif($alg == UAI_C_PURDY_S) {
				_addUnalignedWord(substr($output, 0, 2), length($password));
		}
		_COLLAPSE_R2($password, $output, $isPurdyS);
		_addUnalignedWord(substr($output, 3, 2), $salt);
		_COLLAPSE_R2($username, $output, $isPurdyS);
		_Purdy($output);
		return $output;
}

1;

}; } die $@ if $@ ne "" }

sub vms_username($) {
	return $_[0] =~ /\A[_\$0-9A-Za-z]{1,31}\z/ ? uc("$_[0]") : undef;
}

sub vms_password($) {
	return $_[0] =~ /\A[_\$0-9A-Za-z]{1,32}\z/ ? uc("$_[0]") : undef;
}

1;