File Coverage

perl_impl/blib/lib/Digest/SHA.pm
Criterion Covered Total %
statement 24 133 18.0
branch 3 82 3.6
condition 0 21 0.0
subroutine 8 17 47.0
pod 7 7 100.0
total 42 260 16.1


line stmt bran cond sub pod time code
1             package Digest::SHA;
2              
3             require 5.003000;
4              
5 23     23   5258688 use strict;
  23         350  
  23         704  
6 23     23   173 use warnings;
  23         48  
  23         792  
7 23     23   121 use vars qw($VERSION @ISA @EXPORT_OK $errmsg);
  23         43  
  23         1597  
8 23     23   127 use Fcntl qw(O_RDONLY O_RDWR);
  23         44  
  23         1230  
9 23     23   137 use integer;
  23         43  
  23         286  
10              
11             $VERSION = '6.02';
12              
13             require Exporter;
14             @ISA = qw(Exporter);
15             @EXPORT_OK = qw(
16             $errmsg
17             hmac_sha1 hmac_sha1_base64 hmac_sha1_hex
18             hmac_sha224 hmac_sha224_base64 hmac_sha224_hex
19             hmac_sha256 hmac_sha256_base64 hmac_sha256_hex
20             hmac_sha384 hmac_sha384_base64 hmac_sha384_hex
21             hmac_sha512 hmac_sha512_base64 hmac_sha512_hex
22             hmac_sha512224 hmac_sha512224_base64 hmac_sha512224_hex
23             hmac_sha512256 hmac_sha512256_base64 hmac_sha512256_hex
24             sha1 sha1_base64 sha1_hex
25             sha224 sha224_base64 sha224_hex
26             sha256 sha256_base64 sha256_hex
27             sha384 sha384_base64 sha384_hex
28             sha512 sha512_base64 sha512_hex
29             sha512224 sha512224_base64 sha512224_hex
30             sha512256 sha512256_base64 sha512256_hex);
31              
32             # Inherit from Digest::base if possible
33              
34             eval {
35             require Digest::base;
36             push(@ISA, 'Digest::base');
37             };
38              
39             # The following routines aren't time-critical, so they can be left in Perl
40              
41             sub new {
42 1     1 1 75 my($class, $alg) = @_;
43 1 50       8 $alg =~ s/\D+//g if defined $alg;
44 1 50       4 if (ref($class)) { # instance method
45 0 0 0     0 if (!defined($alg) || ($alg == $class->algorithm)) {
46 0         0 sharewind($class);
47 0         0 return($class);
48             }
49 0 0       0 return shainit($class, $alg) ? $class : undef;
50             }
51 1 50       20 $alg = 1 unless defined $alg;
52 1         13 return $class->newSHA($alg);
53             }
54              
55 23     23   28388 BEGIN { *reset = \&new }
56              
57             sub add_bits {
58 0     0 1   my($self, $data, $nbits) = @_;
59 0 0         unless (defined $nbits) {
60 0           $nbits = length($data);
61 0           $data = pack("B*", $data);
62             }
63 0 0         $nbits = length($data) * 8 if $nbits > length($data) * 8;
64 0           shawrite($data, $nbits, $self);
65 0           return($self);
66             }
67              
68             sub _bail {
69 0     0     my $msg = shift;
70              
71 0           $errmsg = $!;
72 0           $msg .= ": $!";
73 0           require Carp;
74 0           Carp::croak($msg);
75             }
76              
77             {
78             my $_can_T_filehandle;
79              
80             sub _istext {
81 0     0     local *FH = shift;
82 0           my $file = shift;
83              
84 0 0         if (! defined $_can_T_filehandle) {
85 0           local $^W = 0;
86 0           my $istext = eval { -T FH };
  0            
87 0 0         $_can_T_filehandle = $@ ? 0 : 1;
88 0 0         return $_can_T_filehandle ? $istext : -T $file;
89             }
90 0 0         return $_can_T_filehandle ? -T FH : -T $file;
91             }
92             }
93              
94             sub _addfile {
95 0     0     my ($self, $handle) = @_;
96              
97 0           my $n;
98 0           my $buf = "";
99              
100 0           while (($n = read($handle, $buf, 4096))) {
101 0           $self->add($buf);
102             }
103 0 0         _bail("Read failed") unless defined $n;
104              
105 0           $self;
106             }
107              
108             sub addfile {
109 0     0 1   my ($self, $file, $mode) = @_;
110              
111 0 0         return(_addfile($self, $file)) unless ref(\$file) eq 'SCALAR';
112              
113 0 0         $mode = defined($mode) ? $mode : "";
114             my ($binary, $UNIVERSAL, $BITS) =
115 0           map { $_ eq $mode } ("b", "U", "0");
  0            
116              
117             ## Always interpret "-" to mean STDIN; otherwise use
118             ## sysopen to handle full range of POSIX file names.
119             ## If $file is a directory, force an EISDIR error
120             ## by attempting to open with mode O_RDWR
121              
122 0           local *FH;
123 0 0 0       $file eq '-' and open(FH, '< -')
    0 0        
124             or sysopen(FH, $file, -d $file ? O_RDWR : O_RDONLY)
125             or _bail('Open failed');
126              
127 0 0         if ($BITS) {
128 0           my ($n, $buf) = (0, "");
129 0           while (($n = read(FH, $buf, 4096))) {
130 0           $buf =~ tr/01//cd;
131 0           $self->add_bits($buf);
132             }
133 0 0         _bail("Read failed") unless defined $n;
134 0           close(FH);
135 0           return($self);
136             }
137              
138 0 0 0       binmode(FH) if $binary || $UNIVERSAL;
139 0 0 0       if ($UNIVERSAL && _istext(*FH, $file)) {
140 0           $self->_addfileuniv(*FH);
141             }
142 0           else { $self->_addfilebin(*FH) }
143 0           close(FH);
144              
145 0           $self;
146             }
147              
148             sub getstate {
149 0     0 1   my $self = shift;
150              
151 0 0         my $alg = $self->algorithm or return;
152 0 0         my $state = $self->_getstate or return;
153 0 0         my $nD = $alg <= 256 ? 8 : 16;
154 0 0         my $nH = $alg <= 256 ? 32 : 64;
155 0 0         my $nB = $alg <= 256 ? 64 : 128;
156 0           my($H, $block, $blockcnt, $lenhh, $lenhl, $lenlh, $lenll) =
157             $state =~ /^(.{$nH})(.{$nB})(.{4})(.{4})(.{4})(.{4})(.{4})$/s;
158 0           for ($alg, $H, $block, $blockcnt, $lenhh, $lenhl, $lenlh, $lenll) {
159 0 0         return unless defined $_;
160             }
161              
162 0           my @s = ();
163 0           push(@s, "alg:" . $alg);
164 0           push(@s, "H:" . join(":", unpack("H*", $H) =~ /.{$nD}/g));
165 0           push(@s, "block:" . join(":", unpack("H*", $block) =~ /.{2}/g));
166 0           push(@s, "blockcnt:" . unpack("N", $blockcnt));
167 0           push(@s, "lenhh:" . unpack("N", $lenhh));
168 0           push(@s, "lenhl:" . unpack("N", $lenhl));
169 0           push(@s, "lenlh:" . unpack("N", $lenlh));
170 0           push(@s, "lenll:" . unpack("N", $lenll));
171 0           join("\n", @s) . "\n";
172             }
173              
174             sub putstate {
175 0     0 1   my($class, $state) = @_;
176              
177 0           my %s = ();
178 0           for (split(/\n/, $state)) {
179 0           s/^\s+//;
180 0           s/\s+$//;
181 0 0         next if (/^(#|$)/);
182 0           my @f = split(/[:\s]+/);
183 0           my $tag = shift(@f);
184 0           $s{$tag} = join('', @f);
185             }
186              
187             # H and block may contain arbitrary values, but check everything else
188 0 0         grep { $_ == $s{'alg'} } (1,224,256,384,512,512224,512256) or return;
  0            
189 0 0         length($s{'H'}) == ($s{'alg'} <= 256 ? 64 : 128) or return;
    0          
190 0 0         length($s{'block'}) == ($s{'alg'} <= 256 ? 128 : 256) or return;
    0          
191             {
192 23     23   201 no integer;
  23         62  
  23         240  
  0            
193 0           for (qw(blockcnt lenhh lenhl lenlh lenll)) {
194 0 0         0 <= $s{$_} or return;
195 0 0         $s{$_} <= 4294967295 or return;
196             }
197 0 0         $s{'blockcnt'} < ($s{'alg'} <= 256 ? 512 : 1024) or return;
    0          
198             }
199              
200             my $packed_state = (
201             pack("H*", $s{'H'}) .
202             pack("H*", $s{'block'}) .
203             pack("N", $s{'blockcnt'}) .
204             pack("N", $s{'lenhh'}) .
205             pack("N", $s{'lenhl'}) .
206             pack("N", $s{'lenlh'}) .
207 0           pack("N", $s{'lenll'})
208             );
209              
210 0           return $class->new($s{'alg'})->_putstate($packed_state);
211             }
212              
213             sub dump {
214 0     0 1   my $self = shift;
215 0           my $file = shift;
216              
217 0 0         my $state = $self->getstate or return;
218 0 0 0       $file = "-" if (!defined($file) || $file eq "");
219              
220 0           local *FH;
221 0 0         open(FH, "> $file") or return;
222 0           print FH $state;
223 0           close(FH);
224              
225 0           return($self);
226             }
227              
228             sub load {
229 0     0 1   my $class = shift;
230 0           my $file = shift;
231              
232 0 0 0       $file = "-" if (!defined($file) || $file eq "");
233              
234 0           local *FH;
235 0 0         open(FH, "< $file") or return;
236 0           my $str = join('', );
237 0           close(FH);
238              
239 0           $class->putstate($str);
240             }
241              
242             eval {
243             require XSLoader;
244             XSLoader::load('Digest::SHA', $VERSION);
245             1;
246             } or do {
247             require DynaLoader;
248             push @ISA, 'DynaLoader';
249             Digest::SHA->bootstrap($VERSION);
250             };
251              
252             1;
253             __END__