1package SHA512_qnx;
2
3# this code was taken and stripped down from Digest::SHA::PurePerl
4# in this code, ONLY SHA512_qnx() is defined. That function is the
5# 'same' as Digest::SHA::PurePerl::SHA512() except the code here
6# has the same 'bug' as we have found in QNX's passwd SHA512 function.
7
8use strict;
9use warnings;
10use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
11use integer;
12use Carp qw(croak);
13
14$VERSION = '5.95';
15
16require Exporter;
17@ISA = qw(Exporter);
18@EXPORT_OK = ();
19
20my $MAX32 = 0xffffffff;
21
22no warnings qw(portable);
23
24my @K512 = (
25	0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f, 0xe9b5dba58189dbbc, 0x3956c25bf348b538, 0x59f111f1b605d019, 0x923f82a4af194f9b, 0xab1c5ed5da6d8118,
26	0xd807aa98a3030242, 0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2, 0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235, 0xc19bf174cf692694,
27	0xe49b69c19ef14ad2, 0xefbe4786384f25e3, 0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, 0x2de92c6f592b0275, 0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
28	0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f, 0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725, 0x06ca6351e003826f, 0x142929670a0e6e70,
29	0x27b70a8546d22ffc, 0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df, 0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6, 0x92722c851482353b,
30	0xa2bfe8a14cf10364, 0xa81a664bbc423001, 0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218, 0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
31	0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99, 0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb, 0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3,
32	0x748f82ee5defb2fc, 0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec, 0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915, 0xc67178f2e372532b,
33	0xca273eceea26619c, 0xd186b8c721c0c207, 0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba, 0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
34	0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc, 0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a, 0x5fcb6fab3ad6faec, 0x6c44198c4a475817);
35
36my @H0512 = (
37	0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b, 0xa54ff53a5f1d36f1, 0x510e527fade682d1, 0x9b05688c2b3e6c1f, 0x1f83d9abfb41bd6b, 0x5be0cd19137e2179);
38
39use warnings;
40
41sub _c_SL64    { my($x, $n) = @_; "($x << $n)" }
42sub _c_SR64    { my($x, $n) = @_; my $mask = (1 << (64 - $n)) - 1; "(($x >> $n) & $mask)"; }
43sub _c_ROTRQ   { my($x, $n) = @_; "(" . _c_SR64($x, $n) . "|" . _c_SL64($x, 64 - $n) . ")"; }
44sub _c_SIGMAQ0 { my($x) = @_;     "(" . _c_ROTRQ($x,28) . "^" . _c_ROTRQ($x, 34) . "^" . _c_ROTRQ($x, 39) . ")"; }
45sub _c_SIGMAQ1 { my($x) = @_;     "(" . _c_ROTRQ($x,14) . "^" . _c_ROTRQ($x, 18) . "^" . _c_ROTRQ($x, 41) . ")"; }
46sub _c_sigmaQ0 { my($x) = @_;     "(" . _c_ROTRQ($x, 1) . "^" . _c_ROTRQ($x, 8)  . "^" . _c_SR64($x, 7) . ")";   }
47sub _c_sigmaQ1 { my($x) = @_;     "(" . _c_ROTRQ($x,19) . "^" . _c_ROTRQ($x, 61) . "^" . _c_SR64($x, 6) . ")";   }
48
49my $sha512_code = q/
50sub _sha512 {
51	my($self, $block) = @_;
52	my(@N, @W, $a, $b, $c, $d, $e, $f, $g, $h, $T1, $T2);
53
54	@N = unpack("N32", $block);
55	($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
56	for ( 0 .. 15) { $W[$_] = (($N[2*$_] << 16) << 16) | $N[2*$_+1] }
57	for (16 .. 79) { $W[$_] = / .
58		_c_sigmaQ1(q/$W[$_- 2]/) . q/ + $W[$_- 7] + / .
59		_c_sigmaQ0(q/$W[$_-15]/) . q/ + $W[$_-16] }
60	for ( 0 .. 79) {
61		$T1 = $h + / . _c_SIGMAQ1(q/$e/) .
62			q/ + (($g) ^ (($e) & (($f) ^ ($g)))) +
63				$K512[$_] + $W[$_];
64		$T2 = / . _c_SIGMAQ0(q/$a/) .
65			q/ + ((($a) & ($b)) | (($c) & (($a) | ($b))));
66		$h = $g; $g = $f; $f = $e; $e = $d + $T1;
67		$d = $c; $c = $b; $b = $a; $a = $T1 + $T2;
68	}
69	$self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c; $self->{H}->[3] += $d;
70	$self->{H}->[4] += $e; $self->{H}->[5] += $f; $self->{H}->[6] += $g; $self->{H}->[7] += $h;
71}
72/;
73
74eval($sha512_code);
75my $sha512 = \&_sha512;
76
77sub _SETBIT {
78	my($self, $pos) = @_;
79	my @c = unpack("C*", $self->{block});
80	$c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
81	$c[$pos >> 3] |= (0x01 << (7 - $pos % 8));
82	$self->{block} = pack("C*", @c);
83}
84
85sub _CLRBIT {
86	my($self, $pos) = @_;
87	my @c = unpack("C*", $self->{block});
88	$c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
89	$c[$pos >> 3] &= ~(0x01 << (7 - $pos % 8));
90	$self->{block} = pack("C*", @c);
91}
92
93sub _BYTECNT {
94	my($bitcnt) = @_;
95	$bitcnt > 0 ? 1 + (($bitcnt - 1) >> 3) : 0;
96}
97
98sub _digcpy {
99	my($self) = @_;
100	my @dig;
101	for (@{$self->{H}}) {
102		push(@dig, (($_>>16)>>16) & $MAX32) if $self->{alg} >= 384;
103		push(@dig, $_ & $MAX32);
104	}
105	$self->{digest} = pack("N" . ($self->{digestlen}>>2), @dig);
106}
107
108sub _sharewind {
109	my($self) = @_;
110	my $alg = $self->{alg};
111	$self->{block} = "";
112	$self->{blockcnt} = 0;
113	$self->{blocksize} = 1024;
114	for (qw(lenll lenlh lenhl lenhh)) { $self->{$_} = 0 }
115	$self->{digestlen} = 64;
116	$self->{sha} = \&_sha512;
117	$self->{H} = [@H0512];
118	push(@{$self->{H}}, 0) while scalar(@{$self->{H}}) < 8;
119	$self;
120}
121
122sub _shaopen {
123	my($alg) = @_;
124	my($self);
125	$self->{alg} = $alg;
126	_sharewind($self);
127}
128
129sub _shadirect {
130	my($bitstr, $bitcnt, $self) = @_;
131	my $savecnt = $bitcnt;
132	my $offset = 0;
133	my $blockbytes = $self->{blocksize} >> 3;
134	while ($bitcnt >= $self->{blocksize}) {
135		&{$self->{sha}}($self, substr($bitstr, $offset, $blockbytes));
136		$self->{priorblock} = substr($bitstr, $offset, $blockbytes);
137		$offset += $blockbytes;
138		$bitcnt -= $self->{blocksize};
139	}
140	if ($bitcnt > 0) {
141		$self->{block} = substr($bitstr, $offset, _BYTECNT($bitcnt));
142		$self->{blockcnt} = $bitcnt;
143	}
144	$savecnt;
145}
146sub _shawrite {
147	my($bitstr, $bitcnt, $self) = @_;
148	return(0) unless $bitcnt > 0;
149	no integer;
150	my $TWO32 = 4294967296;
151	if (($self->{lenll} += $bitcnt) >= $TWO32) {
152		$self->{lenll} -= $TWO32;
153		if (++$self->{lenlh} >= $TWO32) {
154			$self->{lenlh} -= $TWO32;
155			if (++$self->{lenhl} >= $TWO32) {
156				$self->{lenhl} -= $TWO32;
157				if (++$self->{lenhh} >= $TWO32) {
158					$self->{lenhh} -= $TWO32;
159				}
160			}
161		}
162	}
163	use integer;
164	my $blockcnt = $self->{blockcnt};
165	return _shadirect($bitstr, $bitcnt, $self);
166}
167
168sub _shaWrite {
169	my($bytestr_r, $bytecnt, $self) = @_;
170	my $MWS = 33554432;
171	return(0) unless $bytecnt > 0;
172	croak 'Wide character in subroutine entry' unless utf8::downgrade($$bytestr_r, 1);
173	return(_shawrite($$bytestr_r, $bytecnt<<3, $self)) if $bytecnt <= $MWS;
174	my $offset = 0;
175	while ($bytecnt > $MWS) {
176		_shawrite(substr($$bytestr_r, $offset, $MWS), $MWS<<3, $self);
177		$offset  += $MWS;
178		$bytecnt -= $MWS;
179	}
180	_shawrite(substr($$bytestr_r, $offset, $bytecnt), $bytecnt<<3, $self);
181}
182
183sub _shafinish {
184	my($self) = @_;
185	my $LENPOS = $self->{alg} <= 256 ? 448 : 896;
186	_SETBIT($self, $self->{blockcnt}++);
187	while ($self->{blockcnt} > $LENPOS) {
188		if ($self->{blockcnt} < $self->{blocksize}) {
189			_CLRBIT($self, $self->{blockcnt}++);
190		}
191		else {
192			&{$self->{sha}}($self, $self->{block});
193			$self->{priorblock} = $self->{block};
194			$self->{block} = "";
195			$self->{blockcnt} = 0;
196		}
197	}
198	while ($self->{blockcnt} < $LENPOS) {
199		_CLRBIT($self, $self->{blockcnt}++);
200	}
201	if ($self->{blocksize} > 512) {
202		$self->{block} .= pack("N", $self->{lenhh} & $MAX32);
203		$self->{block} .= pack("N", $self->{lenhl} & $MAX32);
204	}
205	$self->{block} .= pack("N", $self->{lenlh} & $MAX32);
206	$self->{block} .= pack("N", $self->{lenll} & $MAX32);
207	# here is the 'magic' code from the BROKEN QNX implementation
208	# NOTE, only sha512 should be used from this module. the other
209	# magic is every time we 'reset' $self->{block} we first copy
210	# that over to $self->{priorblock} so that we have those 4 bytes
211	# which do not properly get cleaned out.
212	my $len = $self->{lenll}/8;
213	if ($len >= 116) { # NOTE, only work up to 4gbit string (good enough for JtR)
214		substr($self->{block}, 116, 4) = substr($self->{priorblock}, 116, 4);
215	}
216	&{$self->{sha}}($self, $self->{block});
217}
218
219sub _shadigest { my($self) = @_; _digcpy($self); $self->{digest} }
220
221sub sha512 {
222	my $state = _shaopen(512) or return;
223	for (@_) { _shaWrite(\$_, length($_), $state) }
224	_shafinish($state);
225	_shadigest($state);
226}
227push(@EXPORT_OK, 'sha512');
228
2291;
230