File Coverage

blib/lib/Crypt/Perl/X509/SCT.pm
Criterion Covered Total %
statement 28 32 87.5
branch 5 8 62.5
condition n/a
subroutine 6 6 100.0
pod 1 1 100.0
total 40 47 85.1


line stmt bran cond sub pod time code
1             package Crypt::Perl::X509::SCT;
2              
3 2     2   60255 use strict;
  2         12  
  2         52  
4 2     2   8 use warnings;
  2         4  
  2         80  
5              
6             =encoding utf-8
7              
8             =head1 NAME
9              
10             Crypt::Perl::X509::SCT
11              
12             =head1 DESCRIPTION
13              
14             This implements encoding of the structure defined in
15             L.
16              
17             B Because SCT records timestamps in milliseconds rather than
18             seconds, this module requires a 64-bit Perl interpreter.
19              
20             =head1 SEE ALSO
21              
22             L has an
23             excellent walkthrough of the format that this module deals with.
24              
25             =cut
26              
27 2         856 use constant _TEMPLATE => join(
28             q<>,
29             'x', # version 1 (represented by 0)
30             'a32', # key_id
31             'N2', # timestamp; use this rather than “Q>” to support Perl 5.8.
32             'xx', # zero-length extensions array
33             'C', # hash algorithm
34             'C', # signature algorithm
35             'n', # signature length
36             'a*', # signature
37 2     2   8 );
  2         4  
38              
39             my @_TLS_hash_algorithm = (
40             q<>,
41             'md5',
42             'sha1',
43             'sha224',
44             'sha256',
45             'sha384',
46             'sha512',
47             );
48              
49             my @_TLS_signature_algorithm = (
50             'anonymous',
51             'rsa',
52             'dsa',
53             'ecdsa',
54             );
55              
56             =head1 FUNCTIONS
57              
58             =head2 encode( %opts )
59              
60             For now this always encodes a version 1 structure.
61              
62             %opts is:
63              
64             =over
65              
66             =item * C - 32-byte string
67              
68             =item * C - integer (NB: milliseconds)
69              
70             =item * C - See
71             L
72             for allowed values (e.g., C).
73              
74             =item * C - Currently accepted values are
75             C and C. (cf. the URL for C values)
76              
77             =item * C - The signature (binary string).
78              
79             =back
80              
81             =cut
82              
83             sub encode {
84 13     13 1 61 my (%opts) = @_;
85              
86             # A non-64-bit perl has no business in this module.
87 13 50       26 if (!_can_64_bit()) {
88 0         0 my $pkg = __PACKAGE__;
89 0         0 die "$pkg requires a 64-bit Perl interpreter.\n";
90             }
91              
92             my $hash_idx = _array_lookup(
93             \@_TLS_hash_algorithm,
94 13         37 $opts{'hash_algorithm'},
95             );
96              
97             my $sig_idx = _array_lookup(
98             \@_TLS_signature_algorithm,
99 13         28 $opts{'signature_algorithm'},
100             );
101              
102 13 50       35 if ( 32 != length $opts{'key_id'} ) {
103 0         0 die sprintf("“key_id” (%v.02x) must be 32 bytes!", $opts{'key_id'});
104             }
105              
106             return pack _TEMPLATE(), (
107             $opts{'key_id'},
108             ( $opts{'timestamp'} >> 32 ),
109             ( $opts{'timestamp'} & 0xffff_ffff ),
110             $hash_idx,
111             $sig_idx,
112             length($opts{'signature'}),
113 13         124 $opts{'signature'},
114             );
115             }
116              
117             # called from test
118             sub _can_64_bit {
119 14     14   116 my $exc = $@;
120              
121 14         19 my $ok = !!eval { pack 'q' };
  14         29  
122              
123 14         23 $@ = $exc;
124              
125 14         41 return $ok;
126             }
127              
128             # decode() will be easy to implement when needed
129              
130             sub _array_lookup {
131 26     26   52 my ($ar, $val, $name) = @_;
132              
133 26         29 my $found_idx;
134              
135 26         87 for my $idx ( 0 .. $#$ar ) {
136 117 100       200 if ($val eq $ar->[$idx]) {
137 26         30 $found_idx = $idx;
138 26         35 last;
139             }
140             }
141              
142 26 50       50 if (!defined $found_idx) {
143 0         0 die "Unrecognized “$name”: “$val”";
144             }
145              
146 26         40 return $found_idx;
147             }
148              
149             1;