tags/0.4.3.1-pre2/CPAN/Digest/SHA/PurePerl.pm

   1 package Digest::SHA::PurePerl;
   2
   3 require 5.003000;
   4
   5 use strict;
   6 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
   7 use integer;
   8 use FileHandle;
   9
  10 $VERSION = '5.45';
  11
  12 require Exporter;
  13 @ISA = qw(Exporter);
  14 @EXPORT_OK = ();                # see "SHA and HMAC-SHA functions" below
  15
  16 # If possible, inherit from Digest::base (which depends on MIME::Base64)
  17
  18 *addfile = \&_Addfile;
  19
  20 eval {
  21         require MIME::Base64;
  22         require Digest::base;
  23         push(@ISA, 'Digest::base');
  24 };
  25 if ($@) {
  26         *hexdigest = \&_Hexdigest;
  27         *b64digest = \&_B64digest;
  28 }
  29
  30 # ref. src/sha.c and sha/sha64bit.c from Digest::SHA
  31
  32 my $MAX32 = 0xffffffff;
  33 my $TWO32 = 4294967296;
  34
  35 my $uses64bit = (((1 << 16) << 16) << 16) << 15;
  36
  37
  38 my @H01 = (                     # SHA-1 initial hash value
  39         0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476,
  40         0xc3d2e1f0
  41 );
  42
  43 my @H0224 = (                   # SHA-224 initial hash value
  44         0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,
  45         0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4
  46 );
  47
  48 my @H0256 = (                   # SHA-256 initial hash value
  49         0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,
  50         0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19
  51 );
  52
  53 my(@H0384, @H0512);             # filled in later if $uses64bit
  54
  55 # Routines with a "_c_" prefix return Perl code-fragments which are
  56 # eval'ed at initialization.  This technique emulates the behavior
  57 # of the C preprocessor, allowing the optimized transform code from
  58 # Digest::SHA to be more easily translated into Perl.
  59
  60 sub _c_SL32 {                   # code to shift $x left by $n bits
  61         my($x, $n) = @_;
  62         "($x << $n)";           # even works for 64-bit integers
  63                                 # since the upper 32 bits are
  64                                 # eventually discarded in _digcpy
  65 }
  66
  67 sub _c_SR32 {                   # code to shift $x right by $n bits
  68         my($x, $n) = @_;
  69         my $mask = (1 << (32 - $n)) - 1;
  70         "(($x >> $n) & $mask)";         # "use integer" does arithmetic
  71                                         # shift, so clear upper bits
  72 }
  73
  74 sub _c_Ch { my($x, $y, $z) = @_; "($z ^ ($x & ($y ^ $z)))" }
  75 sub _c_Pa { my($x, $y, $z) = @_; "($x ^ $y ^ $z)" }
  76 sub _c_Ma { my($x, $y, $z) = @_; "(($x & $y) | ($z & ($x | $y)))" }
  77
  78 sub _c_ROTR {                   # code to rotate $x right by $n bits
  79         my($x, $n) = @_;
  80         "(" . _c_SR32($x, $n) . " | " . _c_SL32($x, 32 - $n) . ")";
  81 }
  82
  83 sub _c_ROTL {                   # code to rotate $x left by $n bits
  84         my($x, $n) = @_;
  85         "(" . _c_SL32($x, $n) . " | " . _c_SR32($x, 32 - $n) . ")";
  86 }
  87
  88 sub _c_SIGMA0 {                 # ref. NIST SHA standard
  89         my($x) = @_;
  90         "(" . _c_ROTR($x,  2) . " ^ " . _c_ROTR($x, 13) . " ^ " .
  91                 _c_ROTR($x, 22) . ")";
  92 }
  93
  94 sub _c_SIGMA1 {
  95         my($x) = @_;
  96         "(" . _c_ROTR($x,  6) . " ^ " . _c_ROTR($x, 11) . " ^ " .
  97                 _c_ROTR($x, 25) . ")";
  98 }
  99
 100 sub _c_sigma0 {
 101         my($x) = @_;
 102         "(" . _c_ROTR($x,  7) . " ^ " . _c_ROTR($x, 18) . " ^ " .
 103                 _c_SR32($x,  3) . ")";
 104 }
 105
 106 sub _c_sigma1 {
 107         my($x) = @_;
 108         "(" . _c_ROTR($x, 17) . " ^ " . _c_ROTR($x, 19) . " ^ " .
 109                 _c_SR32($x, 10) . ")";
 110 }
 111
 112 sub _c_M1Ch {                   # ref. Digest::SHA sha.c (sha1 routine)
 113         my($a, $b, $c, $d, $e, $k, $w) = @_;
 114         "$e += " . _c_ROTL($a, 5) . " + " . _c_Ch($b, $c, $d) .
 115                 " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
 116 }
 117
 118 sub _c_M1Pa {
 119         my($a, $b, $c, $d, $e, $k, $w) = @_;
 120         "$e += " . _c_ROTL($a, 5) . " + " . _c_Pa($b, $c, $d) .
 121                 " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
 122 }
 123
 124 sub _c_M1Ma {
 125         my($a, $b, $c, $d, $e, $k, $w) = @_;
 126         "$e += " . _c_ROTL($a, 5) . " + " . _c_Ma($b, $c, $d) .
 127                 " + $k + $w; $b = " . _c_ROTL($b, 30) . ";\n";
 128 }
 129
 130 sub _c_M11Ch { my($k, $w) = @_; _c_M1Ch('$a', '$b', '$c', '$d', '$e', $k, $w) }
 131 sub _c_M11Pa { my($k, $w) = @_; _c_M1Pa('$a', '$b', '$c', '$d', '$e', $k, $w) }
 132 sub _c_M11Ma { my($k, $w) = @_; _c_M1Ma('$a', '$b', '$c', '$d', '$e', $k, $w) }
 133 sub _c_M12Ch { my($k, $w) = @_; _c_M1Ch('$e', '$a', '$b', '$c', '$d', $k, $w) }
 134 sub _c_M12Pa { my($k, $w) = @_; _c_M1Pa('$e', '$a', '$b', '$c', '$d', $k, $w) }
 135 sub _c_M12Ma { my($k, $w) = @_; _c_M1Ma('$e', '$a', '$b', '$c', '$d', $k, $w) }
 136 sub _c_M13Ch { my($k, $w) = @_; _c_M1Ch('$d', '$e', '$a', '$b', '$c', $k, $w) }
 137 sub _c_M13Pa { my($k, $w) = @_; _c_M1Pa('$d', '$e', '$a', '$b', '$c', $k, $w) }
 138 sub _c_M13Ma { my($k, $w) = @_; _c_M1Ma('$d', '$e', '$a', '$b', '$c', $k, $w) }
 139 sub _c_M14Ch { my($k, $w) = @_; _c_M1Ch('$c', '$d', '$e', '$a', '$b', $k, $w) }
 140 sub _c_M14Pa { my($k, $w) = @_; _c_M1Pa('$c', '$d', '$e', '$a', '$b', $k, $w) }
 141 sub _c_M14Ma { my($k, $w) = @_; _c_M1Ma('$c', '$d', '$e', '$a', '$b', $k, $w) }
 142 sub _c_M15Ch { my($k, $w) = @_; _c_M1Ch('$b', '$c', '$d', '$e', '$a', $k, $w) }
 143 sub _c_M15Pa { my($k, $w) = @_; _c_M1Pa('$b', '$c', '$d', '$e', '$a', $k, $w) }
 144 sub _c_M15Ma { my($k, $w) = @_; _c_M1Ma('$b', '$c', '$d', '$e', '$a', $k, $w) }
 145
 146 sub _c_W11 { my($s) = @_; '$W[' . (($s +  0) & 0xf) . ']' }
 147 sub _c_W12 { my($s) = @_; '$W[' . (($s + 13) & 0xf) . ']' }
 148 sub _c_W13 { my($s) = @_; '$W[' . (($s +  8) & 0xf) . ']' }
 149 sub _c_W14 { my($s) = @_; '$W[' . (($s +  2) & 0xf) . ']' }
 150
 151 sub _c_A1 {
 152         my($s) = @_;
 153         my $tmp = _c_W11($s) . " ^ " . _c_W12($s) . " ^ " .
 154                 _c_W13($s) . " ^ " . _c_W14($s);
 155         "((\$tmp = $tmp), (" . _c_W11($s) . " = " . _c_ROTL('$tmp', 1) . "))";
 156 }
 157
 158 # The following code emulates the "sha1" routine from Digest::SHA sha.c
 159
 160 my $sha1_code = '
 161
 162 my($K1, $K2, $K3, $K4) = (      # SHA-1 constants
 163         0x5a827999, 0x6ed9eba1, 0x8f1bbcdc, 0xca62c1d6
 164 );
 165
 166 sub _sha1 {
 167         my($self, $block) = @_;
 168         my(@W, $a, $b, $c, $d, $e, $tmp);
 169
 170         @W = unpack("N16", $block);
 171         ($a, $b, $c, $d, $e) = @{$self->{H}};
 172 ' .
 173         _c_M11Ch('$K1', '$W[ 0]'  ) . _c_M12Ch('$K1', '$W[ 1]'  ) .
 174         _c_M13Ch('$K1', '$W[ 2]'  ) . _c_M14Ch('$K1', '$W[ 3]'  ) .
 175         _c_M15Ch('$K1', '$W[ 4]'  ) . _c_M11Ch('$K1', '$W[ 5]'  ) .
 176         _c_M12Ch('$K1', '$W[ 6]'  ) . _c_M13Ch('$K1', '$W[ 7]'  ) .
 177         _c_M14Ch('$K1', '$W[ 8]'  ) . _c_M15Ch('$K1', '$W[ 9]'  ) .
 178         _c_M11Ch('$K1', '$W[10]'  ) . _c_M12Ch('$K1', '$W[11]'  ) .
 179         _c_M13Ch('$K1', '$W[12]'  ) . _c_M14Ch('$K1', '$W[13]'  ) .
 180         _c_M15Ch('$K1', '$W[14]'  ) . _c_M11Ch('$K1', '$W[15]'  ) .
 181         _c_M12Ch('$K1', _c_A1( 0) ) . _c_M13Ch('$K1', _c_A1( 1) ) .
 182         _c_M14Ch('$K1', _c_A1( 2) ) . _c_M15Ch('$K1', _c_A1( 3) ) .
 183         _c_M11Pa('$K2', _c_A1( 4) ) . _c_M12Pa('$K2', _c_A1( 5) ) .
 184         _c_M13Pa('$K2', _c_A1( 6) ) . _c_M14Pa('$K2', _c_A1( 7) ) .
 185         _c_M15Pa('$K2', _c_A1( 8) ) . _c_M11Pa('$K2', _c_A1( 9) ) .
 186         _c_M12Pa('$K2', _c_A1(10) ) . _c_M13Pa('$K2', _c_A1(11) ) .
 187         _c_M14Pa('$K2', _c_A1(12) ) . _c_M15Pa('$K2', _c_A1(13) ) .
 188         _c_M11Pa('$K2', _c_A1(14) ) . _c_M12Pa('$K2', _c_A1(15) ) .
 189         _c_M13Pa('$K2', _c_A1( 0) ) . _c_M14Pa('$K2', _c_A1( 1) ) .
 190         _c_M15Pa('$K2', _c_A1( 2) ) . _c_M11Pa('$K2', _c_A1( 3) ) .
 191         _c_M12Pa('$K2', _c_A1( 4) ) . _c_M13Pa('$K2', _c_A1( 5) ) .
 192         _c_M14Pa('$K2', _c_A1( 6) ) . _c_M15Pa('$K2', _c_A1( 7) ) .
 193         _c_M11Ma('$K3', _c_A1( 8) ) . _c_M12Ma('$K3', _c_A1( 9) ) .
 194         _c_M13Ma('$K3', _c_A1(10) ) . _c_M14Ma('$K3', _c_A1(11) ) .
 195         _c_M15Ma('$K3', _c_A1(12) ) . _c_M11Ma('$K3', _c_A1(13) ) .
 196         _c_M12Ma('$K3', _c_A1(14) ) . _c_M13Ma('$K3', _c_A1(15) ) .
 197         _c_M14Ma('$K3', _c_A1( 0) ) . _c_M15Ma('$K3', _c_A1( 1) ) .
 198         _c_M11Ma('$K3', _c_A1( 2) ) . _c_M12Ma('$K3', _c_A1( 3) ) .
 199         _c_M13Ma('$K3', _c_A1( 4) ) . _c_M14Ma('$K3', _c_A1( 5) ) .
 200         _c_M15Ma('$K3', _c_A1( 6) ) . _c_M11Ma('$K3', _c_A1( 7) ) .
 201         _c_M12Ma('$K3', _c_A1( 8) ) . _c_M13Ma('$K3', _c_A1( 9) ) .
 202         _c_M14Ma('$K3', _c_A1(10) ) . _c_M15Ma('$K3', _c_A1(11) ) .
 203         _c_M11Pa('$K4', _c_A1(12) ) . _c_M12Pa('$K4', _c_A1(13) ) .
 204         _c_M13Pa('$K4', _c_A1(14) ) . _c_M14Pa('$K4', _c_A1(15) ) .
 205         _c_M15Pa('$K4', _c_A1( 0) ) . _c_M11Pa('$K4', _c_A1( 1) ) .
 206         _c_M12Pa('$K4', _c_A1( 2) ) . _c_M13Pa('$K4', _c_A1( 3) ) .
 207         _c_M14Pa('$K4', _c_A1( 4) ) . _c_M15Pa('$K4', _c_A1( 5) ) .
 208         _c_M11Pa('$K4', _c_A1( 6) ) . _c_M12Pa('$K4', _c_A1( 7) ) .
 209         _c_M13Pa('$K4', _c_A1( 8) ) . _c_M14Pa('$K4', _c_A1( 9) ) .
 210         _c_M15Pa('$K4', _c_A1(10) ) . _c_M11Pa('$K4', _c_A1(11) ) .
 211         _c_M12Pa('$K4', _c_A1(12) ) . _c_M13Pa('$K4', _c_A1(13) ) .
 212         _c_M14Pa('$K4', _c_A1(14) ) . _c_M15Pa('$K4', _c_A1(15) ) .
 213
 214 '       $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
 215         $self->{H}->[3] += $d; $self->{H}->[4] += $e;
 216 }
 217 ';
 218
 219 eval($sha1_code);
 220
 221 sub _c_M2 {                     # ref. Digest::SHA sha.c (sha256 routine)
 222         my($a, $b, $c, $d, $e, $f, $g, $h, $w) = @_;
 223         "\$T1 = $h + " . _c_SIGMA1($e) . " + " . _c_Ch($e, $f, $g) .
 224                 " + \$K256[\$i++] + $w; $h = \$T1 + " . _c_SIGMA0($a) .
 225                 " + " . _c_Ma($a, $b, $c) . "; $d += \$T1;\n";
 226 }
 227
 228 sub _c_M21 { _c_M2('$a', '$b', '$c', '$d', '$e', '$f', '$g', '$h', $_[0]) }
 229 sub _c_M22 { _c_M2('$h', '$a', '$b', '$c', '$d', '$e', '$f', '$g', $_[0]) }
 230 sub _c_M23 { _c_M2('$g', '$h', '$a', '$b', '$c', '$d', '$e', '$f', $_[0]) }
 231 sub _c_M24 { _c_M2('$f', '$g', '$h', '$a', '$b', '$c', '$d', '$e', $_[0]) }
 232 sub _c_M25 { _c_M2('$e', '$f', '$g', '$h', '$a', '$b', '$c', '$d', $_[0]) }
 233 sub _c_M26 { _c_M2('$d', '$e', '$f', '$g', '$h', '$a', '$b', '$c', $_[0]) }
 234 sub _c_M27 { _c_M2('$c', '$d', '$e', '$f', '$g', '$h', '$a', '$b', $_[0]) }
 235 sub _c_M28 { _c_M2('$b', '$c', '$d', '$e', '$f', '$g', '$h', '$a', $_[0]) }
 236
 237 sub _c_W21 { my($s) = @_; '$W[' . (($s +  0) & 0xf) . ']' }
 238 sub _c_W22 { my($s) = @_; '$W[' . (($s + 14) & 0xf) . ']' }
 239 sub _c_W23 { my($s) = @_; '$W[' . (($s +  9) & 0xf) . ']' }
 240 sub _c_W24 { my($s) = @_; '$W[' . (($s +  1) & 0xf) . ']' }
 241
 242 sub _c_A2 {
 243         my($s) = @_;
 244         "(" . _c_W21($s) . " += " . _c_sigma1(_c_W22($s)) . " + " .
 245                 _c_W23($s) . " + " . _c_sigma0(_c_W24($s)) . ")";
 246 }
 247
 248 # The following code emulates the "sha256" routine from Digest::SHA sha.c
 249
 250 my $sha256_code = '
 251
 252 my @K256 = (                    # SHA-224/256 constants
 253         0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,
 254         0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
 255         0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,
 256         0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
 257         0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,
 258         0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
 259         0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,
 260         0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
 261         0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,
 262         0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
 263         0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,
 264         0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
 265         0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,
 266         0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
 267         0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,
 268         0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
 269 );
 270
 271 sub _sha256 {
 272         my($self, $block) = @_;
 273         my(@W, $a, $b, $c, $d, $e, $f, $g, $h, $i, $T1);
 274
 275         @W = unpack("N16", $block);
 276         ($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
 277 ' .
 278         _c_M21('$W[ 0]' ) . _c_M22('$W[ 1]' ) . _c_M23('$W[ 2]' ) .
 279         _c_M24('$W[ 3]' ) . _c_M25('$W[ 4]' ) . _c_M26('$W[ 5]' ) .
 280         _c_M27('$W[ 6]' ) . _c_M28('$W[ 7]' ) . _c_M21('$W[ 8]' ) .
 281         _c_M22('$W[ 9]' ) . _c_M23('$W[10]' ) . _c_M24('$W[11]' ) .
 282         _c_M25('$W[12]' ) . _c_M26('$W[13]' ) . _c_M27('$W[14]' ) .
 283         _c_M28('$W[15]' ) .
 284         _c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) .
 285         _c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) .
 286         _c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) .
 287         _c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) .
 288         _c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) .
 289         _c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) . _c_M22(_c_A2( 1)) .
 290         _c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) . _c_M25(_c_A2( 4)) .
 291         _c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) . _c_M28(_c_A2( 7)) .
 292         _c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) . _c_M23(_c_A2(10)) .
 293         _c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) . _c_M26(_c_A2(13)) .
 294         _c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) . _c_M21(_c_A2( 0)) .
 295         _c_M22(_c_A2( 1)) . _c_M23(_c_A2( 2)) . _c_M24(_c_A2( 3)) .
 296         _c_M25(_c_A2( 4)) . _c_M26(_c_A2( 5)) . _c_M27(_c_A2( 6)) .
 297         _c_M28(_c_A2( 7)) . _c_M21(_c_A2( 8)) . _c_M22(_c_A2( 9)) .
 298         _c_M23(_c_A2(10)) . _c_M24(_c_A2(11)) . _c_M25(_c_A2(12)) .
 299         _c_M26(_c_A2(13)) . _c_M27(_c_A2(14)) . _c_M28(_c_A2(15)) .
 300
 301 '       $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
 302         $self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
 303         $self->{H}->[6] += $g; $self->{H}->[7] += $h;
 304 }
 305 ';
 306
 307 eval($sha256_code);
 308
 309 sub _sha512_placeholder { return }
 310 my $sha512 = \&_sha512_placeholder;
 311
 312 my $_64bit_code = '
 313
 314 BEGIN { $^W = 0 }       # suppress warnings triggered by 64-bit constants
 315
 316 my @K512 = (
 317         0x428a2f98d728ae22, 0x7137449123ef65cd, 0xb5c0fbcfec4d3b2f,
 318         0xe9b5dba58189dbbc, 0x3956c25bf348b538, 0x59f111f1b605d019,
 319         0x923f82a4af194f9b, 0xab1c5ed5da6d8118, 0xd807aa98a3030242,
 320         0x12835b0145706fbe, 0x243185be4ee4b28c, 0x550c7dc3d5ffb4e2,
 321         0x72be5d74f27b896f, 0x80deb1fe3b1696b1, 0x9bdc06a725c71235,
 322         0xc19bf174cf692694, 0xe49b69c19ef14ad2, 0xefbe4786384f25e3,
 323         0x0fc19dc68b8cd5b5, 0x240ca1cc77ac9c65, 0x2de92c6f592b0275,
 324         0x4a7484aa6ea6e483, 0x5cb0a9dcbd41fbd4, 0x76f988da831153b5,
 325         0x983e5152ee66dfab, 0xa831c66d2db43210, 0xb00327c898fb213f,
 326         0xbf597fc7beef0ee4, 0xc6e00bf33da88fc2, 0xd5a79147930aa725,
 327         0x06ca6351e003826f, 0x142929670a0e6e70, 0x27b70a8546d22ffc,
 328         0x2e1b21385c26c926, 0x4d2c6dfc5ac42aed, 0x53380d139d95b3df,
 329         0x650a73548baf63de, 0x766a0abb3c77b2a8, 0x81c2c92e47edaee6,
 330         0x92722c851482353b, 0xa2bfe8a14cf10364, 0xa81a664bbc423001,
 331         0xc24b8b70d0f89791, 0xc76c51a30654be30, 0xd192e819d6ef5218,
 332         0xd69906245565a910, 0xf40e35855771202a, 0x106aa07032bbd1b8,
 333         0x19a4c116b8d2d0c8, 0x1e376c085141ab53, 0x2748774cdf8eeb99,
 334         0x34b0bcb5e19b48a8, 0x391c0cb3c5c95a63, 0x4ed8aa4ae3418acb,
 335         0x5b9cca4f7763e373, 0x682e6ff3d6b2b8a3, 0x748f82ee5defb2fc,
 336         0x78a5636f43172f60, 0x84c87814a1f0ab72, 0x8cc702081a6439ec,
 337         0x90befffa23631e28, 0xa4506cebde82bde9, 0xbef9a3f7b2c67915,
 338         0xc67178f2e372532b, 0xca273eceea26619c, 0xd186b8c721c0c207,
 339         0xeada7dd6cde0eb1e, 0xf57d4f7fee6ed178, 0x06f067aa72176fba,
 340         0x0a637dc5a2c898a6, 0x113f9804bef90dae, 0x1b710b35131c471b,
 341         0x28db77f523047d84, 0x32caab7b40c72493, 0x3c9ebe0a15c9bebc,
 342         0x431d67c49c100d4c, 0x4cc5d4becb3e42b6, 0x597f299cfc657e2a,
 343         0x5fcb6fab3ad6faec, 0x6c44198c4a475817);
 344
 345 @H0384 = (
 346         0xcbbb9d5dc1059ed8, 0x629a292a367cd507, 0x9159015a3070dd17,
 347         0x152fecd8f70e5939, 0x67332667ffc00b31, 0x8eb44a8768581511,
 348         0xdb0c2e0d64f98fa7, 0x47b5481dbefa4fa4);
 349
 350 @H0512 = (
 351         0x6a09e667f3bcc908, 0xbb67ae8584caa73b, 0x3c6ef372fe94f82b,
 352         0xa54ff53a5f1d36f1, 0x510e527fade682d1, 0x9b05688c2b3e6c1f,
 353         0x1f83d9abfb41bd6b, 0x5be0cd19137e2179);
 354
 355 sub _c_SL64 { my($x, $n) = @_; "($x << $n)" }
 356
 357 sub _c_SR64 {
 358         my($x, $n) = @_;
 359         my $mask = (1 << (64 - $n)) - 1;
 360         "(($x >> $n) & $mask)";
 361 }
 362
 363 sub _c_ROTRQ {
 364         my($x, $n) = @_;
 365         "(" . _c_SR64($x, $n) . " | " . _c_SL64($x, 64 - $n) . ")";
 366 }
 367
 368 sub _c_SIGMAQ0 {
 369         my($x) = @_;
 370         "(" . _c_ROTRQ($x, 28) . " ^ " .  _c_ROTRQ($x, 34) . " ^ " .
 371                 _c_ROTRQ($x, 39) . ")";
 372 }
 373
 374 sub _c_SIGMAQ1 {
 375         my($x) = @_;
 376         "(" . _c_ROTRQ($x, 14) . " ^ " .  _c_ROTRQ($x, 18) . " ^ " .
 377                 _c_ROTRQ($x, 41) . ")";
 378 }
 379
 380 sub _c_sigmaQ0 {
 381         my($x) = @_;
 382         "(" . _c_ROTRQ($x, 1) . " ^ " .  _c_ROTRQ($x, 8) . " ^ " .
 383                 _c_SR64($x, 7) . ")";
 384 }
 385
 386 sub _c_sigmaQ1 {
 387         my($x) = @_;
 388         "(" . _c_ROTRQ($x, 19) . " ^ " .  _c_ROTRQ($x, 61) . " ^ " .
 389                 _c_SR64($x, 6) . ")";
 390 }
 391
 392 my $sha512_code = q/
 393 sub _sha512 {
 394         my($self, $block) = @_;
 395         my(@N, @W, $a, $b, $c, $d, $e, $f, $g, $h, $T1, $T2);
 396
 397         @N = unpack("N32", $block);
 398         ($a, $b, $c, $d, $e, $f, $g, $h) = @{$self->{H}};
 399         for ( 0 .. 15) { $W[$_] = (($N[2*$_] << 16) << 16) | $N[2*$_+1] }
 400         for (16 .. 79) { $W[$_] = / .
 401                 _c_sigmaQ1(q/$W[$_- 2]/) . q/ + $W[$_- 7] + / .
 402                 _c_sigmaQ0(q/$W[$_-15]/) . q/ + $W[$_-16] }
 403         for ( 0 .. 79) {
 404                 $T1 = $h + / . _c_SIGMAQ1(q/$e/) .
 405                         q/ + (($g) ^ (($e) & (($f) ^ ($g)))) +
 406                                 $K512[$_] + $W[$_];
 407                 $T2 = / . _c_SIGMAQ0(q/$a/) .
 408                         q/ + ((($a) & ($b)) | (($c) & (($a) | ($b))));
 409                 $h = $g; $g = $f; $f = $e; $e = $d + $T1;
 410                 $d = $c; $c = $b; $b = $a; $a = $T1 + $T2;
 411         }
 412         $self->{H}->[0] += $a; $self->{H}->[1] += $b; $self->{H}->[2] += $c;
 413         $self->{H}->[3] += $d; $self->{H}->[4] += $e; $self->{H}->[5] += $f;
 414         $self->{H}->[6] += $g; $self->{H}->[7] += $h;
 415 }
 416 /;
 417
 418 eval($sha512_code);
 419 $sha512 = \&_sha512;
 420
 421 ';
 422
 423 eval($_64bit_code) if $uses64bit;
 424
 425 sub _SETBIT {
 426         my($self, $pos) = @_;
 427         my @c = unpack("C*", $self->{block});
 428         $c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
 429         $c[$pos >> 3] |= (0x01 << (7 - $pos % 8));
 430         $self->{block} = pack("C*", @c);
 431 }
 432
 433 sub _CLRBIT {
 434         my($self, $pos) = @_;
 435         my @c = unpack("C*", $self->{block});
 436         $c[$pos >> 3] = 0x00 unless defined $c[$pos >> 3];
 437         $c[$pos >> 3] &= ~(0x01 << (7 - $pos % 8));
 438         $self->{block} = pack("C*", @c);
 439 }
 440
 441 sub _BYTECNT {
 442         my($bitcnt) = @_;
 443         $bitcnt > 0 ? 1 + (($bitcnt - 1) >> 3) : 0;
 444 }
 445
 446 sub _digcpy {
 447         my($self) = @_;
 448         my @dig;
 449         for (@{$self->{H}}) {
 450                 push(@dig, (($_>>16)>>16) & $MAX32) if $self->{alg} >= 384;
 451                 push(@dig, $_ & $MAX32);
 452         }
 453         $self->{digest} = pack("N" . ($self->{digestlen}>>2), @dig);
 454 }
 455
 456 sub _sharewind {
 457         my($self) = @_;
 458         my $alg = $self->{alg};
 459         $self->{block} = ""; $self->{blockcnt} = 0;
 460         $self->{blocksize} = $alg <= 256 ? 512 : 1024;
 461         for (qw(lenll lenlh lenhl lenhh)) { $self->{$_} = 0 }
 462         $self->{digestlen} = $alg == 1 ? 20 : $alg/8;
 463         if    ($alg == 1)   { $self->{sha} = \&_sha1;   $self->{H} = [@H01]   }
 464         elsif ($alg == 224) { $self->{sha} = \&_sha256; $self->{H} = [@H0224] }
 465         elsif ($alg == 256) { $self->{sha} = \&_sha256; $self->{H} = [@H0256] }
 466         elsif ($alg == 384) { $self->{sha} = $sha512;   $self->{H} = [@H0384] }
 467         elsif ($alg == 512) { $self->{sha} = $sha512;   $self->{H} = [@H0512] }
 468         push(@{$self->{H}}, 0) while scalar(@{$self->{H}}) < 8;
 469         $self;
 470 }
 471
 472 sub _shaopen {
 473         my($alg) = @_;
 474         my($self);
 475         return unless grep { $alg == $_ } (1, 224, 256, 384, 512);
 476         return if ($alg >= 384 && !$uses64bit);
 477         $self->{alg} = $alg;
 478         _sharewind($self);
 479 }
 480
 481 sub _shadirect {
 482         my($bitstr, $bitcnt, $self) = @_;
 483         my $savecnt = $bitcnt;
 484         my $offset = 0;
 485         my $blockbytes = $self->{blocksize} >> 3;
 486         while ($bitcnt >= $self->{blocksize}) {
 487                 &{$self->{sha}}($self, substr($bitstr, $offset, $blockbytes));
 488                 $offset += $blockbytes;
 489                 $bitcnt -= $self->{blocksize};
 490         }
 491         if ($bitcnt > 0) {
 492                 $self->{block} = substr($bitstr, $offset, _BYTECNT($bitcnt));
 493                 $self->{blockcnt} = $bitcnt;
 494         }
 495         $savecnt;
 496 }
 497
 498 sub _shabytes {
 499         my($bitstr, $bitcnt, $self) = @_;
 500         my($numbits);
 501         my $savecnt = $bitcnt;
 502         if ($self->{blockcnt} + $bitcnt >= $self->{blocksize}) {
 503                 $numbits = $self->{blocksize} - $self->{blockcnt};
 504                 $self->{block} .= substr($bitstr, 0, $numbits >> 3);
 505                 $bitcnt -= $numbits;
 506                 $bitstr = substr($bitstr, $numbits >> 3, _BYTECNT($bitcnt));
 507                 &{$self->{sha}}($self, $self->{block});
 508                 $self->{block} = "";
 509                 $self->{blockcnt} = 0;
 510                 _shadirect($bitstr, $bitcnt, $self);
 511         }
 512         else {
 513                 $self->{block} .= substr($bitstr, 0, _BYTECNT($bitcnt));
 514                 $self->{blockcnt} += $bitcnt;
 515         }
 516         $savecnt;
 517 }
 518
 519 sub _shabits {
 520         my($bitstr, $bitcnt, $self) = @_;
 521         my($i, @buf);
 522         my $numbytes = _BYTECNT($bitcnt);
 523         my $savecnt = $bitcnt;
 524         my $gap = 8 - $self->{blockcnt} % 8;
 525         my @c = unpack("C*", $self->{block});
 526         my @b = unpack("C" . $numbytes, $bitstr);
 527         $c[$self->{blockcnt}>>3] &= (~0 << $gap);
 528         $c[$self->{blockcnt}>>3] |= $b[0] >> (8 - $gap);
 529         $self->{block} = pack("C*", @c);
 530         $self->{blockcnt} += ($bitcnt < $gap) ? $bitcnt : $gap;
 531         return($savecnt) if $bitcnt < $gap;
 532         if ($self->{blockcnt} == $self->{blocksize}) {
 533                 &{$self->{sha}}($self, $self->{block});
 534                 $self->{block} = "";
 535                 $self->{blockcnt} = 0;
 536         }
 537         return($savecnt) if ($bitcnt -= $gap) == 0;
 538         for ($i = 0; $i < $numbytes - 1; $i++) {
 539                 $buf[$i] = (($b[$i] << $gap) & 0xff) | ($b[$i+1] >> (8 - $gap));
 540         }
 541         $buf[$numbytes-1] = ($b[$numbytes-1] << $gap) & 0xff;
 542         _shabytes(pack("C*", @buf), $bitcnt, $self);
 543         $savecnt;
 544 }
 545
 546 sub _shawrite {
 547         my($bitstr, $bitcnt, $self) = @_;
 548         return(0) unless $bitcnt > 0;
 549         no integer;
 550         if (($self->{lenll} += $bitcnt) >= $TWO32) {
 551                 $self->{lenll} -= $TWO32;
 552                 if (++$self->{lenlh} >= $TWO32) {
 553                         $self->{lenlh} -= $TWO32;
 554                         if (++$self->{lenhl} >= $TWO32) {
 555                                 $self->{lenhl} -= $TWO32;
 556                                 if (++$self->{lenhh} >= $TWO32) {
 557                                         $self->{lenhh} -= $TWO32;
 558                                 }
 559                         }
 560                 }
 561         }
 562         use integer;
 563         my $blockcnt = $self->{blockcnt};
 564         return(_shadirect($bitstr, $bitcnt, $self)) if $blockcnt == 0;
 565         return(_shabytes ($bitstr, $bitcnt, $self)) if $blockcnt % 8 == 0;
 566         return(_shabits  ($bitstr, $bitcnt, $self));
 567 }
 568
 569 sub _shafinish {
 570         my($self) = @_;
 571         my $LENPOS = $self->{alg} <= 256 ? 448 : 896;
 572         _SETBIT($self, $self->{blockcnt}++);
 573         while ($self->{blockcnt} > $LENPOS) {
 574                 if ($self->{blockcnt} < $self->{blocksize}) {
 575                         _CLRBIT($self, $self->{blockcnt}++);
 576                 }
 577                 else {
 578                         &{$self->{sha}}($self, $self->{block});
 579                         $self->{block} = "";
 580                         $self->{blockcnt} = 0;
 581                 }
 582         }
 583         while ($self->{blockcnt} < $LENPOS) {
 584                 _CLRBIT($self, $self->{blockcnt}++);
 585         }
 586         if ($self->{blocksize} > 512) {
 587                 $self->{block} .= pack("N", $self->{lenhh} & $MAX32);
 588                 $self->{block} .= pack("N", $self->{lenhl} & $MAX32);
 589         }
 590         $self->{block} .= pack("N", $self->{lenlh} & $MAX32);
 591         $self->{block} .= pack("N", $self->{lenll} & $MAX32);
 592         &{$self->{sha}}($self, $self->{block});
 593 }
 594
 595 sub _shadigest { my($self) = @_; _digcpy($self); $self->{digest} }
 596
 597 sub _shahex {
 598         my($self) = @_;
 599         _digcpy($self);
 600         join("", unpack("H*", $self->{digest}));
 601 }
 602
 603 sub _shabase64 {
 604         my($self) = @_;
 605         _digcpy($self);
 606         my $b64 = pack("u", $self->{digest});
 607         $b64 =~ s/^.//mg;
 608         $b64 =~ s/\n//g;
 609         $b64 =~ tr|` -_|AA-Za-z0-9+/|;
 610         my $numpads = (3 - length($self->{digest}) % 3) % 3;
 611         $b64 =~ s/.{$numpads}$// if $numpads;
 612         $b64;
 613 }
 614
 615 sub _shadsize { my($self) = @_; $self->{digestlen} }
 616
 617 sub _shacpy {
 618         my($to, $from) = @_;
 619         $to->{alg} = $from->{alg};
 620         $to->{sha} = $from->{sha};
 621         $to->{H} = [@{$from->{H}}];
 622         $to->{block} = $from->{block};
 623         $to->{blockcnt} = $from->{blockcnt};
 624         $to->{blocksize} = $from->{blocksize};
 625         for (qw(lenhh lenhl lenlh lenll)) { $to->{$_} = $from->{$_} }
 626         $to->{digestlen} = $from->{digestlen};
 627         $to;
 628 }
 629
 630 sub _shadup { my($self) = @_; my($copy); _shacpy($copy, $self) }
 631
 632 sub _shadump {
 633         my $file = shift;
 634         $file = "-" if (!defined($file) || $file eq "");
 635
 636         my $fh = FileHandle->new($file, "w") or return;
 637         my $self = shift;
 638         my $is32bit = $self->{alg} <= 256;
 639         my $fmt = $is32bit ? ":%08x" : ":%016x";
 640
 641         printf $fh "alg:%d\n", $self->{alg};
 642
 643         printf $fh "H";
 644         for (@{$self->{H}}) { printf $fh $fmt, $is32bit ? $_ & $MAX32 : $_ }
 645
 646         printf $fh "\nblock";
 647         my @c = unpack("C*", $self->{block});
 648         push(@c, 0x00) while scalar(@c) < ($self->{blocksize} >> 3);
 649         for (@c) { printf $fh ":%02x", $_ }
 650
 651         printf $fh "\nblockcnt:%u\n", $self->{blockcnt};
 652
 653         printf $fh "lenhh:%lu\n", $self->{lenhh} & $MAX32;
 654         printf $fh "lenhl:%lu\n", $self->{lenhl} & $MAX32;
 655         printf $fh "lenlh:%lu\n", $self->{lenlh} & $MAX32;
 656         printf $fh "lenll:%lu\n", $self->{lenll} & $MAX32;
 657
 658         close($fh);
 659         $self;
 660 }
 661
 662 sub _match {
 663         my($fh, $tag) = @_;
 664         my @f;
 665         while (<$fh>) {
 666                 s/^\s+//;
 667                 s/\s+$//;
 668                 next if (/^(#|$)/);
 669                 @f = split(/[:\s]+/);
 670                 last;
 671         }
 672         shift(@f) eq $tag or return;
 673         return(@f);
 674 }
 675
 676 sub _shaload {
 677         my $file = shift;
 678         $file = "-" if (!defined($file) || $file eq "");
 679
 680         my $fh = FileHandle->new($file, "r") or return;
 681
 682         my @f = _match($fh, "alg") or return;
 683         my $self = _shaopen(shift(@f)) or return;
 684
 685         @f = _match($fh, "H") or return;
 686         my $numxdigits = $self->{alg} <= 256 ? 8 : 16;
 687         for (@f) { $_ = "0" . $_ while length($_) < $numxdigits }
 688         for (@f) { $_ = substr($_, 1) while length($_) > $numxdigits }
 689         @{$self->{H}} = map { $self->{alg} <= 256 ? hex($_) :
 690                 ((hex(substr($_, 0, 8)) << 16) << 16) |
 691                 hex(substr($_, 8)) } @f;
 692
 693         @f = _match($fh, "block") or return;
 694         for (@f) { $self->{block} .= chr(hex($_)) }
 695
 696         @f = _match($fh, "blockcnt") or return;
 697         $self->{blockcnt} = shift(@f);
 698         $self->{block} = substr($self->{block},0,_BYTECNT($self->{blockcnt}));
 699
 700         @f = _match($fh, "lenhh") or return;
 701         $self->{lenhh} = shift(@f);
 702         @f = _match($fh, "lenhl") or return;
 703         $self->{lenhl} = shift(@f);
 704         @f = _match($fh, "lenlh") or return;
 705         $self->{lenlh} = shift(@f);
 706         @f = _match($fh, "lenll") or return;
 707         $self->{lenll} = shift(@f);
 708
 709         close($fh);
 710         $self;
 711 }
 712
 713 # ref. src/hmac.c from Digest::SHA
 714
 715 sub _hmacopen {
 716         my($alg, $key) = @_;
 717         my($self);
 718         $self->{isha} = _shaopen($alg) or return;
 719         $self->{osha} = _shaopen($alg) or return;
 720         if (length($key) > $self->{osha}->{blocksize} >> 3) {
 721                 $self->{ksha} = _shaopen($alg) or return;
 722                 _shawrite($key, length($key) << 3, $self->{ksha});
 723                 _shafinish($self->{ksha});
 724                 $key = _shadigest($self->{ksha});
 725         }
 726         $key .= chr(0x00)
 727                 while length($key) < $self->{osha}->{blocksize} >> 3;
 728         my @k = unpack("C*", $key);
 729         for (@k) { $_ ^= 0x5c }
 730         _shawrite(pack("C*", @k), $self->{osha}->{blocksize}, $self->{osha});
 731         for (@k) { $_ ^= (0x5c ^ 0x36) }
 732         _shawrite(pack("C*", @k), $self->{isha}->{blocksize}, $self->{isha});
 733         $self;
 734 }
 735
 736 sub _hmacwrite {
 737         my($bitstr, $bitcnt, $self) = @_;
 738         _shawrite($bitstr, $bitcnt, $self->{isha});
 739 }
 740
 741 sub _hmacfinish {
 742         my($self) = @_;
 743         _shafinish($self->{isha});
 744         _shawrite(_shadigest($self->{isha}),
 745                         $self->{isha}->{digestlen} << 3, $self->{osha});
 746         _shafinish($self->{osha});
 747 }
 748
 749 sub _hmacdigest { my($self) = @_; _shadigest($self->{osha}) }
 750 sub _hmachex    { my($self) = @_; _shahex($self->{osha})    }
 751 sub _hmacbase64 { my($self) = @_; _shabase64($self->{osha}) }
 752
 753 # SHA and HMAC-SHA functions
 754
 755 my @suffix_extern = ("", "_hex", "_base64");
 756 my @suffix_intern = ("digest", "hex", "base64");
 757
 758 my($i, $alg);
 759 for $alg (1, 224, 256, 384, 512) {
 760         for $i (0 .. 2) {
 761                 my $fcn = 'sub sha' . $alg . $suffix_extern[$i] . ' {
 762                         my $state = _shaopen(' . $alg . ') or return;
 763                         for (@_) { _shawrite($_, length($_) << 3, $state) }
 764                         _shafinish($state);
 765                         _sha' . $suffix_intern[$i] . '($state);
 766                 }';
 767                 eval($fcn);
 768                 push(@EXPORT_OK, 'sha' . $alg . $suffix_extern[$i]);
 769                 $fcn = 'sub hmac_sha' . $alg . $suffix_extern[$i] . ' {
 770                         my $state = _hmacopen(' . $alg . ', pop(@_)) or return;
 771                         for (@_) { _hmacwrite($_, length($_) << 3, $state) }
 772                         _hmacfinish($state);
 773                         _hmac' . $suffix_intern[$i] . '($state);
 774                 }';
 775                 eval($fcn);
 776                 push(@EXPORT_OK, 'hmac_sha' . $alg . $suffix_extern[$i]);
 777         }
 778 }
 779
 780 # OOP methods
 781
 782 sub hashsize  { my $self = shift; _shadsize($self) << 3 }
 783 sub algorithm { my $self = shift; $self->{alg} }
 784
 785 sub add {
 786         my $self = shift;
 787         for (@_) { _shawrite($_, length($_) << 3, $self) }
 788         $self;
 789 }
 790
 791 sub digest {
 792         my $self = shift;
 793         _shafinish($self);
 794         my $rsp = _shadigest($self);
 795         _sharewind($self);
 796         $rsp;
 797 }
 798
 799 sub _Hexdigest {
 800         my $self = shift;
 801         _shafinish($self);
 802         my $rsp = _shahex($self);
 803         _sharewind($self);
 804         $rsp;
 805 }
 806
 807 sub _B64digest {
 808         my $self = shift;
 809         _shafinish($self);
 810         my $rsp = _shabase64($self);
 811         _sharewind($self);
 812         $rsp;
 813 }
 814
 815 sub new {
 816         my($class, $alg) = @_;
 817         $alg =~ s/\D+//g if defined $alg;
 818         if (ref($class)) {      # instance method
 819                 unless (defined($alg) && ($alg != $class->algorithm)) {
 820                         _sharewind($class);
 821                         return($class);
 822                 }
 823                 my $self = _shaopen($alg) or return;
 824                 return(_shacpy($class, $self));
 825         }
 826         $alg = 1 unless defined $alg;
 827         my $self = _shaopen($alg) or return;
 828         bless($self, $class);
 829         $self;
 830 }
 831
 832 sub clone {
 833         my $self = shift;
 834         my $copy = _shadup($self) or return;
 835         bless($copy, ref($self));
 836         return($copy);
 837 }
 838
 839 *reset = \&new;
 840
 841 sub add_bits {
 842         my($self, $data, $nbits) = @_;
 843         unless (defined $nbits) {
 844                 $nbits = length($data);
 845                 $data = pack("B*", $data);
 846         }
 847         _shawrite($data, $nbits, $self);
 848         return($self);
 849 }
 850
 851 sub _bail {
 852         my $msg = shift;
 853
 854         require Carp;
 855         Carp::croak("$msg: $!");
 856 }
 857
 858 sub _addfile {
 859     my ($self, $handle) = @_;
 860
 861     my $n;
 862     my $buf = "";
 863
 864     while (($n = read($handle, $buf, 4096))) {
 865         $self->add($buf);
 866     }
 867     _bail("Read failed") unless defined $n;
 868
 869     $self;
 870 }
 871
 872 sub _Addfile {
 873         my ($self, $file, $mode) = @_;
 874
 875         return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
 876
 877         $mode = defined($mode) ? $mode : "";
 878         my ($binary, $portable) = map { $_ eq $mode } ("b", "p");
 879         my $text = -T $file;
 880
 881         local *FH;
 882         open(FH, "<$file") or _bail("Open failed");
 883         binmode(FH) if $binary || $portable;
 884
 885         unless ($portable && $text) {
 886                 $self->_addfile(*FH);
 887                 close(FH);
 888                 return($self);
 889         }
 890
 891         my ($n1, $n2);
 892         my ($buf1, $buf2) = ("", "");
 893
 894         while (($n1 = read(FH, $buf1, 4096))) {
 895                 while (substr($buf1, -1) eq "\015") {
 896                         $n2 = read(FH, $buf2, 4096);
 897                         _bail("Read failed") unless defined $n2;
 898                         last unless $n2;
 899                         $buf1 .= $buf2;
 900                 }
 901                 $buf1 =~ s/\015?\015\012/\012/g;        # DOS/Windows
 902                 $buf1 =~ s/\015/\012/g;                 # early MacOS
 903                 $self->add($buf1);
 904         }
 905         _bail("Read failed") unless defined $n1;
 906         close(FH);
 907
 908         $self;
 909 }
 910
 911 sub dump {
 912         my $self = shift;
 913         my $file = shift || "";
 914
 915         _shadump($file, $self) or return;
 916         return($self);
 917 }
 918
 919 sub load {
 920         my $class = shift;
 921         my $file = shift || "";
 922         if (ref($class)) {      # instance method
 923                 my $self = _shaload($file) or return;
 924                 return(_shacpy($class, $self));
 925         }
 926         my $self = _shaload($file) or return;
 927         bless($self, $class);
 928         return($self);
 929 }
 930
 931 1;
 932 __END__
 933
 934 =head1 NAME
 935
 936 Digest::SHA::PurePerl - Perl implementation of SHA-1/224/256/384/512
 937
 938 =head1 SYNOPSIS
 939
 940 In programs:
 941
 942                 # Functional interface
 943
 944         use Digest::SHA::PurePerl qw(sha1 sha1_hex sha1_base64 ...);
 945
 946         $digest = sha1($data);
 947         $digest = sha1_hex($data);
 948         $digest = sha1_base64($data);
 949
 950         $digest = sha256($data);
 951         $digest = sha384_hex($data);
 952         $digest = sha512_base64($data);
 953
 954                 # Object-oriented
 955
 956         use Digest::SHA::PurePerl;
 957
 958         $sha = Digest::SHA::PurePerl->new($alg);
 959
 960         $sha->add($data);               # feed data into stream
 961
 962         $sha->addfile(*F);
 963         $sha->addfile($filename);
 964
 965         $sha->add_bits($bits);
 966         $sha->add_bits($data, $nbits);
 967
 968         $sha_copy = $sha->clone;        # if needed, make copy of
 969         $sha->dump($file);              #       current digest state,
 970         $sha->load($file);              #       or save it on disk
 971
 972         $digest = $sha->digest;         # compute digest
 973         $digest = $sha->hexdigest;
 974         $digest = $sha->b64digest;
 975
 976 From the command line:
 977
 978         $ shasum files
 979
 980         $ shasum --help
 981
 982 =head1 SYNOPSIS (HMAC-SHA)
 983
 984                 # Functional interface only
 985
 986         use Digest::SHA::PurePerl qw(hmac_sha1 hmac_sha1_hex ...);
 987
 988         $digest = hmac_sha1($data, $key);
 989         $digest = hmac_sha224_hex($data, $key);
 990         $digest = hmac_sha256_base64($data, $key);
 991
 992 =head1 ABSTRACT
 993
 994 Digest::SHA::PurePerl is a complete implementation of the NIST
 995 Secure Hash Standard.  It gives Perl programmers a convenient way
 996 to calculate SHA-1, SHA-224, SHA-256, SHA-384, and SHA-512 message
 997 digests.  The module can handle all types of input, including
 998 partial-byte data.
 999
1000 =head1 DESCRIPTION
1001
1002 Digest::SHA::PurePerl is written entirely in Perl.  If your platform
1003 has a C compiler, you should install the functionally equivalent
1004 (but much faster) L<Digest::SHA> module.
1005
1006 The programming interface is easy to use: it's the same one found
1007 in CPAN's L<Digest> module.  So, if your applications currently
1008 use L<Digest::MD5> and you'd prefer the stronger security of SHA,
1009 it's a simple matter to convert them.
1010
1011 The interface provides two ways to calculate digests:  all-at-once,
1012 or in stages.  To illustrate, the following short program computes
1013 the SHA-256 digest of "hello world" using each approach:
1014
1015         use Digest::SHA::PurePerl qw(sha256_hex);
1016
1017         $data = "hello world";
1018         @frags = split(//, $data);
1019
1020         # all-at-once (Functional style)
1021         $digest1 = sha256_hex($data);
1022
1023         # in-stages (OOP style)
1024         $state = Digest::SHA::PurePerl->new(256);
1025         for (@frags) { $state->add($_) }
1026         $digest2 = $state->hexdigest;
1027
1028         print $digest1 eq $digest2 ?
1029                 "whew!\n" : "oops!\n";
1030
1031 To calculate the digest of an n-bit message where I<n> is not a
1032 multiple of 8, use the I<add_bits()> method.  For example, consider
1033 the 446-bit message consisting of the bit-string "110" repeated
1034 148 times, followed by "11".  Here's how to display its SHA-1
1035 digest:
1036
1037         use Digest::SHA::PurePerl;
1038         $bits = "110" x 148 . "11";
1039         $sha = Digest::SHA::PurePerl->new(1)->add_bits($bits);
1040         print $sha->hexdigest, "\n";
1041
1042 Note that for larger bit-strings, it's more efficient to use the
1043 two-argument version I<add_bits($data, $nbits)>, where I<$data> is
1044 in the customary packed binary format used for Perl strings.
1045
1046 The module also lets you save intermediate SHA states to disk, or
1047 display them on standard output.  The I<dump()> method generates
1048 portable, human-readable text describing the current state of
1049 computation.  You can subsequently retrieve the file with I<load()>
1050 to resume where the calculation left off.
1051
1052 To see what a state description looks like, just run the following:
1053
1054         use Digest::SHA::PurePerl;
1055         Digest::SHA::PurePerl->new->add("Shaw" x 1962)->dump;
1056
1057 As an added convenience, the Digest::SHA::PurePerl module offers
1058 routines to calculate keyed hashes using the HMAC-SHA-1/224/256/384/512
1059 algorithms.  These services exist in functional form only, and
1060 mimic the style and behavior of the I<sha()>, I<sha_hex()>, and
1061 I<sha_base64()> functions.
1062
1063         # Test vector from draft-ietf-ipsec-ciph-sha-256-01.txt
1064
1065         use Digest::SHA::PurePerl qw(hmac_sha256_hex);
1066         print hmac_sha256_hex("Hi There", chr(0x0b) x 32), "\n";
1067
1068 =head1 NIST STATEMENT ON SHA-1
1069
1070 I<NIST was recently informed that researchers had discovered a way
1071 to "break" the current Federal Information Processing Standard SHA-1
1072 algorithm, which has been in effect since 1994. The researchers
1073 have not yet published their complete results, so NIST has not
1074 confirmed these findings. However, the researchers are a reputable
1075 research team with expertise in this area.>
1076
1077 I<Due to advances in computing power, NIST already planned to phase
1078 out SHA-1 in favor of the larger and stronger hash functions (SHA-224,
1079 SHA-256, SHA-384 and SHA-512) by 2010. New developments should use
1080 the larger and stronger hash functions.>
1081
1082 ref. L<http://www.csrc.nist.gov/pki/HashWorkshop/NIST%20Statement/Burr_Mar2005.html>
1083
1084 =head1 PADDING OF BASE64 DIGESTS
1085
1086 By convention, CPAN Digest modules do B<not> pad their Base64 output.
1087 Problems can occur when feeding such digests to other software that
1088 expects properly padded Base64 encodings.
1089
1090 For the time being, any necessary padding must be done by the user.
1091 Fortunately, this is a simple operation: if the length of a Base64-encoded
1092 digest isn't a multiple of 4, simply append "=" characters to the end
1093 of the digest until it is:
1094
1095         while (length($b64_digest) % 4) {
1096                 $b64_digest .= '=';
1097         }
1098
1099 To illustrate, I<sha256_base64("abc")> is computed to be
1100
1101         ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0
1102
1103 which has a length of 43.  So, the properly padded version is
1104
1105         ungWv48Bz+pBQUDeXa4iI7ADYaOWF3qctBD/YfIAFa0=
1106
1107 =head1 EXPORT
1108
1109 None by default.
1110
1111 =head1 EXPORTABLE FUNCTIONS
1112
1113 Provided your Perl installation supports 64-bit integers, all of
1114 these functions will be available for use.  Otherwise, you won't
1115 be able to perform the SHA-384 and SHA-512 transforms, both of
1116 which require 64-bit operations.
1117
1118 I<Functional style>
1119
1120 =over 4
1121
1122 =item B<sha1($data, ...)>
1123
1124 =item B<sha224($data, ...)>
1125
1126 =item B<sha256($data, ...)>
1127
1128 =item B<sha384($data, ...)>
1129
1130 =item B<sha512($data, ...)>
1131
1132 Logically joins the arguments into a single string, and returns
1133 its SHA-1/224/256/384/512 digest encoded as a binary string.
1134
1135 =item B<sha1_hex($data, ...)>
1136
1137 =item B<sha224_hex($data, ...)>
1138
1139 =item B<sha256_hex($data, ...)>
1140
1141 =item B<sha384_hex($data, ...)>
1142
1143 =item B<sha512_hex($data, ...)>
1144
1145 Logically joins the arguments into a single string, and returns
1146 its SHA-1/224/256/384/512 digest encoded as a hexadecimal string.
1147
1148 =item B<sha1_base64($data, ...)>
1149
1150 =item B<sha224_base64($data, ...)>
1151
1152 =item B<sha256_base64($data, ...)>
1153
1154 =item B<sha384_base64($data, ...)>
1155
1156 =item B<sha512_base64($data, ...)>
1157
1158 Logically joins the arguments into a single string, and returns
1159 its SHA-1/224/256/384/512 digest encoded as a Base64 string.
1160
1161 It's important to note that the resulting string does B<not> contain
1162 the padding characters typical of Base64 encodings.  This omission is
1163 deliberate, and is done to maintain compatibility with the family of
1164 CPAN Digest modules.  See L</"PADDING OF BASE64 DIGESTS"> for details.
1165
1166 =back
1167
1168 I<OOP style>
1169
1170 =over 4
1171
1172 =item B<new($alg)>
1173
1174 Returns a new Digest::SHA::PurePerl object.  Allowed values for
1175 I<$alg> are 1, 224, 256, 384, or 512.  It's also possible to use
1176 common string representations of the algorithm (e.g. "sha256",
1177 "SHA-384").  If the argument is missing, SHA-1 will be used by
1178 default.
1179
1180 Invoking I<new> as an instance method will not create a new object;
1181 instead, it will simply reset the object to the initial state
1182 associated with I<$alg>.  If the argument is missing, the object
1183 will continue using the same algorithm that was selected at creation.
1184
1185 =item B<reset($alg)>
1186
1187 This method has exactly the same effect as I<new($alg)>.  In fact,
1188 I<reset> is just an alias for I<new>.
1189
1190 =item B<hashsize>
1191
1192 Returns the number of digest bits for this object.  The values are
1193 160, 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384,
1194 and SHA-512, respectively.
1195
1196 =item B<algorithm>
1197
1198 Returns the digest algorithm for this object.  The values are 1,
1199 224, 256, 384, and 512 for SHA-1, SHA-224, SHA-256, SHA-384, and
1200 SHA-512, respectively.
1201
1202 =item B<clone>
1203
1204 Returns a duplicate copy of the object.
1205
1206 =item B<add($data, ...)>
1207
1208 Logically joins the arguments into a single string, and uses it to
1209 update the current digest state.  In other words, the following
1210 statements have the same effect:
1211
1212         $sha->add("a"); $sha->add("b"); $sha->add("c");
1213         $sha->add("a")->add("b")->add("c");
1214         $sha->add("a", "b", "c");
1215         $sha->add("abc");
1216
1217 The return value is the updated object itself.
1218
1219 =item B<add_bits($data, $nbits)>
1220
1221 =item B<add_bits($bits)>
1222
1223 Updates the current digest state by appending bits to it.  The
1224 return value is the updated object itself.
1225
1226 The first form causes the most-significant I<$nbits> of I<$data>
1227 to be appended to the stream.  The I<$data> argument is in the
1228 customary binary format used for Perl strings.
1229
1230 The second form takes an ASCII string of "0" and "1" characters as
1231 its argument.  It's equivalent to
1232
1233         $sha->add_bits(pack("B*", $bits), length($bits));
1234
1235 So, the following two statements do the same thing:
1236
1237         $sha->add_bits("111100001010");
1238         $sha->add_bits("\xF0\xA0", 12);
1239
1240 =item B<addfile(*FILE)>
1241
1242 Reads from I<FILE> until EOF, and appends that data to the current
1243 state.  The return value is the updated object itself.
1244
1245 =item B<addfile($filename [, $mode])>
1246
1247 Reads the contents of I<$filename>, and appends that data to the current
1248 state.  The return value is the updated object itself.
1249
1250 By default, I<$filename> is simply opened and read; no special modes
1251 or I/O disciplines are used.  To change this, set the optional I<$mode>
1252 argument to one of the following values:
1253
1254         "b"     read file in binary mode
1255
1256         "p"     use portable mode
1257
1258 The "p" mode is handy since it ensures that the digest value of
1259 I<$filename> will be the same when computed on different operating
1260 systems.  It accomplishes this by internally translating all newlines
1261 in text files to UNIX format before calculating the digest; on the other
1262 hand, binary files are read in raw mode with no translation whatsoever.
1263
1264 For a fuller discussion of newline formats, refer to CPAN module
1265 L<File::LocalizeNewlines>.  Its "universal line separator" regex forms
1266 the basis of I<addfile>'s portable mode processing.
1267
1268 =item B<dump($filename)>
1269
1270 Provides persistent storage of intermediate SHA states by writing
1271 a portable, human-readable representation of the current state to
1272 I<$filename>.  If the argument is missing, or equal to the empty
1273 string, the state information will be written to STDOUT.
1274
1275 =item B<load($filename)>
1276
1277 Returns a Digest::SHA::PurePerl object representing the intermediate
1278 SHA state that was previously dumped to I<$filename>.  If called
1279 as a class method, a new object is created; if called as an instance
1280 method, the object is reset to the state contained in I<$filename>.
1281 If the argument is missing, or equal to the empty string, the state
1282 information will be read from STDIN.
1283
1284 =item B<digest>
1285
1286 Returns the digest encoded as a binary string.
1287
1288 Note that the I<digest> method is a read-once operation. Once it
1289 has been performed, the Digest::SHA::PurePerl object is automatically
1290 reset in preparation for calculating another digest value.  Call
1291 I<$sha-E<gt>clone-E<gt>digest> if it's necessary to preserve the
1292 original digest state.
1293
1294 =item B<hexdigest>
1295
1296 Returns the digest encoded as a hexadecimal string.
1297
1298 Like I<digest>, this method is a read-once operation.  Call
1299 I<$sha-E<gt>clone-E<gt>hexdigest> if it's necessary to preserve
1300 the original digest state.
1301
1302 This method is inherited if L<Digest::base> is installed on your
1303 system.  Otherwise, a functionally equivalent substitute is used.
1304
1305 =item B<b64digest>
1306
1307 Returns the digest encoded as a Base64 string.
1308
1309 Like I<digest>, this method is a read-once operation.  Call
1310 I<$sha-E<gt>clone-E<gt>b64digest> if it's necessary to preserve
1311 the original digest state.
1312
1313 This method is inherited if L<Digest::base> is installed on your
1314 system.  Otherwise, a functionally equivalent substitute is used.
1315
1316 It's important to note that the resulting string does B<not> contain
1317 the padding characters typical of Base64 encodings.  This omission is
1318 deliberate, and is done to maintain compatibility with the family of
1319 CPAN Digest modules.  See L</"PADDING OF BASE64 DIGESTS"> for details.
1320
1321 =back
1322
1323 I<HMAC-SHA-1/224/256/384/512>
1324
1325 =over 4
1326
1327 =item B<hmac_sha1($data, $key)>
1328
1329 =item B<hmac_sha224($data, $key)>
1330
1331 =item B<hmac_sha256($data, $key)>
1332
1333 =item B<hmac_sha384($data, $key)>
1334
1335 =item B<hmac_sha512($data, $key)>
1336
1337 Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
1338 with the result encoded as a binary string.  Multiple I<$data>
1339 arguments are allowed, provided that I<$key> is the last argument
1340 in the list.
1341
1342 =item B<hmac_sha1_hex($data, $key)>
1343
1344 =item B<hmac_sha224_hex($data, $key)>
1345
1346 =item B<hmac_sha256_hex($data, $key)>
1347
1348 =item B<hmac_sha384_hex($data, $key)>
1349
1350 =item B<hmac_sha512_hex($data, $key)>
1351
1352 Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
1353 with the result encoded as a hexadecimal string.  Multiple I<$data>
1354 arguments are allowed, provided that I<$key> is the last argument
1355 in the list.
1356
1357 =item B<hmac_sha1_base64($data, $key)>
1358
1359 =item B<hmac_sha224_base64($data, $key)>
1360
1361 =item B<hmac_sha256_base64($data, $key)>
1362
1363 =item B<hmac_sha384_base64($data, $key)>
1364
1365 =item B<hmac_sha512_base64($data, $key)>
1366
1367 Returns the HMAC-SHA-1/224/256/384/512 digest of I<$data>/I<$key>,
1368 with the result encoded as a Base64 string.  Multiple I<$data>
1369 arguments are allowed, provided that I<$key> is the last argument
1370 in the list.
1371
1372 It's important to note that the resulting string does B<not> contain
1373 the padding characters typical of Base64 encodings.  This omission is
1374 deliberate, and is done to maintain compatibility with the family of
1375 CPAN Digest modules.  See L</"PADDING OF BASE64 DIGESTS"> for details.
1376
1377 =back
1378
1379 =head1 SEE ALSO
1380
1381 L<Digest>, L<Digest::SHA>
1382
1383 The Secure Hash Standard (FIPS PUB 180-2) can be found at:
1384
1385 L<http://csrc.nist.gov/publications/fips/fips180-2/fips180-2withchangenotice.pdf>
1386
1387 The Keyed-Hash Message Authentication Code (HMAC):
1388
1389 L<http://csrc.nist.gov/publications/fips/fips198/fips-198a.pdf>
1390
1391 =head1 AUTHOR
1392
1393         Mark Shelor     <mshelor@cpan.org>
1394
1395 =head1 ACKNOWLEDGMENTS
1396
1397 The author is particularly grateful to
1398
1399         Gisle Aas
1400         Chris Carey
1401         Jim Doble
1402         Julius Duque
1403         Jeffrey Friedl
1404         Robert Gilmour
1405         Brian Gladman
1406         Adam Kennedy
1407         Andy Lester
1408         Alex Muntada
1409         Steve Peters
1410         Chris Skiscim
1411         Martin Thurn
1412         Gunnar Wolf
1413         Adam Woodbury
1414
1415 for their valuable comments and suggestions.
1416
1417 =head1 COPYRIGHT AND LICENSE
1418
1419 Copyright (C) 2003-2007 Mark Shelor
1420
1421 This library is free software; you can redistribute it and/or modify
1422 it under the same terms as Perl itself.
1423
1424 L<perlartistic>
1425
1426 =cut