Annotation of palm/Palm-Keyring/lib/Palm/Keyring.pm, Revision 1.26
1.14 andrew 1: package Palm::Keyring;
2:
1.26 ! andrew 3: # $RedRiver: Keyring.pm,v 1.25 2007/02/03 01:12:21 andrew Exp $
1.1 andrew 4: #
1.14 andrew 5: # Perl class for dealing with Keyring for Palm OS databases.
1.1 andrew 6: #
7: # This started as Memo.pm, I just made it work for Keyring.
8:
9: use strict;
1.14 andrew 10: use warnings;
11: use Carp;
12:
13: use base qw/ Palm::StdAppInfo /;
1.1 andrew 14:
15: use Digest::MD5 qw(md5);
1.2 andrew 16: use Crypt::DES;
1.14 andrew 17:
1.24 andrew 18: my $ENCRYPT = 1;
19: my $DECRYPT = 0;
20: my $MD5_CBLOCK = 64;
21: my $kSalt_Size = 4;
22: my $EMPTY = q{};
23: my $SPACE = q{ };
24: my $NULL = chr 0;
1.14 andrew 25:
1.26 ! andrew 26: our $VERSION = 0.94;
1.1 andrew 27:
1.14 andrew 28: sub new {
29: my $classname = shift;
30: my $pass = shift;
1.1 andrew 31:
1.14 andrew 32: # Create a generic PDB. No need to rebless it, though.
33: my $self = $classname->SUPER::new(@_);
1.1 andrew 34:
1.14 andrew 35: $self->{'name'} = 'Keys-Gtkr'; # Default
36: $self->{'creator'} = 'Gtkr';
37: $self->{'type'} = 'Gkyr';
38:
39: # The PDB is not a resource database by
40: # default, but it's worth emphasizing,
41: # since MemoDB is explicitly not a PRC.
42: $self->{'attributes'}{'resource'} = 0;
1.1 andrew 43:
1.14 andrew 44: # Initialize the AppInfo block
45: $self->{'appinfo'} = {};
1.1 andrew 46:
1.14 andrew 47: # Add the standard AppInfo block stuff
48: Palm::StdAppInfo::seed_StdAppInfo( $self->{'appinfo'} );
1.1 andrew 49:
1.14 andrew 50: # Set the version
51: $self->{'version'} = 4;
1.1 andrew 52:
1.14 andrew 53: if ( defined $pass ) {
1.16 andrew 54: $self->Password($pass);
1.14 andrew 55: }
1.1 andrew 56:
1.14 andrew 57: return $self;
58: }
1.1 andrew 59:
1.14 andrew 60: sub import {
61: Palm::PDB::RegisterPDBHandlers( __PACKAGE__, [ 'Gtkr', 'Gkyr' ], );
62: return 1;
63: }
1.1 andrew 64:
1.16 andrew 65: sub ParseRecord {
1.14 andrew 66: my $self = shift;
67:
1.16 andrew 68: my $rec = $self->SUPER::ParseRecord(@_);
69:
70: # skip the 0 record that holds the password
71: return $rec if ! exists $self->{'records'};
72: return $rec if ! exists $rec->{'data'};
1.14 andrew 73:
1.16 andrew 74: my ( $name, $encrypted ) = split /$NULL/xm, $rec->{'data'}, 2;
1.1 andrew 75:
1.16 andrew 76: return $rec if ! $encrypted;
1.19 andrew 77: delete $rec->{'data'};
78: $rec->{'name'} = $name;
1.16 andrew 79: $rec->{'encrypted'} = $encrypted;
1.12 andrew 80:
1.16 andrew 81: return $rec;
1.14 andrew 82: }
1.11 andrew 83:
1.16 andrew 84: sub PackRecord {
85: my $self = shift;
86: my $rec = shift;
87:
1.23 andrew 88: if ($rec->{'encrypted'}) {
1.22 andrew 89: if (! defined $rec->{'name'}) {
90: $rec->{'name'} = $EMPTY;
91: }
1.19 andrew 92: $rec->{'data'} = join $NULL, $rec->{'name'}, $rec->{'encrypted'};
93: delete $rec->{'name'};
1.16 andrew 94: delete $rec->{'encrypted'};
95: }
1.1 andrew 96:
1.16 andrew 97: return $self->SUPER::PackRecord($rec, @_);
1.14 andrew 98: }
1.1 andrew 99:
1.14 andrew 100: sub Encrypt {
101: my $self = shift;
1.16 andrew 102: my $rec = shift;
103: my $data = shift;
104: my $pass = shift || $self->{'password'};
105:
106: if ( ! $pass) {
107: croak("'password' not set!\n");
108: }
109:
110: if ( ! $rec) {
111: croak("Needed parameter 'record' not passed!\n");
112: }
1.14 andrew 113:
1.16 andrew 114: if ( ! $data) {
115: croak("Needed parameter 'data' not passed!\n");
1.14 andrew 116: }
117:
1.16 andrew 118: if ( ! $self->Password($pass)) {
119: croak("Incorrect Password!\n");
120: }
1.14 andrew 121:
1.22 andrew 122: $self->{'digest'} ||= _calc_keys( $pass );
1.14 andrew 123:
1.16 andrew 124: $data->{'account'} ||= $EMPTY;
125: $data->{'password'} ||= $EMPTY;
126: $data->{'notes'} ||= $EMPTY;
1.1 andrew 127:
1.22 andrew 128: my $changed = 0;
129: my $need_newdate = 0;
130: my $acct = {};
131: if ($rec->{'encrypted'}) {
132: $acct = $self->Decrypt($rec, $pass);
133: foreach my $key (keys %{ $data }) {
134: next if $key eq 'lastchange';
135: if ($data->{$key} ne $acct->{$key}) {
136: $changed = 1;
137: last;
138: }
139: }
140: if ( exists $data->{'lastchange'} && exists $acct->{'lastchange'} && (
141: $data->{'lastchange'}->{day} != $acct->{'lastchange'}->{day} ||
142: $data->{'lastchange'}->{month} != $acct->{'lastchange'}->{month} ||
143: $data->{'lastchange'}->{year} != $acct->{'lastchange'}->{year}
144: )) {
145: $changed = 1;
146: $need_newdate = 0;
147: } else {
148: $need_newdate = 1;
149: }
150:
151: } else {
152: $changed = 1;
153: }
154:
155: # no need to re-encrypt if it has not changed.
156: return 1 if ! $changed;
157:
1.21 andrew 158: my ($day, $month, $year);
159:
1.22 andrew 160: if ($data->{'lastchange'} && ! $need_newdate ) {
161: $day = $data->{'lastchange'}->{'day'} || 1;
162: $month = $data->{'lastchange'}->{'month'} || 0;
163: $year = $data->{'lastchange'}->{'year'} || 0;
164:
165: # XXX Need to actually validate the above information somehow
166: if ($year >= 1900) {
167: $year -= 1900;
168: }
169: } else {
170: $need_newdate = 1;
171: }
172:
173: if ($need_newdate) {
1.21 andrew 174: ($day, $month, $year) = (localtime)[3,4,5];
175: }
1.22 andrew 176: $year -= 4;
177: $month++;
178:
1.19 andrew 179:
180: my $p = $day | ($month << 5) | ($year << 9);
181: my $packeddate = pack 'n', $p;
182:
1.16 andrew 183: my $plaintext = join $NULL,
1.19 andrew 184: $data->{'account'}, $data->{'password'}, $data->{'notes'}, $packeddate;
1.1 andrew 185:
1.16 andrew 186: my $encrypted = _crypt3des( $plaintext, $self->{'digest'}, $ENCRYPT );
1.11 andrew 187:
1.16 andrew 188: return if ! $encrypted;
1.1 andrew 189:
1.19 andrew 190: $rec->{'attributes'}{'Dirty'} = 1;
191: $rec->{'attributes'}{'dirty'} = 1;
192: $rec->{'name'} ||= $data->{'name'};
1.16 andrew 193: $rec->{'encrypted'} = $encrypted;
1.19 andrew 194:
1.14 andrew 195: return 1;
196: }
1.1 andrew 197:
1.14 andrew 198: sub Decrypt {
199: my $self = shift;
1.16 andrew 200: my $rec = shift;
201: my $pass = shift || $self->{'password'};
202:
203: if ( ! $pass) {
204: croak("'password' not set!\n");
205: }
206:
207: if ( ! $rec) {
1.19 andrew 208: croak("Needed parameter 'record' not passed!\n");
1.16 andrew 209: }
1.14 andrew 210:
1.16 andrew 211: if ( ! $self->Password($pass)) {
212: croak("Invalid Password!\n");
1.14 andrew 213: }
214:
1.16 andrew 215: if ( ! $rec->{'encrypted'} ) {
216: croak("No encrypted content!");
217: }
1.14 andrew 218:
1.16 andrew 219: $self->{'digest'} ||= _calc_keys( $pass );
1.14 andrew 220:
1.16 andrew 221: my $decrypted =
222: _crypt3des( $rec->{'encrypted'}, $self->{'digest'}, $DECRYPT );
1.19 andrew 223: my ( $account, $password, $notes, $packeddate ) = split /$NULL/xm,
1.16 andrew 224: $decrypted, 4;
1.14 andrew 225:
1.19 andrew 226: my %Modified;
227: if ($packeddate) {
228: my $u = unpack 'n', $packeddate;
229: my $year = (($u & 0xFE00) >> 9) + 4; # since 1900
230: my $month = (($u & 0x01E0) >> 5) - 1; # 0-11
231: my $day = (($u & 0x001F) >> 0); # 1-31
232:
233: %Modified = (
234: year => $year,
235: month => $month || 0,
236: day => $day || 1,
237: );
238: }
239:
1.16 andrew 240: return {
1.20 andrew 241: name => $rec->{'name'},
242: account => $account,
243: password => $password,
244: notes => $notes,
245: lastchange => \%Modified,
1.16 andrew 246: };
247: }
1.14 andrew 248:
1.16 andrew 249: sub Password {
250: my $self = shift;
1.24 andrew 251: my $pass = shift;
1.16 andrew 252: my $new_pass = shift;
1.14 andrew 253:
1.24 andrew 254: if (! $pass) {
255: delete $self->{password};
256: return 1;
257: }
258:
1.16 andrew 259: if (! exists $self->{'records'}) {
260: # Give the PDB the first record that will hold the encrypted password
261: $self->{'records'} = [ $self->new_Record ];
262:
263: return $self->_password_update($pass);
264: }
265:
266: if ($new_pass) {
267: my @accts = ();
268: foreach my $i (0..$#{ $self->{'records'} }) {
269: if ($i == 0) {
270: push @accts, undef;
271: next;
272: }
273: my $acct = $self->Decrypt($self->{'records'}->[$i], $pass);
274: if ( ! $acct ) {
1.19 andrew 275: croak("Couldn't decrypt $self->{'records'}->[$i]->{'name'}");
1.16 andrew 276: }
277: push @accts, $acct;
278: }
1.14 andrew 279:
1.16 andrew 280: if ( ! $self->_password_update($new_pass)) {
281: croak("Couldn't set new password!");
282: }
283: $pass = $new_pass;
1.1 andrew 284:
1.16 andrew 285: foreach my $i (0..$#accts) {
286: next if $i == 0;
1.22 andrew 287: delete $self->{'records'}->[$i]->{'encrypted'};
1.16 andrew 288: $self->Encrypt($self->{'records'}->[$i], $accts[$i], $pass);
289: }
1.14 andrew 290: }
1.1 andrew 291:
1.16 andrew 292: return $self->_password_verify($pass);
1.1 andrew 293: }
294:
1.14 andrew 295: sub _calc_keys {
296: my $pass = shift;
297: if (! defined $pass) { croak('No password defined!'); };
298:
299: my $digest = md5($pass);
300:
301: my ( $key1, $key2 ) = unpack 'a8a8', $digest;
302:
303: #--------------------------------------------------
304: # print "key1: $key1: ", length $key1, "\n";
305: # print "key2: $key2: ", length $key2, "\n";
306: #--------------------------------------------------
307:
308: $digest = unpack 'H*', $key1 . $key2 . $key1;
309:
310: #--------------------------------------------------
311: # print "Digest: ", $digest, "\n";
312: # print length $digest, "\n";
313: #--------------------------------------------------
314:
315: return $digest;
1.3 andrew 316: }
317:
1.16 andrew 318: sub _password_verify {
1.14 andrew 319: my $self = shift;
320: my $pass = shift;
321:
322: if (! $pass) { croak('No password specified!'); };
1.11 andrew 323:
1.16 andrew 324: if (defined $self->{'password'} && $pass eq $self->{'password'}) {
325: # already verified this password
326: return 1;
327: }
328:
1.14 andrew 329: # AFAIK the thing we use to test the password is
330: # always in the first entry
331: my $data = $self->{'records'}->[0]->{'data'};
1.11 andrew 332:
1.14 andrew 333: #die "No encrypted password in file!" unless defined $data;
1.16 andrew 334: if ( ! defined $data) { return; };
1.11 andrew 335:
1.14 andrew 336: $data =~ s/$NULL$//xm;
1.11 andrew 337:
1.14 andrew 338: my $salt = substr $data, 0, $kSalt_Size;
1.11 andrew 339:
1.14 andrew 340: my $msg = $salt . $pass;
1.11 andrew 341:
1.14 andrew 342: $msg .= "\0" x ( $MD5_CBLOCK - length $msg );
1.11 andrew 343:
1.14 andrew 344: my $digest = md5($msg);
1.11 andrew 345:
1.14 andrew 346: if ( $data eq $salt . $digest ) {
1.11 andrew 347:
1.14 andrew 348: # May as well generate the keys we need now, since we know the password is right
349: $self->{'digest'} = _calc_keys($pass);
350: if ( $self->{'digest'} ) {
351: $self->{'password'} = $pass;
352: return 1;
353: }
354: }
355: return;
1.6 andrew 356: }
357:
1.16 andrew 358: sub _password_update {
1.14 andrew 359:
360: # It is very important to Encrypt after calling this
361: # (Although it is generally only called by Encrypt)
362: # because otherwise the data will be out of sync with the
363: # password, and that would suck!
364: my $self = shift;
365: my $pass = shift;
366:
1.16 andrew 367: if (! defined $pass) { croak('No password specified!'); };
1.14 andrew 368:
369: my $salt;
370: for ( 1 .. $kSalt_Size ) {
371: $salt .= chr int rand 255;
372: }
373:
374: my $msg = $salt . $pass;
1.11 andrew 375:
1.14 andrew 376: $msg .= "\0" x ( $MD5_CBLOCK - length $msg );
1.11 andrew 377:
1.14 andrew 378: my $digest = md5($msg);
1.11 andrew 379:
1.14 andrew 380: my $data = $salt . $digest; # . "\0";
1.11 andrew 381:
1.14 andrew 382: # AFAIK the thing we use to test the password is
383: # always in the first entry
384: $self->{'records'}->[0]->{'data'} = $data;
1.11 andrew 385:
1.14 andrew 386: $self->{'password'} = $pass;
387: $self->{'digest'} = _calc_keys( $self->{'password'} );
1.11 andrew 388:
1.14 andrew 389: return 1;
1.1 andrew 390: }
391:
1.14 andrew 392: sub _crypt3des {
393: my ( $plaintext, $passphrase, $flag ) = @_;
394:
395: $passphrase .= $SPACE x ( 16 * 3 );
396: my $cyphertext = $EMPTY;
397:
398: my $size = length $plaintext;
1.11 andrew 399:
1.14 andrew 400: #print "STRING: '$plaintext' - Length: " . (length $plaintext) . "\n";
401:
402: my @C;
403: for ( 0 .. 2 ) {
404: $C[$_] =
405: new Crypt::DES( pack 'H*', ( substr $passphrase, 16 * $_, 16 ));
406: }
407:
408: for ( 0 .. ( ($size) / 8 ) ) {
409: my $pt = substr $plaintext, $_ * 8, 8;
410:
411: #print "PT: '$pt' - Length: " . length($pt) . "\n";
412: if (! length $pt) { next; };
413: if ( (length $pt) < 8 ) {
1.16 andrew 414: if ($flag == $DECRYPT) { croak('record not 8 byte padded'); };
1.14 andrew 415: my $len = 8 - (length $pt);
416:
417: #print "LENGTH: $len\n";
418: #print "Binary: '" . unpack("b*", $pt) . "'\n";
419: $pt .= ($NULL x $len);
420:
421: #print "PT: '$pt' - Length: " . length($pt) . "\n";
422: #print "Binary: '" . unpack("b*", $pt) . "'\n";
423: }
424: if ( $flag == $ENCRYPT ) {
425: $pt = $C[0]->encrypt($pt);
426: $pt = $C[1]->decrypt($pt);
427: $pt = $C[2]->encrypt($pt);
428: }
429: else {
430: $pt = $C[0]->decrypt($pt);
431: $pt = $C[1]->encrypt($pt);
432: $pt = $C[2]->decrypt($pt);
433: }
434:
435: #print "PT: '$pt' - Length: " . length($pt) . "\n";
436: $cyphertext .= $pt;
437: }
438:
439: $cyphertext =~ s/$NULL+$//xm;
1.11 andrew 440:
1.14 andrew 441: #print "CT: '$cyphertext' - Length: " . length($cyphertext) . "\n";
1.11 andrew 442:
1.14 andrew 443: return $cyphertext;
444: }
1.11 andrew 445:
1.14 andrew 446: 1;
447: __END__
1.11 andrew 448:
1.14 andrew 449: =head1 NAME
1.11 andrew 450:
1.14 andrew 451: Palm::Keyring - Handler for Palm Keyring databases.
1.1 andrew 452:
1.14 andrew 453: =head1 DESCRIPTION
1.7 andrew 454:
1.14 andrew 455: The Keyring PDB handler is a helper class for the Palm::PDB package. It
456: parses Keyring for Palm OS databases. See
457: L<http://gnukeyring.sourceforge.net/>.
1.1 andrew 458:
1.14 andrew 459: It has the standard Palm::PDB methods with 2 additional public methods.
460: Decrypt and Encrypt.
1.1 andrew 461:
1.16 andrew 462: It currently supports the v4 Keyring databases. The v5 databases from
463: the pre-release keyring-2.0 are not supported.
464:
465: This module doesn't store the decrypted content. It only keeps it until it
466: returns it to you or encrypts it.
1.1 andrew 467:
1.14 andrew 468: =head1 SYNOPSIS
1.1 andrew 469:
1.16 andrew 470: use Palm::PDB;
471: use Palm::Keyring;
1.17 andrew 472:
473: my $pass = 'password';
1.18 andrew 474: my $file = 'Keys-Gtkr.pdb';
475: my $pdb = new Palm::PDB;
1.16 andrew 476: $pdb->Load($file);
1.17 andrew 477:
478: foreach (0..$#{ $pdb->{'records'} }) {
479: next if $_ = 0; # skip the password record
480: my $rec = $pdb->{'records'}->[$_];
481: my $acct = $pdb->Decrypt($rec, $pass);
1.19 andrew 482: print $rec->{'name'}, ' - ', $acct->{'account'}, "\n";
1.16 andrew 483: }
1.1 andrew 484:
1.14 andrew 485: =head1 SUBROUTINES/METHODS
1.1 andrew 486:
1.14 andrew 487: =head2 new
1.11 andrew 488:
1.16 andrew 489: $pdb = new Palm::Keyring([$password]);
1.11 andrew 490:
1.14 andrew 491: Create a new PDB, initialized with the various Palm::Keyring fields
492: and an empty record list.
1.11 andrew 493:
1.14 andrew 494: Use this method if you're creating a Keyring PDB from scratch otherwise you
1.16 andrew 495: can just use Palm::PDB::new() before calling Load().
1.11 andrew 496:
1.24 andrew 497: If you pass in a password, it will initalize the first record with the encrypted
498: password.
499:
1.16 andrew 500: =head2 Encrypt
1.11 andrew 501:
1.24 andrew 502: $pdb->Encrypt($rec, $acct[, $password]);
1.11 andrew 503:
1.16 andrew 504: Encrypts an account into a record, either with the password previously
505: used, or with a password that is passed.
1.1 andrew 506:
1.24 andrew 507: $rec is a record from $pdb->{'records'} or a new_Record().
1.16 andrew 508: $acct is a hashref in the format below.
1.1 andrew 509:
1.16 andrew 510: my $acct = {
1.20 andrew 511: name => $rec->{'name'},
512: account => $account,
513: password => $password,
514: notes => $notes,
515: lastchange => {
516: year => 107, # years since 1900
517: month => 0, # 0-11, 0 = January, 11 = December
1.21 andrew 518: day => 30, # 1-31, same as localtime
1.20 andrew 519: },
1.16 andrew 520: };
1.7 andrew 521:
1.22 andrew 522: If you have changed anything other than the lastchange, or don't pass in a
1.24 andrew 523: lastchange key, Encrypt() will generate a new lastchange date for you.
1.22 andrew 524:
525: If you pass in a lastchange field that is different than the one in the
526: record, it will honor what you passed in.
527:
1.24 andrew 528: Encrypt() only uses the $acct->{'name'} if there is not already a $rec->{'name'}.
1.22 andrew 529:
1.16 andrew 530: =head2 Decrypt
1.1 andrew 531:
1.16 andrew 532: my $acct = $pdb->Decrypt($rec[, $password]);
1.1 andrew 533:
1.16 andrew 534: Decrypts the record and returns a hashref for the account as described
1.20 andrew 535: under Encrypt().
1.1 andrew 536:
1.16 andrew 537: foreach (0..$#{ $pdb->{'records'}) {
538: next if $_ == 0;
539: my $rec = $pdb->{'records'}->[$_];
540: my $acct = $pdb->Decrypt($rec[, $password]);
541: # do something with $acct
542: }
1.1 andrew 543:
1.16 andrew 544: =head2 Password
1.1 andrew 545:
1.16 andrew 546: $pdb->Password([$password[, $new_password]]);
1.1 andrew 547:
1.16 andrew 548: Either sets the password to be used to crypt, or if you pass $new_password,
549: changes the password on the database.
1.1 andrew 550:
1.16 andrew 551: If you have created a new $pdb, and you didn't set a password when you
552: called new(), you only need to pass one password and it will set that as
553: the password.
1.1 andrew 554:
1.24 andrew 555: If nothing is passed, it forgets the password that it was remembering.
1.1 andrew 556:
1.14 andrew 557: =head1 DEPENDENCIES
1.1 andrew 558:
1.14 andrew 559: Palm::StdAppInfo
1.1 andrew 560:
1.14 andrew 561: Digest::MD5
1.9 andrew 562:
1.14 andrew 563: Crypt::DES
1.4 andrew 564:
1.14 andrew 565: Readonly
1.10 andrew 566:
1.24 andrew 567: =head1 THANKS
568:
569: I would like to thank the helpful Perlmonk shigetsu who gave me some great advice
570: and helped me get my first module posted. L<http://perlmonks.org/?node_id=596998>
571:
572: I would also like to thank
573: Johan Vromans
574: E<lt>jvromans@squirrel.nlE<gt> --
575: L<http://www.squirrel.nl/people/jvromans>.
576: He had his own Palm::KeyRing module that he posted a couple of days before
577: mine was ready and he was kind enough to let me have the namespace as well
578: as giving me some very helpful hints about doing a few things that I was
579: unsure of. He is really great.
580:
1.14 andrew 581: =head1 BUGS AND LIMITATIONS
1.1 andrew 582:
1.14 andrew 583: Please report any bugs or feature requests to
584: C<bug-palm-keyring at rt.cpan.org>, or through the web interface at
585: L<http://rt.cpan.org>. I will be notified, and then you'll automatically be
586: notified of progress on your bug as I make changes.
1.1 andrew 587:
588: =head1 AUTHOR
589:
1.12 andrew 590: Andrew Fresh E<lt>andrew@mad-techies.orgE<gt>
1.1 andrew 591:
1.14 andrew 592: =head1 LICENSE AND COPYRIGHT
593:
594: Copyright 2004, 2005, 2006, 2007 Andrew Fresh, All Rights Reserved.
595:
1.15 andrew 596: This program is free software; you can redistribute it and/or
597: modify it under the same terms as Perl itself.
1.14 andrew 598:
1.1 andrew 599: =head1 SEE ALSO
600:
601: Palm::PDB(3)
602:
603: Palm::StdAppInfo(3)
1.11 andrew 604:
605: The Keyring for Palm OS website:
606: L<http://gnukeyring.sourceforge.net/>
1.24 andrew 607:
608: Johan Vromans also has a wxkeyring app that now uses this module, available
1.25 andrew 609: from his website at L<http://www.vromans.org/johan/software/>
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>