summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Crypt/OpenPGP/KeyRing.pm
blob: 6709ed47a772c1b652be7d9805ba56c77b767f8d (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
package Crypt::OpenPGP::KeyRing;
use strict;

use Crypt::OpenPGP::Constants qw( PGP_PKT_USER_ID
                                  PGP_PKT_PUBLIC_KEY
                                  PGP_PKT_SECRET_KEY
                                  PGP_PKT_PUBLIC_SUBKEY
                                  PGP_PKT_SECRET_SUBKEY );
use Crypt::OpenPGP::Buffer;
use Crypt::OpenPGP::KeyBlock;
use Crypt::OpenPGP::PacketFactory;
use Crypt::OpenPGP::ErrorHandler;
use base qw( Crypt::OpenPGP::ErrorHandler );

sub new {
    my $class = shift;
    my $ring = bless { }, $class;
    $ring->init(@_);
}

sub init {
    my $ring = shift;
    my %param = @_;
    $ring->{_data} = $param{Data} || '';
    if (!$ring->{_data} && (my $file = $param{Filename})) {
        local *FH;
        open FH, $file or
            return (ref $ring)->error("Can't open keyring $file: $!");
        binmode FH;
        { local $/; $ring->{_data} = <FH> }
        close FH;
    }
    if ($ring->{_data} =~ /-----BEGIN/) {
        require Crypt::OpenPGP::Armour;
        my $rec = Crypt::OpenPGP::Armour->unarmour($ring->{_data}) or
            return (ref $ring)->error("Unarmour failed: " .
                Crypt::OpenPGP::Armour->errstr);
        $ring->{_data} = $rec->{Data};
    }
    $ring;
}

sub save {
    my $ring = shift;
    my @blocks = $ring->blocks;
    my $res = '';
    for my $block (@blocks) {
        $res .= $block->save;
    }
    $res;
}

sub read {
    my $ring = shift;
    return $ring->error("No data to read") unless $ring->{_data};
    my $buf = Crypt::OpenPGP::Buffer->new;
    $buf->append($ring->{_data});
    $ring->restore($buf);
    1;
}

sub restore {
    my $ring = shift;
    my($buf) = @_;
    $ring->{blocks} = [];
    my($kb);
    while (my $packet = Crypt::OpenPGP::PacketFactory->parse($buf)) {
        if (ref($packet) eq "Crypt::OpenPGP::Certificate" &&
            !$packet->is_subkey) {
            $kb = Crypt::OpenPGP::KeyBlock->new;
            $ring->add($kb);
        }
        $kb->add($packet) if $kb;
    }
}

sub add {
    my $ring = shift;
    my($entry) = @_;
    push @{ $ring->{blocks} }, $entry;
}

sub find_keyblock_by_keyid {
    my $ring = shift;
    my($key_id) = @_;
    my $ref = $ring->{by_keyid}{$key_id};
    unless ($ref) {
        my $len = length($key_id);
        my @kbs = $ring->find_keyblock(
            sub { substr($_[0]->key_id, -$len, $len) eq $key_id },
            [ PGP_PKT_PUBLIC_KEY, PGP_PKT_SECRET_KEY,
              PGP_PKT_PUBLIC_SUBKEY, PGP_PKT_SECRET_SUBKEY ], 1 );
        return unless @kbs;
        $ref = $ring->{by_keyid}{ $key_id } = \@kbs;
    }
    return wantarray ? @$ref : $ref->[0];
}

sub find_keyblock_by_uid {
    my $ring = shift;
    my($uid) = @_;
    $ring->find_keyblock(sub { $_[0]->id =~ /$uid/i },
        [ PGP_PKT_USER_ID ], 1 );
}

sub find_keyblock_by_index {
    my $ring = shift;
    my($index) = @_;
    ## XXX should not have to read entire keyring
    $ring->read;
    ($ring->blocks)[$index];
}

sub find_keyblock {
    my $ring = shift;
    my($test, $pkttypes, $multiple) = @_;
    $pkttypes ||= [];
    return $ring->error("No data to read") unless $ring->{_data};
    my $buf = Crypt::OpenPGP::Buffer->new_with_init($ring->{_data});
    my($last_kb_start_offset, $last_kb_start_cert, @kbs);
    while (my $pkt = Crypt::OpenPGP::PacketFactory->parse($buf,
                      [ PGP_PKT_SECRET_KEY, PGP_PKT_PUBLIC_KEY,
                        @$pkttypes ], $pkttypes)) {
        if (($pkt->{__unparsed} && ($pkt->{type} == PGP_PKT_SECRET_KEY ||
                                   $pkt->{type} == PGP_PKT_PUBLIC_KEY)) ||
            (ref($pkt) eq 'Crypt::OpenPGP::Certificate' && !$pkt->is_subkey)) {
            $last_kb_start_offset = $buf->offset;
            $last_kb_start_cert = $pkt;
        }
        next unless !$pkt->{__unparsed} && $test->($pkt);
        my $kb = Crypt::OpenPGP::KeyBlock->new;

        ## Rewind buffer; if start-cert is parsed, rewind to offset
        ## after start-cert--otherwise rewind before start-cert
        if ($last_kb_start_cert->{__unparsed}) {
            $buf->set_offset($last_kb_start_offset -
                $last_kb_start_cert->{__pkt_len});
            my $cert = Crypt::OpenPGP::PacketFactory->parse($buf);
            $kb->add($cert);
        } else {
            $buf->set_offset($last_kb_start_offset);
            $kb->add($last_kb_start_cert);
        }
        {
            my $off = $buf->offset;
            my $packet = Crypt::OpenPGP::PacketFactory->parse($buf);
            last unless $packet;
            $buf->set_offset($off),
                last if ref($packet) eq "Crypt::OpenPGP::Certificate" &&
                    !$packet->is_subkey;
            $kb->add($packet) if $kb;
            redo;
        }
        unless ($multiple) {
            return wantarray ? ($kb, $pkt) : $kb;
        } else {
            return $kb unless wantarray;
            push @kbs, $kb;
        }
    }
    @kbs;
}

sub blocks { $_[0]->{blocks} ? @{ $_[0]->{blocks} } : () }

1;
__END__

=head1 NAME

Crypt::OpenPGP::KeyRing - Key ring object

=head1 SYNOPSIS

    use Crypt::OpenPGP::KeyRing;

    my $ring = Crypt::OpenPGP::KeyRing->new( Filename => 'foo.ring' );

    my $key_id = '...';
    my $kb = $ring->find_keyblock_by_keyid($key_id);

=head1 DESCRIPTION

I<Crypt::OpenPGP::KeyRing> provides keyring management and key lookup
for I<Crypt::OpenPGP>. A I<KeyRing>, in this case, does not necessarily
have to be a keyring file; a I<KeyRing> object is just a collection of
key blocks, where each key block contains exactly one master key,
zero or more subkeys, some user ID packets, some signatures, etc.

=head1 USAGE

=head2 Crypt::OpenPGP::KeyRing->new( %arg )

Constructs a new I<Crypt::OpenPGP::KeyRing> object and returns that
object. This has the effect os hooking the object to a particular
keyring, so that all subsequent methods called on the I<KeyRing>
object will use the data specified in the arguments to I<new>.

I<%arg> can contain:

=over 4

=item * Data

A block of data specifying the serialized keyring, presumably as read
in from a file on disk. This data can be either in binary form or in
ASCII-armoured form; if the latter it will be unarmoured automatically.

This argument is optional.

=item * Filename

The path to a keyring file, or at least, a file containing a key (and
perhaps other associated keyblock data). The data in this file can be
either in binary form or in ASCII-armoured form; if the latter it will be
unarmoured automatically.

This argument is optional.

=back

=head2 $ring->find_keyblock_by_keyid($key_id)

Looks up the key ID I<$key_id> in the keyring I<$ring>. I<$key_id>
should be either a 4-octet or 8-octet string--it should I<not> be a
string of hexadecimal digits. If that is what you have, use I<pack> to
convert it to an octet string:

    pack 'H*', $hex_key_id

If a keyblock is found where the key ID of either the master key or
subkey matches I<$key_id>, that keyblock will be returned. The
definition of "match" depends on the length of I<$key_id>: if it is a
16-digit hex number, only exact matches will be returned; if it is an
8-digit hex number, any keyblocks containing keys whose last 8 hex
digits match I<$key_id> will be returned.

In scalar context, only the first keyblock found in the keyring is
returned; in list context, all matching keyblocks are returned. In
practice, duplicated key IDs are rare, particularly so if you specify
the full 16 hex digits in I<$key_id>.

Returns false on failure (C<undef> in scalar context, an empty list in
list context).

=head2 $ring->find_keyblock_by_uid($uid)

Given a string I<$uid>, looks up all keyblocks with User ID packets
matching the string I<$uid>, including partial matches.

In scalar context, returns only the first keyblock with a matching
user ID; in list context, returns all matching keyblocks.

Returns false on failure.

=head2 $ring->find_keyblock_by_index($index)

Given an index into a list of keyblocks I<$index>, returns the keyblock
(a I<Crypt::OpenPGP::KeyBlock> object) at that index. Accepts negative
indexes, so C<-1> will give you the last keyblock in the keyring.

=head1 AUTHOR & COPYRIGHTS

Please see the Crypt::OpenPGP manpage for author, copyright, and
license information.

=cut