1package File::KeePass;
2
3=head1 NAME
4
5File::KeePass - Interface to KeePass V1 and V2 database files
6
7=cut
8
9use strict;
10use warnings;
11use Crypt::Rijndael;
12use Digest::SHA qw(sha256);
13
14use constant DB_HEADSIZE_V1   => 124;
15use constant DB_SIG_1         => 0x9AA2D903;
16use constant DB_SIG_2_v1      => 0xB54BFB65;
17use constant DB_SIG_2_v2      => 0xB54BFB67;
18use constant DB_VER_DW_V1     => 0x00030002;
19use constant DB_VER_DW_V2     => 0x00030000; # recent KeePass is 0x0030001
20use constant DB_FLAG_RIJNDAEL => 2;
21use constant DB_FLAG_TWOFISH  => 8;
22
23our $VERSION = '2.03';
24my %locker;
25my $salsa20_iv = "\xe8\x30\x09\x4b\x97\x20\x5d\x2a";
26my $qr_date = qr/^(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+|)?Z?$/;
27
28sub new {
29    my $class = shift;
30    my $args  = ref($_[0]) ? {%{shift()}} : {@_};
31    return bless $args, $class;
32}
33
34sub auto_lock {
35    my $self = shift;
36    $self->{'auto_lock'} = shift if @_;
37    return !exists($self->{'auto_lock'}) || $self->{'auto_lock'};
38}
39
40sub groups { shift->{'groups'} || die "No groups loaded yet\n" }
41
42sub header { shift->{'header'} }
43
44###----------------------------------------------------------------###
45
46sub load_db {
47    my $self = shift;
48    my $file = shift || die "Missing file\n";
49    my $pass = shift || die "Missing pass\n";
50    my $args = shift || {};
51
52    my $buffer = $self->slurp($file);
53    return $self->parse_db($buffer, $pass, $args);
54}
55
56sub save_db {
57    my ($self, $file, $pass, $head, $groups) = @_;
58    die "Missing file\n" if ! $file;
59    $head ||= {};
60    my $v = $file =~ /\.kdbx$/i ? 2
61          : $file =~ /\.kdb$/i  ? 1
62          : $head->{'version'} || $self->{'version'};
63    $head->{'version'} = $v;
64
65    my $buf = $self->gen_db($pass, $head, $groups);
66    my $bak = "$file.bak";
67    my $tmp = "$file.new.".int(time());
68    open my $fh, '>', $tmp or die "Could not open $tmp: $!\n";
69    binmode $fh;
70    print $fh $buf;
71    close $fh;
72    if (-s $tmp ne length($buf)) {
73        die "Written file size of $tmp didn't match (".(-s $tmp)." != ".length($buf).") - not moving into place\n";
74        unlink($tmp);
75    }
76
77    if (-e $bak) {
78        unlink($bak) or unlink($tmp) or die "Could not removing already existing backup $bak: $!\n";
79    }
80    if (-e $file) {
81        rename($file, $bak) or unlink($tmp) or die "Could not backup $file to $bak: $!\n";
82    }
83    rename($tmp, $file) or die "Could not move $tmp to $file: $!\n";
84    if (!$self->{'keep_backup'} && -e $bak) {
85        unlink($bak) or die "Could not removing temporary backup $bak: $!\n";
86    }
87
88    return 1;
89}
90
91sub clear {
92    my $self = shift;
93    $self->unlock if $self->{'groups'};
94    delete @$self{qw(header groups)};
95}
96
97sub DESTROY { shift->clear }
98
99###----------------------------------------------------------------###
100
101sub parse_db {
102    my ($self, $buffer, $pass, $args) = @_;
103    $self = $self->new($args || {}) if ! ref $self;
104    $buffer = $$buffer if ref $buffer;
105
106    my $head = $self->parse_header($buffer);
107    local $head->{'raw'} = substr $buffer, 0, $head->{'header_size'} if $head->{'version'} == 2;
108    $buffer = substr $buffer, $head->{'header_size'};
109
110    $self->unlock if $self->{'groups'}; # make sure we don't leave dangling keys should we reopen a new db
111
112    my $meth = ($head->{'version'} == 1) ? '_parse_v1_body'
113             : ($head->{'version'} == 2) ? '_parse_v2_body'
114             : die "Unsupported keepass database version ($head->{'version'})\n";
115    (my $meta, $self->{'groups'}) = $self->$meth($buffer, $pass, $head);
116    $self->{'header'} = {%$head, %$meta};
117    $self->auto_lock($args->{'auto_lock'}) if exists $args->{'auto_lock'};
118
119    $self->lock if $self->auto_lock;
120    return $self;
121}
122
123sub parse_header {
124    my ($self, $buffer) = @_;
125    my ($sig1, $sig2) = unpack 'LL', $buffer;
126    die "File signature (sig1) did not match ($sig1 != ".DB_SIG_1().")\n" if $sig1 != DB_SIG_1;
127    return $self->_parse_v1_header($buffer) if $sig2 eq DB_SIG_2_v1;
128    return $self->_parse_v2_header($buffer) if $sig2 eq DB_SIG_2_v2;
129    die "Second file signature did not match ($sig2 != ".DB_SIG_2_v1()." or ".DB_SIG_2_v2().")\n";
130}
131
132sub _parse_v1_header {
133    my ($self, $buffer) = @_;
134    my $size = length($buffer);
135    die "File was smaller than db header ($size < ".DB_HEADSIZE_V1().")\n" if $size < DB_HEADSIZE_V1;
136    my %h = (version => 1, header_size => DB_HEADSIZE_V1);
137    my @f = qw(sig1 sig2 flags ver seed_rand enc_iv n_groups n_entries checksum seed_key rounds);
138    my $t =   'L    L    L     L   a16       a16    L        L         a32      a32      L';
139    @h{@f} = unpack $t, $buffer;
140    die "Unsupported file version ($h{'ver'}).\n" if $h{'ver'} & 0xFFFFFF00 != DB_VER_DW_V1 & 0xFFFFFF00;
141    $h{'enc_type'} = ($h{'flags'} & DB_FLAG_RIJNDAEL) ? 'rijndael'
142                   : ($h{'flags'} & DB_FLAG_TWOFISH)  ? 'twofish'
143                   : die "Unknown encryption type\n";
144    return \%h;
145}
146
147sub _parse_v2_header {
148    my ($self, $buffer) = @_;
149    my %h = (version => 2, enc_type => 'rijndael');
150    @h{qw(sig1 sig2 ver)} = unpack 'L3', $buffer;
151    die "Unsupported file version2 ($h{'ver'}).\n" if $h{'ver'} & 0xFFFF0000 > 0x00020000 & 0xFFFF0000;
152    my $pos = 12;
153
154    while (1) {
155        my ($type, $size) = unpack "\@$pos CS", $buffer;
156        $pos += 3;
157        my $val = substr $buffer, $pos, $size; # #my ($val) = unpack "\@$pos a$size", $buffer;
158        if (!$type) {
159            $h{'0'} = $val;
160            $pos += $size;
161            last;
162        }
163        $pos += $size;
164        if ($type == 1) {
165            $h{'comment'} = $val;
166        } elsif ($type == 2) {
167            warn "Cipher id did not match AES\n" if $val ne "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff";
168            $h{'cipher'} = 'aes';
169        } elsif ($type == 3) {
170            $val = unpack 'V', $val;
171            warn "Compression was too large.\n" if $val > 1;
172            $h{'compression'} = $val;
173        } elsif ($type == 4) {
174            warn "Length of seed random was not 32\n" if length($val) != 32;
175            $h{'seed_rand'} = $val;
176        } elsif ($type == 5) {
177            warn "Length of seed key was not 32\n" if length($val) != 32;
178            $h{'seed_key'} = $val;
179        } elsif ($type == 6) {
180            $h{'rounds'} = unpack 'L', $val;
181        } elsif ($type == 7) {
182            warn "Length of encryption IV was not 16\n" if length($val) != 16;
183            $h{'enc_iv'} = $val;
184        } elsif ($type == 8) {
185            warn "Length of stream key was not 32\n" if length($val) != 32;
186            $h{'protected_stream_key'} = $val;
187        } elsif ($type == 9) {
188            warn "Length of start bytes was not 32\n" if length($val) != 32;
189            $h{'start_bytes'} = $val;
190        } elsif ($type == 10) {
191            warn "Inner stream id did not match Salsa20\n" if unpack('V', $val) != 2;
192            $h{'protected_stream'} = 'salsa20';
193        } else {
194            warn "Found an unknown header type ($type, $val)\n";
195        }
196    }
197
198    $h{'header_size'} = $pos;
199    return \%h;
200}
201
202sub _parse_v1_body {
203    my ($self, $buffer, $pass, $head) = @_;
204    die "Unimplemented enc_type $head->{'enc_type'}\n" if $head->{'enc_type'} ne 'rijndael';
205    my $key = $self->_master_key($pass, $head);
206    $buffer = $self->decrypt_rijndael_cbc($buffer, $key, $head->{'enc_iv'});
207
208    die "The file could not be decrypted either because the key is wrong or the file is damaged.\n"
209        if length($buffer) > 2**32-1 || (!length($buffer) && $head->{'n_groups'});
210    die "The file checksum did not match.\nThe key is wrong or the file is damaged\n"
211        if $head->{'checksum'} ne sha256($buffer);
212
213    my ($groups, $gmap, $pos) = $self->_parse_v1_groups($buffer, $head->{'n_groups'});
214    $self->_parse_v1_entries($buffer, $head->{'n_entries'}, $pos, $gmap, $groups);
215    return ({}, $groups);
216}
217
218sub _parse_v2_body {
219    my ($self, $buffer, $pass, $head) = @_;
220    my $key = $self->_master_key($pass, $head);
221    $buffer = $self->decrypt_rijndael_cbc($buffer, $key, $head->{'enc_iv'});
222    die "The database key appears invalid or else the database is corrupt.\n"
223        if substr($buffer, 0, 32, '') ne $head->{'start_bytes'};
224    $buffer = $self->unchunksum($buffer);
225    $buffer = eval { $self->decompress($buffer) } or die "Failed to decompress document: $@" if ($head->{'compression'} || '') eq '1';
226    $self->{'xml_in'} = $buffer if $self->{'keep_xml'} || $head->{'keep_xml'};
227
228    my $uuid = sub {
229        my $id = shift;
230        if ($id) {
231            $id = $self->decode_base64($id);
232            $id = 0 if $id eq "\0"x16;
233            $id =~ s/^0+(?=\d)// if $id =~ /^\d{16}$/;
234        }
235        return $id;
236    };
237
238    # parse the XML - use our own parser since XML::Simple does not do event based actions
239    my $tri = sub { return !defined($_[0]) ? undef : ('true' eq lc $_[0]) ? 1 : ('false' eq lc $_[0]) ? 0 : undef };
240    my $s20_stream = $self->salsa20_stream({key => sha256($head->{'protected_stream_key'}), iv => $salsa20_iv, rounds => 20});
241    my %BIN;
242    my $META;
243    my @GROUPS;
244    my $level = 0;
245    my $data = $self->parse_xml($buffer, {
246        top            => 'KeePassFile',
247        force_array    => {map {$_ => 1} qw(Binaries Binary Group Entry String Association Item DeletedObject)},
248        start_handlers => {Group => sub { $level++ }},
249        end_handlers   => {
250            Meta => sub {
251                my ($node, $parent) = @_;
252                die "Found multiple intances of Meta.\n" if $META;
253                $META = {};
254                my $pro = delete($node->{'MemoryProtection'}) || {}; # flatten out protection
255                @$node{map {s/Protect/protect_/; lc $_} keys %$pro} = map {$tri->($_)} values %$pro;
256                for my $key (keys %$node) {
257                    next if $key eq 'Binaries';
258                    (my $copy = $key) =~ s/([a-z])([A-Z])/${1}_${2}/g;
259                    $META->{lc $copy} = $copy =~ /_changed$/i ? $self->_parse_v2_date($node->{$key}) : $node->{$key};
260                }
261                $META->{'recycle_bin_enabled'} = $tri->($META->{'recycle_bin_enabled'});
262                $META->{$_} = $uuid->($META->{$_}) for qw(entry_templates_group last_selected_group last_top_visible_group recycle_bin_uuid);
263                die "HeaderHash recorded in file did not match actual hash of header.\n"
264                    if $META->{'header_hash'} && $head->{'raw'} && $META->{'header_hash'} ne $self->encode_base64(sha256($head->{'raw'}));
265            },
266            Binary => sub {
267                my ($node, $parent, $parent_tag, $tag) = @_;
268                if ($parent_tag eq 'Binaries') {
269                    my ($content, $id, $comp) = @$node{qw(content ID Compressed)};
270                    $content = '' if ! defined $content;
271                    $content = $self->decode_base64($content) if length $content;
272                    if ($comp && $comp eq 'True' && length $content) {
273                        eval { $content = $self->decompress($content) } or warn "Could not decompress associated binary ($id): $@";
274                    }
275                    warn "Duplicate binary id $id - using most recent.\n" if exists $BIN{$id};
276                    $BIN{$id} = $content;
277                } elsif ($parent_tag eq 'Entry') {
278                    my $key = $node->{'Key'};
279                    $key = do { warn "Missing key for binary."; 'unknown' } if ! defined $key;
280                    warn "Duplicate binary key for entry." if $parent->{'__binary__'}->{$key};
281                    $parent->{'__binary__'}->{$key} = $BIN{$node->{'Value'}->{'Ref'}};
282                }
283            },
284            CustomData => sub {
285                my ($node, $parent, $parent_tag, $tag) = @_;
286                $parent->{$tag} = {map {$_->{'Key'} => $_->{'Value'}} @{ $node->{'Item'} || [] }}; # is order important?
287            },
288            Group => sub {
289                my ($node, $parent, $parent_tag) = @_;
290                my $group = {
291                    id       => $uuid->($node->{'UUID'}),
292                    icon     => $node->{'IconID'},
293                    title    => $node->{'Name'},
294                    expanded => $tri->($node->{'IsExpanded'}),
295                    level    => $level,
296                    accessed => $self->_parse_v2_date($node->{'Times'}->{'LastAccessTime'}),
297                    expires  => $self->_parse_v2_date($node->{'Times'}->{'ExpiryTime'}),
298                    created  => $self->_parse_v2_date($node->{'Times'}->{'CreationTime'}),
299                    modified => $self->_parse_v2_date($node->{'Times'}->{'LastModificationTime'}),
300
301                    auto_type_default => $node->{'DefaultAutoTypeSequence'},
302                    auto_type_enabled => $tri->($node->{'EnableAutoType'}),
303                    enable_searching  => $tri->($node->{'EnableSearching'}),
304                    last_top_entry    => $uuid->($node->{'LastTopVisibleEntry'}),
305                    expires_enabled   => $tri->($node->{'Times'}->{'Expires'}),
306                    location_changed  => $self->_parse_v2_date($node->{'Times'}->{'LocationChanged'}),
307                    usage_count       => $node->{'Times'}->{'UsageCount'},
308                    notes             => $node->{'Notes'},
309
310                    entries => delete($node->{'__entries__'}) || [],
311                    groups  => delete($node->{'__groups__'})  || [],
312                };
313                if ($parent_tag eq 'Group') {
314                    push @{ $parent->{'__groups__'} }, $group;
315                } else {
316                    push @GROUPS, $group;
317                }
318            },
319            Entry => sub {
320                my ($node, $parent, $parent_tag) = @_;
321                my %str;
322                for my $s (@{ $node->{'String'} || [] }) {
323                    $str{$s->{'Key'}} = $s->{'Value'};
324                    $str{'__protected__'}->{$s->{'Key'} =~ /^(Password|UserName|URL|Notes|Title)$/i ? lc($s->{'Key'}) : $s->{'Key'}} = 1 if $s->{'__protected__'};
325                }
326                my $entry = {
327                    accessed => $self->_parse_v2_date($node->{'Times'}->{'LastAccessTime'}),
328                    created  => $self->_parse_v2_date($node->{'Times'}->{'CreationTime'}),
329                    expires  => $self->_parse_v2_date($node->{'Times'}->{'ExpiryTime'}),
330                    modified => $self->_parse_v2_date($node->{'Times'}->{'LastModificationTime'}),
331                    comment  => delete($str{'Notes'}),
332                    icon     => $node->{'IconID'},
333                    id       => $uuid->($node->{'UUID'}),
334                    title    => delete($str{'Title'}),
335                    url      => delete($str{'URL'}),
336                    username => delete($str{'UserName'}),
337                    password => delete($str{'Password'}),
338
339                    expires_enabled   => $tri->($node->{'Times'}->{'Expires'}),
340                    location_changed  => $self->_parse_v2_date($node->{'Times'}->{'LocationChanged'}),
341                    usage_count       => $node->{'Times'}->{'UsageCount'},
342                    tags              => $node->{'Tags'},
343                    background_color  => $node->{'BackgroundColor'},
344                    foreground_color  => $node->{'ForegroundColor'},
345                    override_url      => $node->{'OverrideURL'},
346                    auto_type         => delete($node->{'AutoType'}->{'__auto_type__'}) || [],
347                    auto_type_enabled => $tri->($node->{'AutoType'}->{'Enabled'}),
348                    auto_type_munge   => $node->{'AutoType'}->{'DataTransferObfuscation'} ? 1 : 0,
349                    protected         => delete($str{'__protected__'}),
350                };
351                $entry->{'history'} = $node->{'History'} if defined $node->{'History'};
352                $entry->{'custom_icon_uuid'} = $node->{'CustomIconUUID'} if defined $node->{'CustomIconUUID'};
353                $entry->{'strings'} = \%str if scalar keys %str;
354                $entry->{'binary'} = delete($node->{'__binary__'}) if $node->{'__binary__'};
355                push @{ $parent->{'__entries__'} }, $entry;
356            },
357            String => sub {
358                my $node = shift;
359                my $val = $node->{'Value'};
360                if (ref($val) eq 'HASH' && $val->{'Protected'} && $val->{'Protected'} eq 'True') {
361                    $val = $val->{'content'};
362                    $node->{'Value'} = (defined($val) && length($val)) ? $s20_stream->($self->decode_base64($val)) : '';
363                    $node->{'__protected__'} = 1;
364                }
365            },
366            Association => sub {
367                my ($node, $parent) = @_;
368                push @{ $parent->{'__auto_type__'} },  {window => $node->{'Window'}, keys => $node->{'KeystrokeSequence'}};
369            },
370            History => sub {
371                my ($node, $parent, $parent_tag, $tag) = @_;
372                $parent->{$tag} = delete($node->{'__entries__'}) || [];
373            },
374            Association => sub {
375                my ($node, $parent) = @_;
376                push @{ $parent->{'__auto_type__'} },  {window => $node->{'Window'}, keys => $node->{'KeystrokeSequence'}};
377            },
378            DeletedObject => sub {
379                my ($node) = @_;
380                push @{ $GROUPS[0]->{'deleted_objects'} }, {
381                    uuid => $self->decode_base64($node->{'UUID'}),
382                    date => $self->_parse_v2_date($node->{'DeletionTime'}),
383                } if $GROUPS[0] && $node->{'UUID'} && $node->{'DeletionTime'};
384            },
385        },
386    });
387
388    my $g = $GROUPS[0];
389    @GROUPS = @{ $g->{'groups'} } if @GROUPS == 1
390        && $g && $g->{'notes'} && $g->{'notes'} eq "Added as a top group by File::KeePass"
391        && @{ $g->{'groups'} || [] } && !@{ $g->{'entries'} || [] } && !$g->{'auto_type_default'};
392    return ($META, \@GROUPS);
393}
394
395sub _parse_v1_groups {
396    my ($self, $buffer, $n_groups) = @_;
397    my $pos = 0;
398
399    my @groups;
400    my %gmap; # allow entries to find their groups (group map)
401    my @gref = (\@groups); # group ref pointer stack - let levels nest safely
402    my $group = {};
403    while ($n_groups) {
404        my $type = unpack 'S', substr($buffer, $pos, 2);
405        $pos += 2;
406        die "Group header offset is out of range. ($pos)" if $pos >= length($buffer);
407
408        my $size = unpack 'L', substr($buffer, $pos, 4);
409        $pos += 4;
410        die "Group header offset is out of range. ($pos, $size)" if $pos + $size > length($buffer);
411
412        if ($type == 1) {
413            $group->{'id'}       = unpack 'L', substr($buffer, $pos, 4);
414        } elsif ($type == 2) {
415            ($group->{'title'}   = substr($buffer, $pos, $size)) =~ s/\0$//;
416        } elsif ($type == 3) {
417            $group->{'created'}  = $self->_parse_v1_date(substr($buffer, $pos, $size));
418        } elsif ($type == 4) {
419            $group->{'modified'} = $self->_parse_v1_date(substr($buffer, $pos, $size));
420        } elsif ($type == 5) {
421            $group->{'accessed'} = $self->_parse_v1_date(substr($buffer, $pos, $size));
422        } elsif ($type == 6) {
423            $group->{'expires'}  = $self->_parse_v1_date(substr($buffer, $pos, $size));
424        } elsif ($type == 7) {
425            $group->{'icon'}     = unpack 'L', substr($buffer, $pos, 4);
426        } elsif ($type == 8) {
427            $group->{'level'}    = unpack 'S', substr($buffer, $pos, 2);
428        } elsif ($type == 0xFFFF) {
429            $group->{'created'} ||= '';
430            $n_groups--;
431            $gmap{$group->{'id'}} = $group;
432            my $level = $group->{'level'} || 0;
433            if (@gref > $level + 1) { # gref is index base 1 because the root is a pointer to \@groups
434                splice @gref, $level + 1;
435            } elsif (@gref < $level + 1) {
436                push @gref, ($gref[-1]->[-1]->{'groups'} = []);
437            }
438            push @{ $gref[-1] }, $group;
439            $group = {};
440        } else {
441            $group->{'unknown'}->{$type} = substr($buffer, $pos, $size);
442        }
443        $pos += $size;
444    }
445
446    return (\@groups, \%gmap, $pos);
447}
448
449sub _parse_v1_entries {
450    my ($self, $buffer, $n_entries, $pos, $gmap, $groups) = @_;
451
452    my $entry = {};
453    while ($n_entries) {
454        my $type = unpack 'S', substr($buffer, $pos, 2);
455        $pos += 2;
456        die "Entry header offset is out of range. ($pos)" if $pos >= length($buffer);
457
458        my $size = unpack 'L', substr($buffer, $pos, 4);
459        $pos += 4;
460        die "Entry header offset is out of range for type $type. ($pos, ".length($buffer).", $size)" if $pos + $size > length($buffer);
461
462        if ($type == 1) {
463            $entry->{'id'}        = substr($buffer, $pos, $size);
464        } elsif ($type == 2) {
465            $entry->{'group_id'}  = unpack 'L', substr($buffer, $pos, 4);
466        } elsif ($type == 3) {
467            $entry->{'icon'}      = unpack 'L', substr($buffer, $pos, 4);
468        } elsif ($type == 4) {
469            ($entry->{'title'}    = substr($buffer, $pos, $size)) =~ s/\0$//;
470        } elsif ($type == 5) {
471            ($entry->{'url'}      = substr($buffer, $pos, $size)) =~ s/\0$//;
472        } elsif ($type == 6) {
473            ($entry->{'username'} = substr($buffer, $pos, $size)) =~ s/\0$//;
474        } elsif ($type == 7) {
475            ($entry->{'password'} = substr($buffer, $pos, $size)) =~ s/\0$//;
476        } elsif ($type == 8) {
477            ($entry->{'comment'}  = substr($buffer, $pos, $size)) =~ s/\0$//;
478        } elsif ($type == 9) {
479            $entry->{'created'}   = $self->_parse_v1_date(substr($buffer, $pos, $size));
480        } elsif ($type == 0xA) {
481            $entry->{'modified'}  = $self->_parse_v1_date(substr($buffer, $pos, $size));
482        } elsif ($type == 0xB) {
483            $entry->{'accessed'}  = $self->_parse_v1_date(substr($buffer, $pos, $size));
484        } elsif ($type == 0xC) {
485            $entry->{'expires'}   = $self->_parse_v1_date(substr($buffer, $pos, $size));
486	} elsif ($type == 0xD) {
487            ($entry->{'binary_name'} = substr($buffer, $pos, $size)) =~ s/\0$//;
488	} elsif ($type == 0xE) {
489            $entry->{'binary'}    = substr($buffer, $pos, $size);
490        } elsif ($type == 0xFFFF) {
491            $entry->{'created'} ||= '';
492            $n_entries--;
493            my $gid = delete $entry->{'group_id'};
494            my $ref = $gmap->{$gid};
495            if (!$ref) { # orphaned nodes go in special group
496                $gid = -1;
497                if (!$gmap->{$gid}) {
498                    push @$groups, ($gmap->{$gid} = {id => $gid, title => '*Orphaned*', icon => 0, created => $self->now});
499                }
500                $ref = $gmap->{$gid};
501            }
502
503            if ($entry->{'comment'} && $entry->{'comment'} eq 'KPX_GROUP_TREE_STATE') {
504                if (!defined($entry->{'binary'}) || length($entry->{'binary'}) < 4) {
505                    warn "Discarded metastream KPX_GROUP_TREE_STATE because of a parsing error."
506                } else {
507                    my $n = unpack 'L', substr($entry->{'binary'}, 0, 4);
508                    if ($n * 5 != length($entry->{'binary'}) - 4) {
509                        warn "Discarded metastream KPX_GROUP_TREE_STATE because of a parsing error.";
510                    } else {
511                        for (my $i = 0; $i < $n; $i++) {
512                            my $group_id    = unpack 'L', substr($entry->{'binary'}, 4 + $i * 5, 4);
513                            my $is_expanded = unpack 'C', substr($entry->{'binary'}, 8 + $i * 5, 1);
514                            $gmap->{$group_id}->{'expanded'} = $is_expanded;
515                        }
516                    }
517                }
518                $entry = {};
519                next;
520            }
521
522            $self->_check_v1_binary($entry);
523            $self->_check_v1_auto_type($entry);
524            push @{ $ref->{'entries'} }, $entry;
525            $entry = {};
526        } else {
527            $entry->{'unknown'}->{$type} = substr($buffer, $pos, $size);
528        }
529        $pos += $size;
530    }
531}
532
533sub _check_v1_binary {
534    my ($self, $e) = @_;
535    if (ref($e->{'binary'}) eq 'HASH') {
536        delete $e->{'binary_name'};
537        return;
538    }
539    my $bin   = delete $e->{'binary'};
540    my $bname = delete $e->{'binary_name'};
541    if ((defined($bin) && length($bin)) || (defined($bname) && length($bname))) {
542        defined($_) or $_ = '' for $bin, $bname;
543        $e->{'binary'} = {$bname => $bin};
544    }
545}
546
547sub _check_v1_auto_type {
548    my ($self, $e, $del) = @_;
549    $e->{'auto_type'} = [$e->{'auto_type'}] if ref($e->{'auto_type'}) eq 'HASH';
550    if (ref($e->{'auto_type'}) eq 'ARRAY') {
551        delete $e->{'auto_type_window'};
552        return;
553    }
554    my @AT;
555    my $key = delete $e->{'auto_type'};
556    my $win = delete $e->{'auto_type_window'};
557    if ((defined($key) && length($key)) || (defined($win) && length($win))) {
558        push @AT, {keys => $key, window => $win};
559    }
560    return if ! $e->{'comment'};
561    my %atw = my @atw = $e->{'comment'} =~ m{ ^Auto-Type-Window((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
562    my %atk = my @atk = $e->{'comment'} =~ m{ ^Auto-Type((?:-?\d+)?): [\t ]* (.*?) [\t ]*$ }mxg;
563    $e->{'comment'} =~ s{ ^Auto-Type(?:-Window)?(?:-?\d+)?: .* \n? }{}mxg;
564    while (@atw) {
565        my ($n, $w) = (shift(@atw), shift(@atw));
566        push @AT, {window => $w, keys => exists($atk{$n}) ? $atk{$n} : $atk{''}};
567    }
568    while (@atk) {
569        my ($n, $k) = (shift(@atk), shift(@atk));
570        push @AT, {keys => $k, window => exists($atw{$n}) ? $atw{$n} : $atw{''}};
571    }
572    for (@AT) { $_->{'window'} = '' if ! defined $_->{'window'}; $_->{'keys'} = '' if ! defined $_->{'keys'} }
573    my %uniq;
574    @AT = grep {!$uniq{"$_->{'window'}\e$_->{'keys'}"}++} @AT;
575    $e->{'auto_type'} = \@AT if @AT;
576}
577
578sub _parse_v1_date {
579    my ($self, $packed) = @_;
580    my @b = unpack('C*', $packed);
581    my $year = ($b[0] << 6) | ($b[1] >> 2);
582    my $mon  = (($b[1] & 0b11)     << 2) | ($b[2] >> 6);
583    my $day  = (($b[2] & 0b111111) >> 1);
584    my $hour = (($b[2] & 0b1)      << 4) | ($b[3] >> 4);
585    my $min  = (($b[3] & 0b1111)   << 2) | ($b[4] >> 6);
586    my $sec  = (($b[4] & 0b111111));
587    return sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $day, $hour, $min, $sec;
588}
589
590sub _parse_v2_date {
591    my ($self, $date) = @_;
592    return ($date && $date =~ $qr_date) ? "$1-$2-$3 $4:$5:$6$7" : '';
593}
594
595sub _master_key {
596    my ($self, $pass, $head) = @_;
597    my $file;
598    ($pass, $file) = @$pass if ref($pass) eq 'ARRAY';
599    $pass = sha256($pass) if defined($pass) && length($pass);
600    if ($file) {
601        $file = ref($file) ? $$file : $self->slurp($file);
602        if (length($file) == 64) {
603            $file = join '', map {chr hex} ($file =~ /\G([a-f0-9A-F]{2})/g);
604        } elsif (length($file) != 32) {
605            $file = sha256($file);
606        }
607    }
608    my $key = (!$pass && !$file) ? die "One or both of password or key file must be passed\n"
609            : ($head->{'version'} && $head->{'version'} eq '2') ? sha256(grep {$_} $pass, $file)
610            : ($pass && $file) ? sha256($pass, $file) : $pass ? $pass : $file;
611    $head->{'enc_iv'}     ||= join '', map {chr rand 256} 1..16;
612    $head->{'seed_rand'}  ||= join '', map {chr rand 256} 1..($head->{'version'} && $head->{'version'} eq '2' ? 32 : 16);
613    $head->{'seed_key'}   ||= sha256(time.rand(2**32-1).$$);
614    $head->{'rounds'} ||= $self->{'rounds'} || ($head->{'version'} && $head->{'version'} eq '2' ? 6_000 : 50_000);
615
616    my $cipher = Crypt::Rijndael->new($head->{'seed_key'}, Crypt::Rijndael::MODE_ECB());
617    $key = $cipher->encrypt($key) for 1 .. $head->{'rounds'};
618    $key = sha256($key);
619    $key = sha256($head->{'seed_rand'}, $key);
620    return $key;
621}
622
623###----------------------------------------------------------------###
624
625sub gen_db {
626    my ($self, $pass, $head, $groups) = @_;
627    $head ||= {};
628    $groups ||= $self->groups;
629    local $self->{'keep_xml'} = $head->{'keep_xml'} if exists $head->{'keep_xml'};
630    my $v = $head->{'version'} || $self->{'version'};
631    my $reuse = $head->{'reuse_header'}                        # explicit yes
632                || (!exists($head->{'reuse_header'})           # not explicit no
633                    && ($self->{'reuse_header'}                # explicit yes
634                        || !exists($self->{'reuse_header'}))); # not explicit no
635    if ($reuse) {
636        ($head, my $args) = ($self->header || {}, $head);
637        @$head{keys %$args} = values %$args;
638    }
639    $head->{'version'} = $v ||= $head->{'version'} || '1';
640    delete @$head{qw(enc_iv seed_key seed_rand protected_stream_key start_bytes)} if $reuse && $reuse < 0;
641
642    die "Missing pass\n" if ! defined($pass);
643    die "Please unlock before calling gen_db\n" if $self->is_locked($groups);
644
645    srand(rand(time() ^ $$)) if ! $self->{'no_srand'};
646    if ($v eq '2') {
647        return $self->_gen_v2_db($pass, $head, $groups);
648    } else {
649        return $self->_gen_v1_db($pass, $head, $groups);
650    }
651}
652
653sub _gen_v1_db {
654    my ($self, $pass, $head, $groups) = @_;
655    if ($head->{'sig2'} && $head->{'sig2'} eq DB_SIG_2_v2) {
656        substr($head->{'seed_rand'}, 16, 16, '') if $head->{'seed_rand'} && length($head->{'seed_rand'}) == 32; # if coming from a v2 db use a smaller key (roundtripable)
657    }
658    my $key = $self->_master_key($pass, $head);
659    my $buffer  = '';
660    my $entries = '';
661    my %gid;
662    my $gid = sub { # v1 groups id size can only be a 32 bit int - v2 is supposed to be a 16 digit string
663        local $_ = my $gid = shift;
664        return $gid{$gid} ||= do {
665            $_ = (/^\d+$/ && $_ < 2**32) ? $_ : /^([a-f0-9]{16})/i ? hex($1) : int(rand 2**32);
666            $_ = int(rand 2**32) while $gid{"\e$_\e"}++;
667            $_;
668        };
669    };
670    my %uniq;
671    my $uuid = sub { return $self->uuid(shift, \%uniq) };
672
673    my @g = $self->find_groups({}, $groups);
674    if (grep {$_->{'expanded'}} @g) {
675        my $bin = pack 'L', scalar(@g);
676        $bin .= pack('LC', $gid->($_->{'id'}), $_->{'expanded'} ? 1 : 0) for @g;
677        my $e = ($self->find_entries({title => 'Meta-Info', username => 'SYSTEM', comment => 'KPX_GROUP_TREE_STATE', url => '$'}))[0] || $self->add_entry({
678            comment  => 'KPX_GROUP_TREE_STATE',
679            title    => 'Meta-Info',
680            username => 'SYSTEM',
681            url      => '$',
682            id       => '0000000000000000',
683            group    => $g[0],
684            binary   => {'bin-stream' => $bin},
685        });
686    }
687    $head->{'n_groups'} = $head->{'n_entries'} = 0;
688    foreach my $g (@g) {
689        $head->{'n_groups'}++;
690        my @d = ([1,      pack('LL', 4, $gid->($g->{'id'}))],
691                 [2,      pack('L', length($g->{'title'})+1)."$g->{'title'}\0"],
692                 [3,      pack('L',  5). $self->_gen_v1_date($g->{'created'}  || $self->now)],
693                 [4,      pack('L',  5). $self->_gen_v1_date($g->{'modified'} || $self->now)],
694                 [5,      pack('L',  5). $self->_gen_v1_date($g->{'accessed'} || $self->now)],
695                 [6,      pack('L',  5). $self->_gen_v1_date($g->{'expires'}  || $self->default_exp)],
696                 [7,      pack('LL', 4, $g->{'icon'}  || 0)],
697                 [8,      pack('LS', 2, $g->{'level'} || 0)],
698                 [0xFFFF, pack('L', 0)]);
699        push @d, [$_, map {pack('L',length $_).$_} $g->{'unknown'}->{$_}]
700            for grep {/^\d+$/ && $_ > 8} keys %{ $g->{'unknown'} || {} };
701        $buffer .= pack('S',$_->[0]).$_->[1] for sort {$a->[0] <=> $b->[0]} @d;
702        foreach my $e (@{ $g->{'entries'} || [] }) {
703            $head->{'n_entries'}++;
704
705            my $bins = $e->{'binary'} || {}; if (ref($bins) ne 'HASH') { warn "Entry binary field was not a hashref of name/content pairs.\n"; $bins = {} }
706            my @bkeys = sort keys %$bins;
707            warn "Found more than one entry in the binary hashref.  Encoding only the first one of (@bkeys) on a version 1 database.\n" if @bkeys > 1;
708            my $bname = @bkeys ? $bkeys[0] : '';
709            my $bin = $bins->{$bname}; $bin = '' if ! defined $bin;
710
711            my $at = $e->{'auto_type'} || []; if (ref($at) ne 'ARRAY') { warn "Entry auto_type field was not an arrayref of auto_type info.\n"; $at = [] }
712            my %AT; my @AT;
713            for (@$at) {
714                my ($k, $w) = map {defined($_) ? $_ : ''} @$_{qw(keys window)};
715                push @AT, $k if ! grep {$_ eq $k} @AT;
716                push @{ $AT{$k} }, $w;
717            }
718            my $txt = '';
719            for my $i (1 .. @AT) {
720                $txt .= "Auto-Type".($i>1 ? "-$i" : '').": $AT[$i-1]\n";
721                $txt .= "Auto-Type-Window".($i>1 ? "-$i" : '').": $_\n" for @{ $AT{$AT[$i-1]} };
722            }
723            my $com = defined($e->{'comment'}) ? "$txt$e->{'comment'}" : $txt;
724            my @d = ([1,      pack('L', 16). $uuid->($e->{'id'})],
725                     [2,      pack('LL', 4, $gid->($g->{'id'}))],
726                     [3,      pack('LL', 4, $e->{'icon'} || 0)],
727                     [4,      pack('L', length($e->{'title'})+1)."$e->{'title'}\0"],
728                     [5,      pack('L', length($e->{'url'})+1).   "$e->{'url'}\0"],
729                     [6,      pack('L', length($e->{'username'})+1). "$e->{'username'}\0"],
730                     [7,      pack('L', length($e->{'password'})+1). "$e->{'password'}\0"],
731                     [8,      pack('L', length($com)+1).  "$com\0"],
732                     [9,      pack('L', 5). $self->_gen_v1_date($e->{'created'}  || $self->now)],
733                     [0xA,    pack('L', 5). $self->_gen_v1_date($e->{'modified'} || $self->now)],
734                     [0xB,    pack('L', 5). $self->_gen_v1_date($e->{'accessed'} || $self->now)],
735                     [0xC,    pack('L', 5). $self->_gen_v1_date($e->{'expires'}  || $self->default_exp)],
736                     [0xD,    pack('L', length($bname)+1)."$bname\0"],
737                     [0xE,    pack('L', length($bin)).$bin],
738                     [0xFFFF, pack('L', 0)]);
739            push @d, [$_, pack('L', length($e->{'unknown'}->{$_})).$e->{'unknown'}->{$_}]
740                for grep {/^\d+$/ && $_ > 0xE} keys %{ $e->{'unknown'} || {} };
741            $entries .= pack('S',$_->[0]).$_->[1] for sort {$a->[0] <=> $b->[0]} @d;
742        }
743    }
744    $buffer .= $entries; $entries = '';
745
746    require utf8;
747    utf8::downgrade($buffer);
748    $head->{'checksum'} = sha256($buffer);
749
750    return $self->_gen_v1_header($head) . $self->encrypt_rijndael_cbc($buffer, $key, $head->{'enc_iv'});
751}
752
753sub _gen_v1_header {
754    my ($self, $head) = @_;
755    $head->{'sig1'}  = DB_SIG_1;
756    $head->{'sig2'}  = DB_SIG_2_v1;
757    $head->{'flags'} = DB_FLAG_RIJNDAEL;
758    $head->{'ver'}   = DB_VER_DW_V1;
759    $head->{'n_groups'}  ||= 0;
760    $head->{'n_entries'} ||= 0;
761    die "Length of $_ was not 32 (".length($head->{$_}).")\n" for grep {length($head->{$_}) != 32} qw(seed_key checksum);
762    die "Length of $_ was not 16 (".length($head->{$_}).")\n" for grep {length($head->{$_}) != 16} qw(enc_iv seed_rand);
763    my @f = qw(sig1 sig2 flags ver seed_rand enc_iv n_groups n_entries checksum seed_key rounds);
764    my $t =   'L    L    L     L   a16       a16    L        L         a32      a32      L';
765    my $header = pack $t, @$head{@f};
766    die "Invalid generated header\n" if length($header) != DB_HEADSIZE_V1;
767    return $header;
768}
769
770sub _gen_v1_date {
771    my ($self, $date) = @_;
772    return "\0\0\0\0\0" if ! $date;
773    my ($year, $mon, $day, $hour, $min, $sec) = $date =~ /^(\d\d\d\d)-(\d\d)-(\d\d) (\d\d):(\d\d):(\d\d)$/ ? ($1,$2,$3,$4,$5,$6) : die "Invalid date ($date)";
774    return pack('C*',
775                ($year >> 6) & 0b111111,
776                (($year & 0b111111) << 2) | (($mon >> 2) & 0b11),
777                (($mon & 0b11) << 6) | (($day & 0b11111) << 1) | (($hour >> 4) & 0b1),
778                (($hour & 0b1111) << 4) | (($min >> 2) & 0b1111),
779                (($min & 0b11) << 6) | ($sec & 0b111111),
780               );
781}
782
783sub _gen_v2_db {
784    my ($self, $pass, $head, $groups) = @_;
785    if ($head->{'sig2'} && $head->{'sig2'} eq DB_SIG_2_v1) {
786        $head->{'seed_rand'} = $head->{'seed_rand'}x2 if $head->{'seed_rand'} && length($head->{'seed_rand'}) == 16; # if coming from a v1 db augment the key (roundtripable)
787    }
788    $head->{'compression'} = 1 if ! defined $head->{'compression'};
789    $head->{'start_bytes'} ||= join '', map {chr rand 256} 1 .. 32;
790    $head->{'protected_stream_key'} ||= join '', map {chr rand 256} 1..32;
791    my $key = $self->_master_key($pass, $head);
792    my $header = $self->_gen_v2_header($head);
793
794    my $buffer  = '';
795    my $untri = sub { return (!defined($_[0]) && !$_[1]) ? 'null' : !$_[0] ? 'False' : 'True' };
796    my %uniq;
797    my $uuid = sub { my $id = (defined($_[0]) && $_[0] eq '0') ? "\0"x16 : $self->uuid($_[0], \%uniq); return $self->encode_base64($id) };
798
799    my @mfld = qw(Generator HeaderHash DatabaseName DatabaseNameChanged DatabaseDescription DatabaseDescriptionChanged DefaultUserName DefaultUserNameChanged
800                        MaintenanceHistoryDays Color MasterKeyChanged MasterKeyChangeRec MasterKeyChangeForce MemoryProtection
801                        RecycleBinEnabled RecycleBinUUID RecycleBinChanged EntryTemplatesGroup EntryTemplatesGroupChanged HistoryMaxItems HistoryMaxSize
802                        LastSelectedGroup LastTopVisibleGroup Binaries CustomData);
803    my $META = {__sort__ => \@mfld};
804    for my $key (@mfld) {
805        (my $copy = $key) =~ s/([a-z])([A-Z])/${1}_${2}/g;
806        $META->{$key} = $head->{lc $copy};
807    }
808    my $def = sub {
809        my ($k, $d, $r) = @_;
810        $META->{$k} = $d if !defined($META->{$k}) || ($r and $META->{$k} !~ $r);
811        $META->{$k} = $self->_gen_v2_date($META->{$k}) if $k =~ /Changed$/;
812    };
813    my $now = $self->_gen_v2_date;
814    $META->{'HeaderHash'} = $self->encode_base64(sha256($header));
815    $def->(Color                      => '');
816    $def->(DatabaseDescription        => '');
817    $def->(DatabaseDescriptionChanged => $now, $qr_date);
818    $def->(DatabaseName               => '');
819    $def->(DatabaseNameChanged        => $now, $qr_date);
820    $def->(DefaultUserName            => '');
821    $def->(DefaultUserNameChanged     => $now, $qr_date);
822    $def->(EntryTemplatesGroupChanged => $now, $qr_date);
823    $def->(Generator                  => ref($self));
824    $def->(HistoryMaxItems            => 10, qr{^\d+$});
825    $def->(HistoryMaxSize             => 6291456, qr{^\d+$});
826    $def->(MaintenanceHistoryDays     => 365, qr{^\d+$});
827    $def->(MasterKeyChangeForce       => -1);
828    $def->(MasterKeyChangeRec         => -1);
829    $def->(MasterKeyChanged           => $now, $qr_date);
830    $def->(RecycleBinChanged          => $now, $qr_date);
831    $META->{$_} = $uuid->($META->{$_} || 0) for qw(EntryTemplatesGroup LastSelectedGroup LastTopVisibleGroup RecycleBinUUID);
832    $META->{'RecycleBinEnabled'}      = $untri->(exists($META->{'RecycleBinEnabled'}) ? $META->{'RecycleBinEnabled'} : 1, 1);
833    my $p = $META->{'MemoryProtection'} ||= {};
834    for my $new (qw(ProtectTitle ProtectUserName ProtectPassword ProtectURL ProtectNotes)) { # unflatten protection
835        (my $key = lc $new) =~ s/protect/protect_/;
836        push @{$p->{'__sort__'}}, $new;
837        $p->{$new} = (exists($META->{$key}) ? delete($META->{$key}) : ($key eq 'protect_password')) ? 'True' : 'False';
838    }
839    my $cd = $META->{'CustomData'} ||= {};
840    $META->{'CustomData'} = {Item => [map {{Key => $_, Value => $cd->{$_}}} sort keys %$cd]} if ref($cd) eq 'HASH' && scalar keys %$cd;
841
842    my @GROUPS;
843    my $BIN = $META->{'Binaries'}->{'Binary'} = [];
844    my @PROTECT_BIN;
845    my @PROTECT_STR;
846    my $data = {
847        Meta => $META,
848        Root => {
849            __sort__ => [qw(Group DeletedObjects)],
850            Group => \@GROUPS,
851            DeletedObjects => undef,
852        },
853    };
854
855    my $gen_entry; $gen_entry = sub {
856        my ($e, $parent) = @_;
857        push @$parent, my $E = {
858            __sort__ => [qw(UUID IconID ForegroundColor BackgroundColor OverrideURL Tags Times String AutoType History)],
859            UUID   => $uuid->($e->{'id'}),
860            IconID => $e->{'icon'} || 0,
861            Times  => {
862                __sort__             => [qw(LastModificationTime CreationTime LastAccessTime ExpiryTime Expires UsageCount LocationChanged)],
863                Expires              => $untri->($e->{'expires_enabled'}, 1),
864                UsageCount           => $e->{'usage_count'} || 0,
865                LastAccessTime       => $self->_gen_v2_date($e->{'accessed'}),
866                ExpiryTime           => $self->_gen_v2_date($e->{'expires'} || $self->default_exp),
867                CreationTime         => $self->_gen_v2_date($e->{'created'}),
868                LastModificationTime => $self->_gen_v2_date($e->{'modified'}),
869                LocationChanged      => $self->_gen_v2_date($e->{'location_changed'}),
870            },
871            Tags            => $e->{'tags'},
872            BackgroundColor => $e->{'background_color'},
873            ForegroundColor => $e->{'foreground_color'},
874            CustomIconUUID  => $uuid->($e->{'custom_icon_uuid'} || 0),
875            OverrideURL     => $e->{'override_url'},
876            AutoType        => {
877                Enabled     => $untri->(exists($e->{'auto_type_enabled'}) ? $e->{'auto_type_enabled'} : 1, 1),
878                DataTransferObfuscation => $e->{'auto_type_munge'} ? 1 : 0,
879            },
880        };
881        foreach my $key (sort(keys %{ $e->{'strings'} || {} }), qw(Notes Password Title URL UserName)) {
882            my $val = ($key eq 'Notes') ? $e->{'comment'} : ($key=~/^(Password|Title|URL|UserName)$/) ? $e->{lc $key} : $e->{'strings'}->{$key};
883            next if ! defined $val;
884            push @{ $E->{'String'} }, my $s = {
885                Key => $key,
886                Value => $val,
887            };
888            if (($META->{'MemoryProtection'}->{"Protect${key}"} || '') eq 'True'
889                || $e->{'protected'}->{$key =~ /^(Password|UserName|URL|Notes|Title)$/ ? lc($key) : $key}) {
890                $s->{'Value'} = {Protected => 'True', content => $val};
891                push @PROTECT_STR, \$s->{'Value'}->{'content'} if length $s->{'Value'}->{'content'};
892            }
893        }
894        foreach my $at (@{ $e->{'auto_type'} || [] }) {
895            push @{ $E->{'AutoType'}->{'Association'} }, {
896                Window => $at->{'window'},
897                KeystrokeSequence => $at->{'keys'},
898            };
899        }
900        my $bin = $e->{'binary'} || {}; $bin = {__anon__ => $bin} if ref($bin) ne 'HASH';
901        splice @{ $E->{'__sort__'} }, -2, 0, 'Binary' if scalar keys %$bin;
902        foreach my $key (sort keys %$bin) {
903            push @$BIN, my $b = {
904                __attr__ => [qw(ID Compressed)],
905                ID       => $#$BIN+1,
906                content  => defined($bin->{$key}) ? $bin->{$key} : '',
907            };
908            $b->{'Compressed'} = (length($b->{'content'}) < 100 || $self->{'no_binary_compress'}) ? 'False' : 'True';
909            if ($b->{'Compressed'} eq 'True') {
910                eval { $b->{'content'} = $self->compress($b->{'content'}) } or warn "Could not compress associated binary ($b->{'ID'}): $@";
911            }
912            $b->{'content'} = $self->encode_base64($b->{'content'});
913            push @{ $E->{'Binary'} }, {Key => $key, Value => {__attr__ => [qw(Ref)], Ref => $b->{'ID'}, content => ''}};
914        }
915        foreach my $h (@{ $e->{'history'}||[] }) {
916            $gen_entry->($h, $E->{'History'}->{'Entry'} ||= []);
917        }
918    };
919
920    my $rec; $rec = sub {
921        my ($group, $parent) = @_;
922        return if ref($group) ne 'HASH';
923        push @$parent, my $G = {
924            __sort__ => [qw(UUID Name Notes IconID Times IsExpanded DefaultAutoTypeSequence EnableAutoType EnableSearching LastTopVisibleEntry)],
925            UUID   => $uuid->($group->{'id'}),
926            Name   => $group->{'title'} || '',
927            Notes  => $group->{'notes'},
928            IconID => $group->{'icon'} || 0,
929            Times  => {
930                __sort__             => [qw(LastModificationTime CreationTime LastAccessTime ExpiryTime Expires UsageCount LocationChanged)],
931                Expires              => $untri->($group->{'expires_enabled'}, 1),
932                UsageCount           => $group->{'usage_count'} || 0,
933                LastAccessTime       => $self->_gen_v2_date($group->{'accessed'}),
934                ExpiryTime           => $self->_gen_v2_date($group->{'expires'} || $self->default_exp),
935                CreationTime         => $self->_gen_v2_date($group->{'created'}),
936                LastModificationTime => $self->_gen_v2_date($group->{'modified'}),
937                LocationChanged      => $self->_gen_v2_date($group->{'location_changed'}),
938            },
939            IsExpanded              => $untri->($group->{'expanded'}, 1),
940            DefaultAutoTypeSequence => $group->{'auto_type_default'},
941            EnableAutoType          => lc($untri->(exists($group->{'auto_type_enabled'}) ? $group->{'auto_type_enabled'} : 1)),
942            EnableSearching         => lc($untri->(exists($group->{'enable_searching'}) ? $group->{'enable_searching'} : 1)),
943            LastTopVisibleEntry     => $uuid->($group->{'last_top_entry'} || 0),
944        };
945        $G->{'CustomIconUUID'} = $uuid->($group->{'custom_icon_uuid'}) if $group->{'custom_icon_uuid'}; # TODO
946        push @{$G->{'__sort__'}}, 'Entry' if @{ $group->{'entries'} || [] };
947        foreach my $e (@{ $group->{'entries'} || [] }) {
948            $gen_entry->($e, $G->{'Entry'} ||= []);
949        }
950        push @{$G->{'__sort__'}}, 'Group' if @{ $group->{'groups'} || [] };
951        $rec->($_, $G->{'Group'} ||= []) for @{ $group->{'groups'} || []};
952    };
953    $groups = [{title => "Database", groups => [@$groups], notes => "Added as a top group by File::KeePass", expanded => 1}] if @$groups > 1;
954    $rec->($_, \@GROUPS) for @$groups;
955
956    if (@$groups && $groups->[0]->{'deleted_objects'}) {
957        foreach my $dob (@{ $groups->[0]->{'deleted_objects'} }) {
958            push @{ $data->{'Root'}->{'DeletedObjects'}->{'DeletedObject'} }, {
959                UUID => $self->encode_base64($dob->{'uuid'}),
960                DeletionTime => $self->_gen_v2_date($dob->{'date'}),
961            }
962        }
963    }
964
965    my $s20_stream = $self->salsa20_stream({key => sha256($head->{'protected_stream_key'}), iv => $salsa20_iv, rounds => 20});
966    for my $ref (@PROTECT_BIN, @PROTECT_STR) {
967        $$ref = $self->encode_base64($s20_stream->($$ref));
968    }
969
970    # gen the XML - use our own generator since XML::Simple does not do event based actions
971    $buffer = $self->gen_xml($data, {
972        top => 'KeePassFile',
973        indent => "\t",
974        declaration => '<?xml version="1.0" encoding="utf-8" standalone="yes"?>',
975        sort => {
976            AutoType => [qw(Enabled DataTransferObfuscation Association)],
977            Association => [qw(Window KeystrokeSequence)],
978            DeletedObject => [qw(UUID DeletionTime)],
979        },
980        no_trailing_newline => 1,
981    });
982    $self->{'xml_out'} = $buffer if $self->{'keep_xml'} || $head->{'keep_xml'};
983
984    $buffer = $self->compress($buffer) if $head->{'compression'} eq '1';
985    $buffer = $self->chunksum($buffer);
986
987    substr $buffer, 0, 0, $head->{'start_bytes'};
988
989    return $header . $self->encrypt_rijndael_cbc($buffer, $key, $head->{'enc_iv'});
990}
991
992sub _gen_v2_date {
993    my ($self, $date) = @_;
994    $date = $self->now($date) if !$date || $date =~ /^\d+$/;
995    my ($year, $mon, $day, $hour, $min, $sec) = $date =~ $qr_date ? ($1,$2,$3,$4,$5,$6) : die "Invalid date ($date)";
996    return "${year}-${mon}-${day}T${hour}:${min}:${sec}Z";
997}
998
999sub _gen_v2_header {
1000    my ($self, $head) = @_;
1001    $head->{'sig1'}        = DB_SIG_1;
1002    $head->{'sig2'}        = DB_SIG_2_v2;
1003    $head->{'ver'}         = DB_VER_DW_V2;
1004    $head->{'comment'}     = '' if ! defined $head->{'comment'};
1005    $head->{'compression'} = (!defined($head->{'compression'}) || $head->{'compression'} eq '1') ? 1 : 0;
1006    $head->{'0'}           ||= "\r\n\r\n";
1007    $head->{'protected_stream_key'} ||= join '', map {chr rand 256} 1..32;
1008    die "Missing start_bytes\n" if ! $head->{'start_bytes'};
1009    die "Length of $_ was not 32 (".length($head->{$_}).")\n" for grep {length($head->{$_}) != 32} qw(seed_rand seed_key protected_stream_key start_bytes);
1010    die "Length of enc_iv was not 16\n" if length($head->{'enc_iv'}) != 16;
1011
1012    my $buffer = pack 'L3', @$head{qw(sig1 sig2 ver)};
1013
1014    my $pack = sub { my ($type, $str) = @_; $buffer .= pack('C S', $type, length($str)) . $str };
1015    $pack->(1, $head->{'comment'}) if defined($head->{'comment'}) && length($head->{'comment'});
1016    $pack->(2, "\x31\xc1\xf2\xe6\xbf\x71\x43\x50\xbe\x58\x05\x21\x6a\xfc\x5a\xff"); # aes cipher
1017    $pack->(3, pack 'V', $head->{'compression'} ? 1 : 0);
1018    $pack->(4, $head->{'seed_rand'});
1019    $pack->(5, $head->{'seed_key'});
1020    $pack->(6, pack 'LL', $head->{'rounds'}, 0); # a little odd to be double the length but not used
1021    $pack->(7, $head->{'enc_iv'});
1022    $pack->(8, $head->{'protected_stream_key'});
1023    $pack->(9, $head->{'start_bytes'});
1024    $pack->(10, pack('V', 2)); # salsa20 protection
1025    $pack->(0, $head->{'0'});
1026    return $buffer;
1027}
1028
1029###----------------------------------------------------------------###
1030
1031sub slurp {
1032    my ($self, $file) = @_;
1033    open my $fh, '<', $file or die "Could not open $file: $!\n";
1034    my $size = -s $file || die "File $file appears to be empty.\n";
1035    binmode $fh;
1036    read($fh, my $buffer, $size);
1037    close $fh;
1038    die "Could not read entire file contents of $file.\n" if length($buffer) != $size;
1039    return $buffer;
1040}
1041
1042sub decrypt_rijndael_cbc {
1043    my ($self, $buffer, $key, $enc_iv) = @_;
1044    #use Crypt::CBC; return Crypt::CBC->new(-cipher => 'Rijndael', -key => $key, -iv => $enc_iv, -regenerate_key => 0, -prepend_iv => 0)->decrypt($buffer);
1045    my $cipher = Crypt::Rijndael->new($key, Crypt::Rijndael::MODE_CBC());
1046    $cipher->set_iv($enc_iv);
1047    $buffer = $cipher->decrypt($buffer);
1048    my $extra = ord(substr $buffer, -1, 1);
1049    substr($buffer, length($buffer) - $extra, $extra, '');
1050    return $buffer;
1051}
1052
1053sub encrypt_rijndael_cbc {
1054    my ($self, $buffer, $key, $enc_iv) = @_;
1055    #use Crypt::CBC; return Crypt::CBC->new(-cipher => 'Rijndael', -key => $key, -iv => $enc_iv, -regenerate_key => 0, -prepend_iv => 0)->encrypt($buffer);
1056    my $cipher = Crypt::Rijndael->new($key, Crypt::Rijndael::MODE_CBC());
1057    $cipher->set_iv($enc_iv);
1058    my $extra = (16 - length($buffer) % 16) || 16; # always pad so we can always trim
1059    $buffer .= chr($extra) for 1 .. $extra;
1060    return $cipher->encrypt($buffer);
1061}
1062
1063sub unchunksum {
1064    my ($self, $buffer) = @_;
1065    my ($new, $pos) = ('', 0);
1066    while ($pos < length($buffer)) {
1067        my ($index, $hash, $size) = unpack "\@$pos L a32 i", $buffer;
1068        $pos += 40;
1069        if ($size == 0) {
1070            warn "Found mismatch for 0 chunksize\n" if $hash ne "\0"x32;
1071            last;
1072        }
1073        #print "$index $hash $size\n";
1074        my $chunk = substr $buffer, $pos, $size;
1075        die "Chunk hash of index $index did not match\n" if $hash ne sha256($chunk);
1076        $pos += $size;
1077        $new .= $chunk;
1078    }
1079    return $new;
1080}
1081
1082sub chunksum {
1083    my ($self, $buffer) = @_;
1084    my $new;
1085    my $index = 0;
1086    my $chunk_size = 8192;
1087    my $pos = 0;
1088    while ($pos < length($buffer)) {
1089        my $chunk = substr($buffer, $pos, $chunk_size);
1090        $new .= pack "L a32 i", $index++, sha256($chunk), length($chunk);
1091        $new .= $chunk;
1092        $pos += length($chunk);
1093    }
1094    $new .= pack "L a32 i", $index++, "\0"x32, 0;
1095    return $new;
1096}
1097
1098sub decompress {
1099    my ($self, $buffer) = @_;
1100    eval { require Compress::Raw::Zlib } or die "Cannot load compression library to decompress database: $@";
1101    my ($i, $status) = Compress::Raw::Zlib::Inflate->new(-WindowBits => 31);
1102    die "Failed to initialize inflator ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
1103    $status = $i->inflate($buffer, my $out);
1104    die "Failed to uncompress buffer ($status)\n" if $status != Compress::Raw::Zlib::Z_STREAM_END();
1105    return $out;
1106}
1107
1108sub compress {
1109    my ($self, $buffer) = @_;
1110    eval { require Compress::Raw::Zlib } or die "Cannot load compression library to compress database: $@";
1111    my ($d, $status) = Compress::Raw::Zlib::Deflate->new(-WindowBits => 31, -AppendOutput => 1);
1112    die "Failed to initialize inflator ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
1113    $status = $d->deflate($buffer, my $out);
1114    die "Failed to compress buffer ($status)\n" if $status != Compress::Raw::Zlib::Z_OK();
1115    $status = $d->flush($out);
1116    die "Failed to compress buffer ($status).\n" if $status != Compress::Raw::Zlib::Z_OK();
1117    return $out;
1118}
1119
1120sub decode_base64 {
1121    my ($self, $content) = @_;
1122    eval { require MIME::Base64 } or die "Cannot load Base64 library to decode item: $@";
1123    return MIME::Base64::decode_base64($content);
1124}
1125
1126sub encode_base64 {
1127    my ($self, $content) = @_;
1128    eval { require MIME::Base64 } or die "Cannot load Base64 library to encode item: $@";
1129    ($content = MIME::Base64::encode_base64($content)) =~ s/\n//g;
1130    return $content;
1131}
1132
1133sub parse_xml {
1134    my ($self, $buffer, $args) = @_;
1135    eval { require XML::Parser } or die "Cannot load XML library to parse database: $@";
1136    my $top = $args->{'top'};
1137    my $force_array = $args->{'force_array'} || {};
1138    my $s_handlers  = $args->{'start_handlers'} || {};
1139    my $e_handlers  = $args->{'end_handlers'}   || $args->{'handlers'} || {};
1140    my $data;
1141    my $ptr;
1142    my $x = XML::Parser->new(Handlers => {
1143        Start => sub {
1144            my ($x, $tag, %attr) = @_; # loses multiple values of duplicately named attrs
1145            my $prev_ptr = $ptr;
1146            $top = $tag if !defined $top;
1147            if ($tag eq $top) {
1148                die "The $top tag should only be used at the top level.\n" if $ptr || $data;
1149                $ptr = $data = {};
1150            } elsif (exists($prev_ptr->{$tag})  || ($force_array->{$tag} and $prev_ptr->{$tag} ||= [])) {
1151                $prev_ptr->{$tag} = [$prev_ptr->{$tag}] if 'ARRAY' ne ref $prev_ptr->{$tag};
1152                push @{ $prev_ptr->{$tag} }, ($ptr = {});
1153            } else {
1154                $ptr = $prev_ptr->{$tag} ||= {};
1155            }
1156            @$ptr{keys %attr} = values %attr;
1157            $_->($ptr, $prev_ptr, $prev_ptr->{'__tag__'}, $tag) if $_ = $s_handlers->{$tag} || $s_handlers->{'__any__'};
1158            @$ptr{qw(__parent__ __tag__)} = ($prev_ptr, $tag);
1159        },
1160        End => sub {
1161            my ($x, $tag) = @_;
1162            my $cur_ptr = $ptr;
1163            $ptr = delete $cur_ptr->{'__parent__'};
1164            die "End tag mismatch on $tag.\n" if $tag ne delete($cur_ptr->{'__tag__'});
1165            my $n_keys = scalar keys %$cur_ptr;
1166            if (!$n_keys) {
1167                $ptr->{$tag} = ''; # SuppressEmpty
1168            } elsif (exists $cur_ptr->{'content'}) {
1169                if ($n_keys == 1) {
1170                    if ($ptr->{$tag} eq 'ARRAY') {
1171                        $ptr->{$tag}->[-1] = $cur_ptr->{'content'};
1172                    } else {
1173                        $ptr->{$tag} = $cur_ptr->{'content'};
1174                    }
1175                } elsif ($cur_ptr->{'content'} !~ /\S/) {
1176                    delete $cur_ptr->{'content'};
1177                }
1178            }
1179            $_->($cur_ptr, $ptr, $ptr->{'__tag__'}, $tag) if $_ = $e_handlers->{$tag} || $e_handlers->{'__any__'};
1180        },
1181        Char => sub { if (defined $ptr->{'content'}) { $ptr->{'content'} .= $_[1] } else { $ptr->{'content'} = $_[1] } },
1182    });
1183    $x->parse($buffer);
1184    return $data;
1185}
1186
1187sub gen_xml {
1188    my ($self, $ref, $args) = @_;
1189    my $indent = !$args->{'indent'} ? '' : $args->{'indent'} eq "1" ? "  " : $args->{'indent'};
1190    my $level = 0;
1191    my $top = $args->{'top'} || 'root';
1192    my $xml = $args->{'declaration'} || '';
1193    $xml .= "\n" . ($indent x $level) if $xml && $indent;
1194    $xml .= "<$top>";
1195    my $rec; $rec = sub {
1196        $level++;
1197        my ($ref, $tag) = @_;
1198        my $n = 0;
1199        my $order = delete($ref->{'__sort__'}) || $args->{'sort'}->{$tag} || [sort grep {$_ ne '__attr__'} keys %$ref];
1200        for my $key (@$order) {
1201            next if ! exists $ref->{$key};
1202            for my $node (ref($ref->{$key}) eq 'ARRAY' ? @{ $ref->{$key} } : $ref->{$key}) {
1203                $n++;
1204                $xml .= "\n" . ($indent x $level) if $indent;
1205                if (!ref $node) {
1206                    $xml .= (!defined($node) || !length($node)) ? "<$key />" : "<$key>".$self->escape_xml($node)."</$key>";
1207                    next;
1208                }
1209                if ($node->{'__attr__'} || exists($node->{'content'})) {
1210                    $xml .= "<$key".join('', map {" $_=\"".$self->escape_xml($node->{$_})."\""} @{$node->{'__attr__'}||[sort grep {$_ ne 'content'} keys %$node]}).">";
1211                } else {
1212                    $xml .= "<$key>";
1213                }
1214                if (exists $node->{'content'}) {
1215                    if (defined($node->{'content'}) && length $node->{'content'}) {
1216                        $xml .= $self->escape_xml($node->{'content'}) . "</$key>";
1217                    } else {
1218                        $xml =~ s|(>\s*)$| /$1|;
1219                    }
1220                    next;
1221                }
1222                if ($rec->($node, $key)) {
1223                    $xml .= "\n" . ($indent x $level) if $indent;
1224                    $xml .= "</$key>";
1225                } else {
1226                    $xml =~ s|(>\s*)$| /$1|;
1227                }
1228            }
1229        }
1230        $level--;
1231        return $n;
1232    };
1233    $rec->($ref, $top);
1234    $xml .= "\n" . ($indent x $level) if $indent;
1235    $xml .= "</$top>";
1236    $xml .= "\n" if $indent && ! $args->{'no_trailing_newline'};
1237    return $xml;
1238}
1239
1240sub escape_xml {
1241    my $self = shift;
1242    local $_ = shift;
1243    return '' if ! defined;
1244    s/&/&amp;/g;
1245    s/</&lt;/g;
1246    s/>/&gt;/g;
1247    s/"/&quot;/g;
1248    s/([^\x00-\x7F])/'&#'.(ord $1).';'/ge;
1249    return $_;
1250}
1251
1252sub uuid {
1253    my ($self, $id, $uniq) = @_;
1254    $id = $self->gen_uuid if !defined($id) || !length($id);
1255    return $uniq->{$id} ||= do {
1256        if (length($id) != 16) {
1257            $id = substr($self->encode_base64($id), 0, 16) if $id !~ /^\d+$/ || $id > 2**32-1;
1258            $id = sprintf '%016s', $id if $id ne '0';
1259        }
1260        $id = $self->gen_uuid while $uniq->{$id}++;
1261        $id;
1262    };
1263}
1264
1265sub gen_uuid { shift->encode_base64(join '', map {chr rand 256} 1..12) } # (3072 bit vs 4096) only 8e28 entries vs 3e38 - but readable
1266
1267###----------------------------------------------------------------###
1268
1269sub dump_groups {
1270    my ($self, $args, $groups) = @_;
1271    my $t = '';
1272    my %gargs; for (keys %$args) { $gargs{$2} = $args->{$1} if /^(group_(.+))$/ };
1273    foreach my $g ($self->find_groups(\%gargs, $groups)) {
1274        my $indent = '    ' x $g->{'level'};
1275        $t .= $indent.($g->{'expanded'} ? '-' : '+')."  $g->{'title'} ($g->{'id'}) $g->{'created'}\n";
1276        local $g->{'groups'}; # don't recurse while looking for entries since we are already flat
1277        $t .= "$indent    > $_->{'title'}\t($_->{'id'}) $_->{'created'}\n" for $self->find_entries($args, [$g]);
1278    }
1279    return $t;
1280}
1281
1282sub add_group {
1283    my ($self, $args, $top_groups) = @_;
1284    $args = {%$args};
1285    my $groups;
1286    my $parent_group = delete $args->{'group'};
1287    if (defined $parent_group) {
1288        $parent_group = $self->find_group({id => $parent_group}, $top_groups) if ! ref($parent_group);
1289        $groups = $parent_group->{'groups'} ||= [] if $parent_group;
1290    }
1291    $groups ||= $top_groups || ($self->{'groups'} ||= []);
1292
1293    $args->{$_} = $self->now for grep {!defined $args->{$_}} qw(created accessed modified);;
1294    $args->{'expires'} ||= $self->default_exp;
1295
1296    push @$groups, $args;
1297    $self->find_groups({}, $groups); # sets title, level, icon and id
1298    return $args;
1299}
1300
1301sub finder_tests {
1302    my ($self, $args) = @_;
1303    my @tests;
1304    foreach my $key (keys %{ $args || {} }) {
1305        next if ! defined $args->{$key};
1306        my ($field, $op) = ($key =~ m{ ^ (\w+) \s* (|!|=|!~|=~|gt|lt) $ }x) ? ($1, $2) : die "Invalid find match criteria \"$key\"\n";
1307        push @tests,  (!$op || $op eq '=') ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} eq $args->{$key} }
1308                    : ($op eq '!')         ? sub { !defined($_[0]->{$field}) || $_[0]->{$field} ne $args->{$key} }
1309                    : ($op eq '=~')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} =~ $args->{$key} }
1310                    : ($op eq '!~')        ? sub { !defined($_[0]->{$field}) || $_[0]->{$field} !~ $args->{$key} }
1311                    : ($op eq 'gt')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} gt $args->{$key} }
1312                    : ($op eq 'lt')        ? sub {  defined($_[0]->{$field}) && $_[0]->{$field} lt $args->{$key} }
1313                    : die "Unknown op \"$op\"\n";
1314    }
1315    return @tests;
1316}
1317
1318sub find_groups {
1319    my ($self, $args, $groups, $level) = @_;
1320    my @tests = $self->finder_tests($args);
1321    my @groups;
1322    my %uniq;
1323    my $container = $groups || $self->groups;
1324    for my $g (@$container) {
1325        $g->{'level'} = $level || 0;
1326        $g->{'title'} = '' if ! defined $g->{'title'};
1327        $g->{'icon'}  ||= 0;
1328        if ($self->{'force_v2_gid'}) {
1329            $g->{'id'} = $self->uuid($g->{'id'}, \%uniq);
1330        } else {
1331            $g->{'id'} = int(rand 2**32-1) while !defined($g->{'id'}) || $uniq{$g->{'id'}}++; # the non-v2 gid is compatible with both v1 and our v2 implementation
1332        }
1333
1334        if (!@tests || !grep{!$_->($g)} @tests) {
1335            push @groups, $g;
1336            push @{ $self->{'__group_groups'} }, $container if $self->{'__group_groups'};
1337        }
1338        push @groups, $self->find_groups($args, $g->{'groups'}, $g->{'level'} + 1) if $g->{'groups'};
1339    }
1340    return @groups;
1341}
1342
1343sub find_group {
1344    my $self = shift;
1345    local $self->{'__group_groups'} = [] if wantarray;
1346    my @g = $self->find_groups(@_);
1347    die "Found too many groups (@g)\n" if @g > 1;
1348    return wantarray ? ($g[0], $self->{'__group_groups'}->[0]) : $g[0];
1349}
1350
1351sub delete_group {
1352    my $self = shift;
1353    my ($g, $c) = $self->find_group(@_);
1354    return if !$g || !$c;
1355    for my $i (0 .. $#$c) {
1356        next if $c->[$i] ne $g;
1357        splice(@$c, $i, 1, ());
1358        last;
1359    }
1360    return $g;
1361}
1362
1363###----------------------------------------------------------------###
1364
1365sub add_entry {
1366    my ($self, $args, $groups) = @_;
1367    $groups ||= eval { $self->groups } || [];
1368    die "You must unlock the passwords before adding new entries.\n" if $self->is_locked($groups);
1369    $args = {%$args};
1370    my $group = delete($args->{'group'}) || $groups->[0] || $self->add_group({});
1371    if (! ref($group)) {
1372        $group = $self->find_group({id => $group}, $groups) || die "Could not find a matching group to add entry to.\n";
1373    }
1374
1375    my %uniq;
1376    foreach my $g ($self->find_groups({}, $groups)) {
1377        $uniq{$_->{'id'}}++ for @{ $g->{'entries'} || [] };
1378    }
1379    $args->{'id'} = $self->uuid($args->{'id'}, \%uniq);
1380    $args->{$_} = ''         for grep {!defined $args->{$_}} qw(title url username password comment);
1381    $args->{$_} = 0          for grep {!defined $args->{$_}} qw(icon);
1382    $args->{$_} = $self->now for grep {!defined $args->{$_}} qw(created accessed modified);
1383    $args->{'expires'} ||= $self->default_exp;
1384    $self->_check_v1_binary($args);
1385    $self->_check_v1_auto_type($args);
1386
1387
1388    push @{ $group->{'entries'} ||= [] }, $args;
1389    return $args;
1390}
1391
1392sub find_entries {
1393    my ($self, $args, $groups) = @_;
1394    local @{ $args }{'expires gt', 'active'} = ($self->now, undef) if $args->{'active'};
1395    my @tests = $self->finder_tests($args);
1396    my @entries;
1397    foreach my $g ($self->find_groups({}, $groups)) {
1398        foreach my $e (@{ $g->{'entries'} || [] }) {
1399            local $e->{'group_id'}    = $g->{'id'};
1400            local $e->{'group_title'} = $g->{'title'};
1401            if (!@tests || !grep{!$_->($e)} @tests) {
1402                push @entries, $e;
1403                push @{ $self->{'__entry_groups'} }, $g if $self->{'__entry_groups'};
1404            }
1405        }
1406    }
1407    return @entries;
1408}
1409
1410sub find_entry {
1411    my $self = shift;
1412    local $self->{'__entry_groups'} = [] if wantarray;
1413    my @e = $self->find_entries(@_);
1414    die "Found too many entries (@e)\n" if @e > 1;
1415    return wantarray ? ($e[0], $self->{'__entry_groups'}->[0]) : $e[0];
1416}
1417
1418sub delete_entry {
1419    my $self = shift;
1420    my ($e, $g) = $self->find_entry(@_);
1421    return if !$e || !$g;
1422    for my $i (0 .. $#{ $g->{'entries'} || [] }) {
1423        next if $g->{'entries'}->[$i] ne $e;
1424        splice(@{ $g->{'entries'} }, $i, 1, ());
1425        last;
1426    }
1427    return $e;
1428}
1429
1430sub now {
1431    my ($self, $time) = @_;
1432    my ($sec, $min, $hour, $day, $mon, $year) = localtime($time || time);
1433    return sprintf '%04d-%02d-%02d %02d:%02d:%02d', $year+1900, $mon+1, $day, $hour, $min, $sec;
1434}
1435
1436sub default_exp { shift->{'default_exp'} || '2999-12-31 23:23:59' }
1437
1438###----------------------------------------------------------------###
1439
1440sub is_locked {
1441    my $self = shift;
1442    my $groups = shift || $self->groups;
1443    return $locker{"$groups"} ? 1 : 0;
1444}
1445
1446sub lock {
1447    my $self = shift;
1448    my $groups = shift || $self->groups;
1449    return 2 if $locker{"$groups"}; # not quite as fast as Scalar::Util::refaddr
1450
1451    my $ref = $locker{"$groups"} = {};
1452    $ref->{'_key'}    = join '', map {chr rand 256} 1..32;
1453    $ref->{'_enc_iv'} = join '', map {chr rand 256} 1..16;
1454
1455    foreach my $e ($self->find_entries({}, $groups)) {
1456        my $pass = delete $e->{'password'}; $pass = '' if ! defined $pass;
1457        $ref->{"$e"} = $self->encrypt_rijndael_cbc($pass, $ref->{'_key'}, $ref->{'_enc_iv'}); # we don't leave plaintext in memory
1458    }
1459
1460    return 1;
1461}
1462
1463sub unlock {
1464    my $self = shift;
1465    my $groups = shift || $self->groups;
1466    return 2 if !$locker{"$groups"};
1467    my $ref = $locker{"$groups"};
1468    foreach my $e ($self->find_entries({}, $groups)) {
1469        my $pass = $ref->{"$e"};
1470        $pass = eval { $self->decrypt_rijndael_cbc($pass, $ref->{'_key'}, $ref->{'_enc_iv'}) } if $pass;
1471        $pass = '' if ! defined $pass;
1472        $e->{'password'} = $pass;
1473    }
1474    delete $locker{"$groups"};
1475    return 1;
1476}
1477
1478sub locked_entry_password {
1479    my $self = shift;
1480    my $entry = shift;
1481    my $groups = shift || $self->groups;
1482    my $ref = $locker{"$groups"} || die "Passwords are not locked\n";
1483    $entry = $self->find_entry({id => $entry}, $groups) if ! ref $entry;
1484    return if ! $entry;
1485    my $pass = $ref->{"$entry"};
1486    $pass = eval { $self->decrypt_rijndael_cbc($pass, $ref->{'_key'}, $ref->{'_enc_iv'}) } if $pass;
1487    $pass = '' if ! defined $pass;
1488    $entry->{'accessed'} = $self->now;
1489    return $pass;
1490}
1491
1492###----------------------------------------------------------------###
1493
1494sub salsa20_stream {
1495    my ($self, $args) = @_;
1496    delete $args->{'data'};
1497    my $salsa20 = $self->salsa20($args);
1498    my $buffer = '';
1499    return sub {
1500        my $enc = shift;
1501        $buffer .= $salsa20->("\0" x 64) while length($buffer) < length($enc);
1502        my $data = join '', map {chr(ord(substr $enc, $_, 1) ^ ord(substr $buffer, $_, 1))} 0 .. length($enc)-1;
1503        substr $buffer, 0, length($enc), '';
1504        return $data;
1505    };
1506}
1507
1508
1509sub salsa20 { # http://cr.yp.to/snuffle/salsa20/regs/salsa20.c
1510    my ($self, $args) = @_;
1511    my ($key, $iv, $rounds) = @$args{qw(key iv rounds)};
1512    $rounds ||= 20;
1513
1514    my (@k, @c);
1515    if (32 == length $key) {
1516        @k = unpack 'L8', $key;
1517        @c = (0x61707865, 0x3320646e, 0x79622d32, 0x6b206574); # SIGMA
1518    } elsif (16 == length $key) {
1519        @k = unpack 'L8', $key x 2;
1520        @c = (0x61707865, 0x3120646e, 0x79622d36, 0x6b206574); # TAU
1521    } else {
1522        die "Salsa20 key length must be 16 or 32\n";
1523    }
1524    die "Salsa20 IV length must be 8\n" if length($iv) != 8;
1525    die "Salsa20 rounds must be 8, 12, or 20.\n" if !grep {$rounds != $_} 8, 12, 20;
1526    my @v = unpack('L2', $iv);
1527
1528    #            0                                  5      6      7            10                                 # 15
1529    my @state = ($c[0], $k[0], $k[1], $k[2], $k[3], $c[1], $v[0], $v[1], 0, 0, $c[2], $k[4], $k[5], $k[6], $k[7], $c[3]);
1530
1531    my $rotl32 = sub { return (($_[0] << $_[1]) | ($_[0] >> (32 - $_[1]))) & 0xffffffff };
1532    my $word_to_byte = sub {
1533        my @x = @state;
1534        for (1 .. $rounds/2) {
1535            $x[ 4] ^= $rotl32->(($x[ 0] + $x[12]) & 0xffffffff,  7);
1536            $x[ 8] ^= $rotl32->(($x[ 4] + $x[ 0]) & 0xffffffff,  9);
1537            $x[12] ^= $rotl32->(($x[ 8] + $x[ 4]) & 0xffffffff, 13);
1538            $x[ 0] ^= $rotl32->(($x[12] + $x[ 8]) & 0xffffffff, 18);
1539            $x[ 9] ^= $rotl32->(($x[ 5] + $x[ 1]) & 0xffffffff,  7);
1540            $x[13] ^= $rotl32->(($x[ 9] + $x[ 5]) & 0xffffffff,  9);
1541            $x[ 1] ^= $rotl32->(($x[13] + $x[ 9]) & 0xffffffff, 13);
1542            $x[ 5] ^= $rotl32->(($x[ 1] + $x[13]) & 0xffffffff, 18);
1543            $x[14] ^= $rotl32->(($x[10] + $x[ 6]) & 0xffffffff,  7);
1544            $x[ 2] ^= $rotl32->(($x[14] + $x[10]) & 0xffffffff,  9);
1545            $x[ 6] ^= $rotl32->(($x[ 2] + $x[14]) & 0xffffffff, 13);
1546            $x[10] ^= $rotl32->(($x[ 6] + $x[ 2]) & 0xffffffff, 18);
1547            $x[ 3] ^= $rotl32->(($x[15] + $x[11]) & 0xffffffff,  7);
1548            $x[ 7] ^= $rotl32->(($x[ 3] + $x[15]) & 0xffffffff,  9);
1549            $x[11] ^= $rotl32->(($x[ 7] + $x[ 3]) & 0xffffffff, 13);
1550            $x[15] ^= $rotl32->(($x[11] + $x[ 7]) & 0xffffffff, 18);
1551
1552            $x[ 1] ^= $rotl32->(($x[ 0] + $x[ 3]) & 0xffffffff,  7);
1553            $x[ 2] ^= $rotl32->(($x[ 1] + $x[ 0]) & 0xffffffff,  9);
1554            $x[ 3] ^= $rotl32->(($x[ 2] + $x[ 1]) & 0xffffffff, 13);
1555            $x[ 0] ^= $rotl32->(($x[ 3] + $x[ 2]) & 0xffffffff, 18);
1556            $x[ 6] ^= $rotl32->(($x[ 5] + $x[ 4]) & 0xffffffff,  7);
1557            $x[ 7] ^= $rotl32->(($x[ 6] + $x[ 5]) & 0xffffffff,  9);
1558            $x[ 4] ^= $rotl32->(($x[ 7] + $x[ 6]) & 0xffffffff, 13);
1559            $x[ 5] ^= $rotl32->(($x[ 4] + $x[ 7]) & 0xffffffff, 18);
1560            $x[11] ^= $rotl32->(($x[10] + $x[ 9]) & 0xffffffff,  7);
1561            $x[ 8] ^= $rotl32->(($x[11] + $x[10]) & 0xffffffff,  9);
1562            $x[ 9] ^= $rotl32->(($x[ 8] + $x[11]) & 0xffffffff, 13);
1563            $x[10] ^= $rotl32->(($x[ 9] + $x[ 8]) & 0xffffffff, 18);
1564            $x[12] ^= $rotl32->(($x[15] + $x[14]) & 0xffffffff,  7);
1565            $x[13] ^= $rotl32->(($x[12] + $x[15]) & 0xffffffff,  9);
1566            $x[14] ^= $rotl32->(($x[13] + $x[12]) & 0xffffffff, 13);
1567            $x[15] ^= $rotl32->(($x[14] + $x[13]) & 0xffffffff, 18);
1568        }
1569        return pack 'L16', map {($x[$_] + $state[$_]) & 0xffffffff} 0 .. 15;
1570    };
1571
1572    my $encoder = sub {
1573        my $enc = shift;
1574        my $out = '';
1575        while (length $enc) {
1576            my $stream = $word_to_byte->();
1577            $state[8] = ($state[8] + 1) & 0xffffffff;
1578            $state[9] = ($state[9] + 1) & 0xffffffff if $state[8] == 0;
1579            my $chunk = substr $enc, 0, 64, '';
1580            $out .= join '', map {chr(ord(substr $stream, $_, 1) ^ ord(substr $chunk, $_, 1))} 0 .. length($chunk)-1;
1581        }
1582        return $out;
1583    };
1584    return $encoder if !exists $args->{'data'};
1585    return $encoder->(defined($args->{'data'}) ? $args->{'data'} : '');
1586}
1587
1588###----------------------------------------------------------------###
1589
15901;
1591
1592__END__
1593
1594=head1 SYNOPSIS
1595
1596    use File::KeePass;
1597    use Data::Dumper qw(Dumper);
1598
1599    my $k = File::KeePass->new;
1600
1601    # read a version 1 or version 2 database
1602    $k->load_db($file, $master_pass); # errors die
1603
1604    print Dumper $k->header;
1605    print Dumper $k->groups; # passwords are locked
1606
1607    $k->unlock;
1608    print Dumper $k->groups; # passwords are now visible
1609
1610    $k->clear; # delete current db from memory
1611
1612
1613    my $group = $k->add_group({
1614        title => 'Foo',
1615    }); # root level group
1616    my $gid = $group->{'id'};
1617
1618    my $group = $k->find_group({id => $gid});
1619    # OR
1620    my $group = $k->find_group({title => 'Foo'});
1621
1622
1623    my $group2 = $k->add_group({
1624        title => 'Bar',
1625        group => $gid,
1626        # OR group => $group,
1627    }); # nested group
1628
1629
1630    my $e = $k->add_entry({
1631        title    => 'Something',
1632        username => 'someuser',
1633        password => 'somepass',
1634        group    => $gid,
1635        # OR group => $group,
1636    });
1637    my $eid = $e->{'id'};
1638
1639    my $e = $k->find_entry({id => $eid});
1640    # OR
1641    my $e = $k->find_entry({title => 'Something'});
1642
1643    $k->lock;
1644    print $e->{'password'}; # eq undef
1645    print $k->locked_entry_password($e); # eq 'somepass'
1646
1647    $k->unlock;
1648    print $e->{'password'}; # eq 'somepass'
1649
1650
1651    # save out a version 1 database
1652    $k->save_db("/some/file/location.kdb", $master_pass);
1653
1654    # save out a version 2 database
1655    $k->save_db("/some/file/location.kdbx", $master_pass);
1656
1657    # save out a version 1 database using a password and key file
1658    $k->save_db("/some/file/location.kdb", [$master_pass, $key_filename]);
1659
1660
1661    # read database from a file
1662    $k->parse_db($pass_db_string, $pass);
1663
1664    # generate a keepass version 1 database string
1665    my $pass_db_string = $k->gen_db($pass);
1666
1667    # generate a keepass version 2 database string
1668    my $pass_db_string = $k->gen_db($pass);
1669
1670
1671=head1 DESCRIPTION
1672
1673File::KeePass gives access to KeePass version 1 (kdb) and version 2
1674(kdbx) databases.
1675
1676The version 1 and version 2 databases are very different in
1677construction, but the majority of information overlaps and many
1678algorithms are similar.  File::KeePass attempts to iron out as many of
1679the differences.
1680
1681File::KeePass gives nearly raw data access.  There are a few utility
1682methods for manipulating groups and entries.  More advanced
1683manipulation can easily be layered on top by other modules.
1684
1685File::KeePass is only used for reading and writing databases and for
1686keeping passwords scrambled while in memory.  Programs dealing with UI
1687or using of auto-type features are the domain of other modules on
1688CPAN.  File::KeePass::Agent is one example.
1689
1690=head1 METHODS
1691
1692=over 4
1693
1694=item new
1695
1696Takes a hashref or hash of arguments.  Returns a new File::KeePass
1697object.  Any named arguments are added to self.
1698
1699=item load_db
1700
1701Takes a kdb filename, a master password, and an optional argument
1702hashref.  Returns the File::KeePass object on success (can be called
1703as a class method).  Errors die.  The resulting database can be
1704accessed via various methods including $k->groups.
1705
1706    my $k = File::KeePass->new;
1707    $k->load_db($file, $pwd);
1708
1709    my $k = File::KeePass->load_db($file, $pwd);
1710
1711    my $k = File::KeePass->load_db($file, $pwd, {auto_lock => 0});
1712
1713The contents are read from file and passed to parse_db.
1714
1715The password passed to load_db may be a composite key in
1716any of the following forms:
1717
1718    "password"                   # password only
1719    ["password"]                 # same
1720    ["password", "keyfilename"]  # password and key file
1721    [undef, "keyfilename"]       # key file only
1722    ["password", \"keycontent"]  # password and reference to key file content
1723    [undef, \"keycontent"]       # reference to key file content only
1724
1725The key file is optional.  It may be passed as a filename, or as a
1726scalar reference to the contents of the key file.  If a filename is
1727passed it will be read in.  The key file can contain any of the
1728following three types:
1729
1730    length 32         # treated as raw key
1731    length 64         # must be 64 hexidecimal characters
1732    any-other-length  # a SHA256 sum will be taken of the data
1733
1734=item save_db
1735
1736Takes a kdb filename and a master password.  Stores out the current
1737groups in the object.  Writes attempt to write first to
1738$file.new.$epoch and are then renamed into the correct location.
1739
1740You will need to unlock the db via $k->unlock before calling this
1741method if the database is currently locked.
1742
1743The same master password types passed to load_db can be used here.
1744
1745=item parse_db
1746
1747Takes a string or a reference to a string containting an encrypted kdb
1748database, a master password, and an optional argument hashref.
1749Returns the File::KeePass object on success (can be called as a class
1750method).  Errors die.  The resulting database can be accessed via
1751various methods including $k->groups.
1752
1753    my $k = File::KeePass->new;
1754    $k->parse_db($loaded_kdb, $pwd);
1755
1756    my $k = File::KeePass->parse_db($kdb_buffer, $pwd);
1757
1758    my $k = File::KeePass->parse_db($kdb_buffer, $pwd, {auto_lock => 0});
1759
1760The same master password types passed to load_db can be used here.
1761
1762=item parse_header
1763
1764Used by parse_db.  Reads just the header information.  Can be used as
1765a basic KeePass file check.  The returned hash will contain version =>
17661 or version => 2 depending upon which type of header is found.  Can
1767be called as a class method.
1768
1769    my $head = File::KeePass->parse_header($kdb_buffer); # errors die
1770    printf "This is a version %d database\n", $head->{'version'};
1771
1772=item gen_db
1773
1774Takes a master password.  Optionally takes a "groups" arrayref and a
1775"headers" hashref.  If groups are not passed, it defaults to using the
1776currently loaded groups.  If headers are not passed, a fresh set of
1777headers are generated based on the groups and the master password.
1778The headers can be passed in to test round trip portability.
1779
1780You will need to unlock the db via $k->unlock before calling this
1781method if the database is currently locked.
1782
1783The same master password types passed to load_db can be used here.
1784
1785=item header
1786
1787Returns a hashref representing the combined current header and meta
1788information for the currently loaded database.
1789
1790The following fields are present in both version 1 and version 2
1791style databases (from the header):
1792
1793    enc_iv               => "123456789123456", # rand
1794    enc_type             => "rijndael",
1795    header_size          => 222,
1796    seed_key             => "1234567890123456", # rand (32 bytes on v2)
1797    seed_rand            => "12345678901234567890123456789012", # rand
1798    rounds               => 6000,
1799    sig1                 => "2594363651",
1800    sig2                 => "3041655655", # indicates db version
1801    ver                  => 196608,
1802    version              => 1, # or 2
1803
1804The following keys will be present after the reading of a version 2
1805database (from the header):
1806
1807    cipher               => "aes",
1808    compression          => 1,
1809    protected_stream     => "salsa20",
1810    protected_stream_key => "12345678901234567890123456789012", # rand
1811    start_bytes          => "12345678901234567890123456789012", # rand
1812
1813Additionally, items parsed from the Meta section of a version 2
1814database will be added.  The following are the available fields.
1815
1816    color                         => "#4FFF00",
1817    custom_data                   => {key1 => "val1"},
1818    database_description          => "database desc",
1819    database_description_changed  => "2012-08-17 00:30:56",
1820    database_name                 => "database name",
1821    database_name_changed         => "2012-08-17 00:30:56",
1822    default_user_name             => "",
1823    default_user_name_changed     => "2012-08-17 00:30:34",
1824    entry_templates_group         => "VL5nOpzlFUevGhqL71/OTA==",
1825    entry_templates_group_changed => "2012-08-21 14:05:32",
1826    generator                     => "KeePass",
1827    history_max_items             => 10,
1828    history_max_size              => 6291456, # bytes
1829    last_selected_group           => "SUgL30QQqUK3tOWuNKUYJA==",
1830    last_top_visible_group        => "dC1sQ1NO80W7klmRhfEUVw==",
1831    maintenance_history_days      => 365,
1832    master_key_change_force       => -1,
1833    master_key_change_rec         => -1,
1834    master_key_changed            => "2012-08-17 00:30:34",
1835    protect_notes                 => 0,
1836    protect_password              => 1,
1837    protect_title                 => 0,
1838    protect_url                   => 0,
1839    protect_username              => 0
1840    recycle_bin_changed           => "2012-08-17 00:30:34",
1841    recycle_bin_enabled           => 1,
1842    recycle_bin_uuid              => "SUgL30QQqUK3tOWuNKUYJA=="
1843
1844When writing a database via either save_db or gen_db, these
1845fields can be set and passed along.  Optionally, it is possible
1846to pass along a key called reuse_header to let calls to save_db
1847and gen_db automatically use the contents of the previous header.
1848
1849=item clear
1850
1851Clears any currently loaded database.
1852
1853=item auto_lock
1854
1855Default true.  If true, passwords are automatically hidden when a
1856database loaded via parse_db or load_db.
1857
1858    $k->auto_lock(0); # turn off auto locking
1859
1860=item is_locked
1861
1862Returns true if the current database is locked.
1863
1864=item lock
1865
1866Locks the database.  This moves all passwords into a protected, in
1867memory, encrypted storage location.  Returns 1 on success.  Returns 2
1868if the db is already locked.  If a database is loaded via parse_db or
1869load_db and auto_lock is true, the newly loaded database will start
1870out locked.
1871
1872=item unlock
1873
1874Unlocks a previously locked database.  You will need to unlock a
1875database before calling save_db or gen_db.
1876
1877=back
1878
1879=head1 GROUP/ENTRY METHODS
1880
1881=over 4
1882
1883=item dump_groups
1884
1885Returns a simplified string representation of the currently loaded
1886database.
1887
1888    print $k->dump_groups;
1889
1890You can optionally pass a match argument hashref.  Only entries
1891matching the criteria will be returned.
1892
1893=item groups
1894
1895Returns an arrayref of groups from the currently loaded database.
1896Groups returned will be hierarchal.  Note, groups simply returns a
1897reference to all of the data.  It makes no attempts at cleaning up the
1898data (find_groups will make sure the data is groomed).
1899
1900    my $g = $k->groups;
1901
1902Groups will look similar to the following:
1903
1904    $g = [{
1905         expanded => 0,
1906         icon     => 0,
1907         id       => 234234234, # under v1 this is a 32 bit int, under v2 it is a 16 char id
1908         title    => 'Foo',
1909         level    => 0,
1910         entries => [{
1911             accessed => "2010-06-24 15:09:19",
1912             comment  => "",
1913             created  => "2010-06-24 15:09:19",
1914             expires  => "2999-12-31 23:23:59",
1915             icon     => 0,
1916             modified => "2010-06-24 15:09:19",
1917             title    => "Something",
1918             password => 'somepass', # will be hidden if the database is locked
1919             url      => "",
1920             username => "someuser",
1921             id       => "0a55ac30af68149f", # v1 is any hex char, v2 is any 16 char
1922         }],
1923         groups => [{
1924             expanded => 0,
1925             icon     => 0,
1926             id       => 994414667,
1927             level    => 1,
1928             title    => "Bar"
1929         }],
1930     }];
1931
1932=item add_group
1933
1934Adds a new group to the database.  Returns a reference to the new
1935group.  If a database isn't loaded, it begins a new one.  Takes a
1936hashref of arguments for the new entry including title, icon,
1937expanded.  A new random group id will be generated.  An optional group
1938argument can be passed.  If a group is passed the new group will be
1939added under that parent group.
1940
1941    my $group = $k->add_group({title => 'Foo'});
1942    my $gid = $group->{'id'};
1943
1944    my $group2 = $k->add_group({title => 'Bar', group => $gid});
1945
1946The group argument's value may also be a reference to a group - such as
1947that returned by find_group.
1948
1949=item finder_tests {
1950
1951Used by find_groups and find_entries.  Takes a hashref of arguments
1952and returns a list of test code refs.
1953
1954    {title => 'Foo'} # will check if title equals Foo
1955    {'title !' => 'Foo'} # will check if title does not equal Foo
1956    {'title =~' => qr{^Foo$}} # will check if title does matches the regex
1957    {'title !~' => qr{^Foo$}} # will check if title does not match the regex
1958
1959=item find_groups
1960
1961Takes a hashref of search criteria and returns all matching groups.
1962Can be passed id, title, icon, and level.  Search arguments will be
1963parsed by finder_tests.
1964
1965    my @groups = $k->find_groups({title => 'Foo'});
1966
1967    my @all_groups_flattened = $k->find_groups({});
1968
1969The find_groups method also checks to make sure group ids are unique
1970and that all needed values are defined.
1971
1972=item find_group
1973
1974Calls find_groups and returns the first group found.  Dies if multiple
1975results are found.  In scalar context it returns only the group.  In
1976list context it returns the group, and its the arrayref in which it is
1977stored (either the root level group or a sub groups group item).
1978
1979=item delete_group
1980
1981Passes arguments to find_group to find the group to delete.  Then
1982deletes the group.  Returns the group that was just deleted.
1983
1984=item add_entry
1985
1986Adds a new entry to the database.  Returns a reference to the new
1987entry.  An optional group argument can be passed.  If a group is not
1988passed, the entry will be added to the first group in the database.  A
1989new entry id will be created if one is not passed or if it conflicts
1990with an existing group.
1991
1992The following fields can be passed to both v1 and v2 databases.
1993
1994    accessed => "2010-06-24 15:09:19", # last accessed date
1995    auto_type => [{keys => "{USERNAME}{TAB}{PASSWORD}{ENTER}", window => "Foo*"}],
1996    binary   => {foo => 'content'}; # hashref of filename/content pairs
1997    comment  => "", # a comment for the system - auto-type info is normally here
1998    created  => "2010-06-24 15:09:19", # entry creation date
1999    expires  => "2999-12-31 23:23:59", # date entry expires
2000    icon     => 0, # icon number for use with agents
2001    modified => "2010-06-24 15:09:19", # last modified
2002    title    => "Something",
2003    password => 'somepass', # will be hidden if the database is locked
2004    url      => "http://",
2005    username => "someuser",
2006    id       => "0a55ac30af68149f", # auto generated if needed, v1 is any hex char, v2 is any 16 char
2007    group    => $gid, # which group to add the entry to
2008
2009For compatibility with earlier versions of File::KeePass, it is
2010possible to pass in a binary and binary_name when creating an entry.
2011They will be automatically converted to the hashref of
2012filename/content pairs
2013
2014    binary_name => "foo", # description of the stored binary - typically a filename
2015    binary   => "content", # raw data to be stored in the system - typically a file
2016
2017    # results in
2018    binary => {"foo" => "content"}
2019
2020Typically, version 1 databases store their Auto-Type information
2021inside of the comment.  They are also limited to having only one key
2022sequence per entry.  File::KeePass 2+ will automatically parse
2023Auto-Type values passed in the entry comment and store them out as the
2024auto_type arrayref.  This arrayref is serialized back into the comment
2025section when saving as a version 1 database.  Version 2 databases have
2026a separate storage mechanism for Auto-Type.
2027
2028    If you passed in:
2029    comment => "
2030       Auto-Type: {USERNAME}{TAB}{PASSWORD}{ENTER}
2031       Auto-Type-Window: Foo*
2032       Auto-Type-Window: Bar*
2033    ",
2034
2035    Will result in:
2036    auto_type => [{
2037        keys => "{USERNAME}{TAB}{PASSWORD}{ENTER}",
2038        window => "Foo*"
2039     }, {
2040        keys => "{USERNAME}{TAB}{PASSWORD}{ENTER}",
2041        window => "Bar*"
2042     }],
2043
2044The group argument value may be either an existing group id, or a
2045reference to a group - such as that returned by find_group.
2046
2047When using a version 2 database, the following additional fields are
2048also available:
2049
2050    expires_enabled   => 0,
2051    location_changed  => "2012-08-05 12:12:12",
2052    usage_count       => 0,
2053    tags              => {},
2054    background_color  => '#ff0000',
2055    foreground_color  => '#ffffff',
2056    custom_icon_uuid  => '234242342aa',
2057    history           => [], # arrayref of previous entry changes
2058    override_url      => $node->{'OverrideURL'},
2059    auto_type_enabled => 1,
2060    auto_type_munge   => 0, # whether or not to attempt two channel auto typing
2061    protected         => {password => 1}, # indicating which strings were/should be salsa20 protected
2062    strings           => {'other key' => 'other value'},
2063
2064=item find_entries
2065
2066Takes a hashref of search criteria and returns all matching groups.
2067Can be passed an entry id, title, username, comment, url, active,
2068group_id, group_title, or any other entry property.  Search arguments
2069will be parsed by finder_tests.
2070
2071    my @entries = $k->find_entries({title => 'Something'});
2072
2073    my @all_entries_flattened = $k->find_entries({});
2074
2075=item find_entry
2076
2077Calls find_entries and returns the first entry found.  Dies if
2078multiple results are found.  In scalar context it returns only the
2079entry.  In list context it returns the entry, and its group.
2080
2081=item delete_entry
2082
2083Passes arguments to find_entry to find the entry to delete.  Then
2084deletes the entry.  Returns the entry that was just deleted.
2085
2086=item locked_entry_password
2087
2088Allows access to individual passwords for a database that is locked.
2089Dies if the database is not locked.
2090
2091=back
2092
2093=head1 UTILITY METHODS
2094
2095The following methods are general purpose methods used during the
2096parsing and generating of kdb databases.
2097
2098=over 4
2099
2100=item now
2101
2102Returns the current localtime datetime stamp.
2103
2104=item default_exp
2105
2106Returns the string representing the default expires time of an entry.
2107Will use $self->{'default_exp'} or fails to the string '2999-12-31
210823:23:59'.
2109
2110=item decrypt_rijndael_cbc
2111
2112Takes an encrypted string, a key, and an encryption_iv string.
2113Returns a plaintext string.
2114
2115=item encrypt_rijndael_cbc
2116
2117Takes a plaintext string, a key, and an encryption_iv string.  Returns
2118an encrypted string.
2119
2120=item decode_base64
2121
2122Loads the MIME::Base64 library and decodes the passed string.
2123
2124=item encode_base64
2125
2126Loads the MIME::Base64 library and encodes the passed string.
2127
2128=item unchunksum
2129
2130Parses and reassembles a buffer, reading in lengths, and checksums
2131of chunks.
2132
2133=item decompress
2134
2135Loads the Compress::Raw::Zlib library and inflates the contents.
2136
2137=item compress
2138
2139Loads the Compress::Raw::Zlib library and deflates the contents.
2140
2141=item parse_xml
2142
2143Loads the XML::Parser library and sets up a basic parser that can call
2144hooks at various events.  Without the hooks, it runs similarly to
2145XML::Simple::parse.
2146
2147    my $data = $self->parse_xml($buffer, {
2148        top            => 'KeePassFile',
2149        force_array    => {Group => 1, Entry => 1},
2150        start_handlers => {Group => sub { $level++ }},
2151        end_handlers   => {Group => sub { $level-- }},
2152    });
2153
2154=item gen_xml
2155
2156Generates XML from the passed data structure.  The output of parse_xml
2157can be passed as is.  Additionally hints such as __sort__ can be used
2158to order the tags of a node and __attr__ can be used to indicate which
2159items of a node are attributes.
2160
2161=item salsa20
2162
2163Takes a hashref containing a salsa20 key string (length 32 or 16), a
2164salsa20 iv string (length 8), number of salsa20 rounds (8, 12, or 20 -
2165default 20), and an optional data string.  The key and iv are used to
2166initialize the salsa20 encryption.
2167
2168If a data string is passed, the string is salsa20 encrypted and
2169returned.
2170
2171If no data string is passed a salsa20 encrypting coderef is returned.
2172
2173    my $encoded = $self->salsa20({key => $key, iv => $iv, data => $data});
2174    my $uncoded = $self->salsa20({key => $key, iv => $iv, data => $encoded});
2175    # $data eq $uncoded
2176
2177    my $encoder = $self->salsa20({key => $key, iv => $Iv}); # no data
2178    my $encoded = $encoder->($data);
2179    my $part2   = $encoder->($more_data); # continues from previous state
2180
2181=item salsa20_stream
2182
2183Takes a hashref that will be passed to salsa20.  Uses the resulting
2184encoder to generate a more continuous encoded stream.  The salsa20
2185method encodes in chunks of 64 bytes.  If a string is not a multiple
2186of 64, then some of the xor bytes are unused.  The salsa20_stream
2187method maintains a buffer of xor bytes to ensure that none are wasted.
2188
2189    my $encoder = $self->salsa20_stream({key => $key, iv => $Iv}); # no data
2190    my $encoded = $encoder->("1234");   # calls salsa20->()
2191    my $part2   = $encoder->("1234");   # uses the same pad until 64 bytes are used
2192
2193=back
2194
2195=head1 OTHER METHODS
2196
2197=over 4
2198
2199=item _parse_v1_header
2200
2201=item _parse_v1_body
2202
2203=item _parse_v1_groups
2204
2205=item _parse_v1_entries
2206
2207=item _parse_v1_date
2208
2209Utilities used for parsing version 1 type databases.
2210
2211=item _parse_v2_header
2212
2213=item _parse_v2_body
2214
2215=item _parse_v2_date
2216
2217Utilities used for parsing version 2 type databases.
2218
2219=item _gen_v1_db
2220
2221=item _gen_v1_header
2222
2223=item _gen_v1_date
2224
2225Utilities used to generate version 1 type databases.
2226
2227=item _gen_v2_db
2228
2229=item _gen_v2_header
2230
2231=item _gen_v2_date
2232
2233Utilities used to generate version 2 type databases.
2234
2235=item _master_key
2236
2237Takes the password and parsed headers.  Returns the
2238master key based on database type.
2239
2240=back
2241
2242=head1 ONE LINERS
2243
2244(Long one liners)
2245
2246Here is a version 1 to version 2, or version 2 to version 1 converter.
2247Simply change the extension of the two files.  Someday we will include
2248a kdb2kdbx utility to do this for you.
2249
2250    perl -MFile::KeePass -e 'use IO::Prompt; $p="".prompt("Pass:",-e=>"*",-tty); File::KeePass->load_db(+shift,$p,{auto_lock=>0})->save_db(+shift,$p)' ~/test.kdb ~/test.kdbx
2251
2252    # OR using graphical prompt
2253    perl -MFile::KeePass -e 'chop($p=`zenity --password`); File::KeePass->load_db(+shift,$p,{auto_lock=>0})->save_db(+shift,$p)' ~/test.kdbx ~/test.kdb
2254
2255    # OR using pure perl (but echoes password)
2256    perl -MFile::KeePass -e 'print "Pass:"; chop($p=<STDIN>); File::KeePass->load_db(+shift,$p,{auto_lock=>0})->save_db(+shift,$p)' ~/test.kdbx ~/test.kdb
2257
2258Dumping the XML from a version 2 database.
2259
2260    perl -MFile::KeePass -e 'chop($p=`zenity --password`); print File::KeePass->load_db(+shift,$p,{keep_xml=>1})->{xml_in},"\n"' ~/test.kdbx
2261
2262Outlining group information.
2263
2264    perl -MFile::KeePass -e 'chop($p=`zenity --password`); print File::KeePass->load_db(+shift,$p)->dump_groups' ~/test.kdbx
2265
2266Dumping header information
2267
2268    perl -MFile::KeePass -MData::Dumper -e 'chop($p=`zenity --password`); print Dumper +File::KeePass->load_db(+shift,$p)->header' ~/test.kdbx
2269
2270=head1 BUGS
2271
2272Only Rijndael is supported when using v1 databases.
2273
2274This module makes no attempt to act as a password agent.  That is the
2275job of File::KeePass::Agent.  This isn't really a bug but some people
2276will think it is.
2277
2278Groups and entries don't have true objects associated with them.  At
2279the moment this is by design.  The data is kept as plain boring data.
2280
2281=head1 SOURCES
2282
2283Knowledge about the algorithms necessary to decode a KeePass DB v1
2284format was gleaned from the source code of keepassx-0.4.3.  That
2285source code is published under the GPL2 license.  KeePassX 0.4.3 bears
2286the copyright of
2287
2288    Copyright (C) 2005-2008 Tarek Saidi <tarek.saidi@arcor.de>
2289    Copyright (C) 2007-2009 Felix Geyer <debfx-keepassx {at} fobos.de>
2290
2291Knowledge about the algorithms necessary to decode a KeePass DB v2
2292format was gleaned from the source code of keepassx-2.0-alpha1.  That
2293source code is published under the GPL2 or GPL3 license.  KeePassX
22942.0-alpha1 bears the copyright of
2295
2296    Copyright: 2010-2012, Felix Geyer <debfx@fobos.de>
2297               2011-2012, Florian Geyer <blueice@fobos.de>
2298
2299The salsa20 algorithm is based on
2300http://cr.yp.to/snuffle/salsa20/regs/salsa20.c which is listed as
2301Public domain (D. J. Bernstein).
2302
2303The ordering and layering of encryption/decryption algorithms of
2304File::KeePass are of derivative nature from KeePassX and could not
2305have been created without this insight - though the perl code is from
2306scratch.
2307
2308=head1 AUTHOR
2309
2310Paul Seamons <paul@seamons.com>
2311
2312=head1 LICENSE
2313
2314This module may be distributed under the same terms as Perl itself.
2315
2316=cut
2317