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