Authen-DecHpwd

 view release on metacpan or  search on metacpan

lib/Authen/DecHpwd.pm  view on Meta::CPAN

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;

lib/Authen/DecHpwd.pm  view on Meta::CPAN

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]);

lib/Authen/DecHpwd.pm  view on Meta::CPAN

			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);

lib/Authen/DecHpwd.pm  view on Meta::CPAN

	_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);

lib/Authen/DecHpwd.pm  view on Meta::CPAN

=item vms_username(USERNAME)

Checks whether the USERNAME string matches VMS username syntax, and
canonicalises it.  VMS username syntax is 1 to 31 characters from
case-insensitive alphanumerics, "B<_>", and "B<$>".  If the string has
correct username syntax then the username is returned in canonical form
(uppercase).  If the string is not a username then C<undef> is returned.

=cut

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

=item vms_password(PASSWORD)

Checks whether the PASSWORD string is an acceptable VMS password,
and canonicalises it.  VMS password syntax is 1 to 32 characters from
case-insensitive alphanumerics, "B<_>", and "B<$>".  If the string is
an acceptable password then the password is returned in canonical form
(uppercase).  If the string is not an acceptable password then C<undef>
is returned.

=cut

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

=back

=head1 SEE ALSO

L<VMS::User>

=head1 AUTHOR