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/&/&/g; 1245 s/</</g; 1246 s/>/>/g; 1247 s/"/"/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