| version 1.9, 2006/11/10 17:49:51 | 
version 1.25, 2007/02/03 01:12:21 | 
 | 
 | 
|  # Palm::Keyring.pm | 
 package Palm::Keyring; | 
|   | 
  | 
|   | 
 # $RedRiver: Keyring.pm,v 1.24 2007/02/03 00:52:43 andrew Exp $ | 
|  # | 
 # | 
|  # Perl class for dealing with Keyring for Palm OS databases. | 
 # Perl class for dealing with Keyring for Palm OS databases. | 
|  # | 
 # | 
|  #       Copyright (C) 2004, Andrew Fresh | 
  | 
|  #       You may distribute this file under the terms of the Artistic | 
  | 
|  #       License, as specified in the README file distributed with the p5-Palm distribution. | 
  | 
|  # | 
  | 
|  #   This started as Memo.pm, I just made it work for Keyring. | 
 #   This started as Memo.pm, I just made it work for Keyring. | 
|  # | 
  | 
|  # $Id$ | 
  | 
|  # $RedRiver: Keyring.pm,v 1.8 2006/11/10 17:31:38 andrew Exp $ | 
  | 
|   | 
  | 
|  use strict; | 
 use strict; | 
|  package Palm::Keyring; | 
 use warnings; | 
|  use Palm::Raw(); | 
 use Carp; | 
|  use Palm::StdAppInfo(); | 
  | 
|  use vars qw( $VERSION @ISA ); | 
  | 
|   | 
  | 
|   | 
 use base qw/ Palm::StdAppInfo /; | 
|   | 
  | 
|  use Digest::MD5 qw(md5); | 
 use Digest::MD5 qw(md5); | 
|  use Crypt::DES; | 
 use Crypt::DES; | 
|   | 
  | 
|  use constant ENCRYPT    =>  1; | 
 my $ENCRYPT    = 1; | 
|  use constant DECRYPT    =>  0; | 
 my $DECRYPT    = 0; | 
|  use constant MD5_CBLOCK => 64; | 
 my $MD5_CBLOCK = 64; | 
|  my $kSaltSize = 4; | 
 my $kSalt_Size = 4; | 
|   | 
 my $EMPTY      = q{}; | 
|   | 
 my $SPACE      = q{ }; | 
|   | 
 my $NULL       = chr 0; | 
|   | 
  | 
|   | 
 our $VERSION = 0.93; | 
|   | 
  | 
|  # One liner, to allow MakeMaker to work. | 
 sub new { | 
|  $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; | 
     my $classname = shift; | 
|   | 
     my $pass      = shift; | 
|   | 
  | 
|  @ISA = qw( Palm::StdAppInfo Palm::Raw ); | 
     # Create a generic PDB. No need to rebless it, though. | 
|   | 
     my $self = $classname->SUPER::new(@_); | 
|   | 
  | 
|  =head1 NAME | 
     $self->{'name'}    = 'Keys-Gtkr';    # Default | 
|   | 
     $self->{'creator'} = 'Gtkr'; | 
|   | 
     $self->{'type'}    = 'Gkyr'; | 
|   | 
  | 
|  Palm::Keyring - Handler for Palm Keyring databases. | 
     # The PDB is not a resource database by | 
|   | 
     # default, but it's worth emphasizing, | 
|   | 
     # since MemoDB is explicitly not a PRC. | 
|   | 
     $self->{'attributes'}{'resource'} = 0; | 
|   | 
  | 
|  =head1 SYNOPSIS | 
     # Initialize the AppInfo block | 
|   | 
     $self->{'appinfo'} = {}; | 
|   | 
  | 
|      use Palm::Keyring; | 
     # Add the standard AppInfo block stuff | 
|          $pdb->Decrypt('mypassword'); | 
     Palm::StdAppInfo::seed_StdAppInfo( $self->{'appinfo'} ); | 
|   | 
  | 
|  =head1 DESCRIPTION | 
     # Set the version | 
|   | 
     $self->{'version'} = 4; | 
|   | 
  | 
|  The Keyring PDB handler is a helper class for the Palm::PDB package. It | 
     if ( defined $pass ) { | 
|  parses Keyring databases.  See | 
         $self->Password($pass); | 
|  L<http://gnukeyring.sourceforge.net/>. | 
     } | 
|   | 
  | 
|  It is just the standard Palm::Raw with 2 additional public methods.  Decrypt and Encrypt. | 
     return $self; | 
|   | 
 } | 
|   | 
  | 
|  =cut | 
 sub import { | 
|  =head2 new | 
     Palm::PDB::RegisterPDBHandlers( __PACKAGE__, [ 'Gtkr', 'Gkyr' ], ); | 
|   | 
     return 1; | 
|   | 
 } | 
|   | 
  | 
|    $pdb = new Palm::Keyring ('password'); | 
 sub ParseRecord { | 
|   | 
     my $self     = shift; | 
|   | 
  | 
|  Create a new PDB, initialized with the various Palm::Keyring fields | 
     my $rec = $self->SUPER::ParseRecord(@_); | 
|  and an empty record list. | 
  | 
|   | 
  | 
|  Use this method if you're creating a Keyring PDB from scratch. | 
     # skip the 0 record that holds the password | 
|   | 
     return $rec if ! exists $self->{'records'}; | 
|   | 
     return $rec if ! exists $rec->{'data'}; | 
|   | 
  | 
|  =cut | 
     my ( $name, $encrypted ) = split /$NULL/xm, $rec->{'data'}, 2; | 
|  #' | 
  | 
|  sub new | 
  | 
|  { | 
  | 
|          my $classname   = shift; | 
  | 
|          my $pass = shift; | 
  | 
|   | 
  | 
|          # Create a generic PDB. No need to rebless it, though. | 
     return $rec if ! $encrypted; | 
|          my $self        = $classname->SUPER::new(@_); | 
     delete $rec->{'data'}; | 
|   | 
     $rec->{'name'} = $name; | 
|   | 
     $rec->{'encrypted'} = $encrypted; | 
|   | 
  | 
|          $self->{name} = "Keys-Gtkr";    # Default | 
     return $rec; | 
|          $self->{creator} = "Gtkr"; | 
 } | 
|          $self->{type} = "Gkyr"; | 
  | 
|          # The PDB is not a resource database by | 
  | 
|          # default, but it's worth emphasizing, | 
  | 
|          # since MemoDB is explicitly not a PRC. | 
  | 
|          $self->{attributes}{resource} = 0; | 
  | 
|   | 
  | 
|          # Initialize the AppInfo block | 
 sub PackRecord { | 
|          $self->{appinfo} = {}; | 
     my $self = shift; | 
|   | 
     my $rec  = shift; | 
|   | 
  | 
|          # Add the standard AppInfo block stuff | 
     if ($rec->{'encrypted'}) { | 
|          &Palm::StdAppInfo::seed_StdAppInfo($self->{appinfo}); | 
         if (! defined $rec->{'name'}) { | 
|   | 
             $rec->{'name'} = $EMPTY; | 
|   | 
         } | 
|   | 
         $rec->{'data'} = join $NULL, $rec->{'name'}, $rec->{'encrypted'}; | 
|   | 
         delete $rec->{'name'}; | 
|   | 
         delete $rec->{'encrypted'}; | 
|   | 
     } | 
|   | 
  | 
|          # Set the version | 
     return $self->SUPER::PackRecord($rec, @_); | 
|          $self->{version} = 4; | 
 } | 
|   | 
  | 
|          # Give the PDB the first record that will hold the encrypted password | 
 sub Encrypt { | 
|          $self->{records} = [ { | 
     my $self = shift; | 
|                  'category'   => 0, | 
     my $rec  = shift; | 
|                  'attributes' => { | 
     my $data = shift; | 
|                          'private' => 1, | 
     my $pass = shift || $self->{'password'}; | 
|                          'Secret'  => 1, | 
  | 
|                          'Dirty'   => 1, | 
  | 
|                          'dirty'   => 1, | 
  | 
|                  }, | 
  | 
|          }, ]; | 
  | 
|   | 
  | 
|          if ($pass) { | 
     if ( ! $pass) { | 
|                  $self->Encrypt($pass); | 
         croak("'password' not set!\n"); | 
|          } | 
     } | 
|   | 
  | 
|          return $self; | 
     if ( ! $rec) { | 
|  } | 
         croak("Needed parameter 'record' not passed!\n"); | 
|   | 
     } | 
|   | 
  | 
|  sub import | 
     if ( ! $data) { | 
|  { | 
         croak("Needed parameter 'data' not passed!\n"); | 
|          &Palm::PDB::RegisterPDBHandlers(__PACKAGE__, | 
     } | 
|                  [ "Gtkr", "Gkyr" ], | 
  | 
|                  ); | 
  | 
|  } | 
  | 
|   | 
  | 
|  sub Load | 
     if ( ! $self->Password($pass)) { | 
|  { | 
         croak("Incorrect Password!\n"); | 
|          my $self = shift; | 
     } | 
|          $self->SUPER::Load(@_); | 
  | 
|   | 
  | 
|          foreach my $record (@{ $self->{records} }) { | 
     $self->{'digest'}   ||= _calc_keys( $pass ); | 
|                  next unless exists $record->{data}; | 
  | 
|                  my ($name, $encrypted) = split /\000/, $record->{data}, 2; | 
  | 
|                  next unless $encrypted; | 
  | 
|                  $record->{plaintext}->{name} = $name; | 
  | 
|          $record->{encrypted} = $encrypted; | 
  | 
|          } | 
  | 
|          1; | 
  | 
|  } | 
  | 
|   | 
  | 
|  sub Write | 
     $data->{'account'}  ||= $EMPTY; | 
|  { | 
     $data->{'password'} ||= $EMPTY; | 
|          my $self = shift; | 
     $data->{'notes'}    ||= $EMPTY; | 
|          $self->Encrypt() || return undef; | 
  | 
|          return $self->SUPER::Load(@_); | 
  | 
|  } | 
  | 
|   | 
  | 
|  sub Encrypt | 
     my $changed      = 0; | 
|  { | 
     my $need_newdate = 0; | 
|          my $self = shift; | 
     my $acct = {}; | 
|          my $pass = shift; | 
     if ($rec->{'encrypted'}) { | 
|   | 
         $acct = $self->Decrypt($rec, $pass); | 
|   | 
         foreach my $key (keys %{ $data }) { | 
|   | 
             next if $key eq 'lastchange'; | 
|   | 
             if ($data->{$key} ne $acct->{$key}) { | 
|   | 
                 $changed = 1; | 
|   | 
                 last; | 
|   | 
             } | 
|   | 
         } | 
|   | 
         if ( exists $data->{'lastchange'} && exists $acct->{'lastchange'} && ( | 
|   | 
             $data->{'lastchange'}->{day}   != $acct->{'lastchange'}->{day}   || | 
|   | 
             $data->{'lastchange'}->{month} != $acct->{'lastchange'}->{month} || | 
|   | 
             $data->{'lastchange'}->{year}  != $acct->{'lastchange'}->{year} | 
|   | 
         )) { | 
|   | 
             $changed = 1; | 
|   | 
             $need_newdate = 0; | 
|   | 
         } else { | 
|   | 
             $need_newdate = 1; | 
|   | 
         } | 
|   | 
  | 
|   | 
     } else { | 
|   | 
         $changed = 1; | 
|   | 
     } | 
|   | 
  | 
|          if ($pass) { | 
     # no need to re-encrypt if it has not changed. | 
|                  unless ($self->_keyring_verify($pass) ) { | 
     return 1 if ! $changed; | 
|                          # This would encrypt with a new password. | 
  | 
|                          # First decrypting everything with the old password of course. | 
  | 
|                          $self->_keyring_update($pass) || return undef; | 
  | 
|                          $self->_keyring_verify($pass) || return undef; | 
  | 
|                  } | 
  | 
|          } | 
  | 
|   | 
  | 
|          $self->{digest} ||= _calc_keys($self->{password}); | 
     my ($day, $month, $year); | 
|   | 
  | 
|          foreach my $record (@{ $self->{records} }) { | 
     if ($data->{'lastchange'} && ! $need_newdate ) { | 
|                  next unless defined $record->{plaintext}; | 
         $day   = $data->{'lastchange'}->{'day'}   || 1; | 
|   | 
         $month = $data->{'lastchange'}->{'month'} || 0; | 
|   | 
         $year  = $data->{'lastchange'}->{'year'}  || 0; | 
|   | 
  | 
|                  my $name        = defined $record->{plaintext}->{name}        ? | 
         # XXX Need to actually validate the above information somehow | 
|                          $record->{plaintext}->{name}        : ''; | 
         if ($year >= 1900) { | 
|                  my $account     = defined $record->{plaintext}->{account}     ? | 
             $year -= 1900; | 
|                          $record->{plaintext}->{account}     : ''; | 
         } | 
|                  my $password    = defined $record->{plaintext}->{password}    ? | 
     } else { | 
|                          $record->{plaintext}->{password}    : ''; | 
         $need_newdate = 1; | 
|                  my $description = defined $record->{plaintext}->{description} ? | 
     } | 
|                          $record->{plaintext}->{description} : ''; | 
  | 
|                  my $extra       = ''; | 
  | 
|   | 
  | 
|                  my $plaintext = join("\000", $account, $password, $description, $extra); | 
     if ($need_newdate) { | 
|   | 
         ($day, $month, $year) = (localtime)[3,4,5]; | 
|   | 
     } | 
|   | 
     $year -= 4; | 
|   | 
     $month++; | 
|   | 
  | 
|                  my $encrypted = _crypt3des($plaintext, $self->{digest}, ENCRYPT); | 
  | 
|   | 
  | 
|                  $record->{data} = join("\000", $name, $encrypted); | 
     my $p = $day | ($month << 5) | ($year << 9); | 
|          } | 
     my $packeddate = pack 'n', $p; | 
|   | 
  | 
|          return 1; | 
     my $plaintext = join $NULL, | 
|   | 
         $data->{'account'}, $data->{'password'}, $data->{'notes'}, $packeddate; | 
|   | 
  | 
|   | 
     my $encrypted = _crypt3des( $plaintext, $self->{'digest'}, $ENCRYPT ); | 
|   | 
  | 
|   | 
     return if ! $encrypted; | 
|   | 
  | 
|   | 
     $rec->{'attributes'}{'Dirty'} = 1; | 
|   | 
     $rec->{'attributes'}{'dirty'} = 1; | 
|   | 
     $rec->{'name'}    ||= $data->{'name'}; | 
|   | 
     $rec->{'encrypted'} = $encrypted; | 
|   | 
  | 
|   | 
     return 1; | 
|  } | 
 } | 
|   | 
  | 
|  sub Decrypt | 
 sub Decrypt { | 
|  { | 
     my $self = shift; | 
|          my $self = shift; | 
     my $rec  = shift; | 
|          my $pass = shift; | 
     my $pass = shift || $self->{'password'}; | 
|   | 
  | 
|          if ($pass) { | 
     if ( ! $pass) { | 
|                  $self->_keyring_verify($pass) || return undef; | 
         croak("'password' not set!\n"); | 
|          } | 
     } | 
|   | 
  | 
|          $self->{digest} ||= _calc_keys($self->{password}); | 
     if ( ! $rec) { | 
|   | 
         croak("Needed parameter 'record' not passed!\n"); | 
|   | 
     } | 
|   | 
  | 
|          foreach my $record (@{ $self->{records} }) { | 
     if ( ! $self->Password($pass)) { | 
|                  next unless defined $record->{data}; | 
         croak("Invalid Password!\n"); | 
|   | 
     } | 
|   | 
  | 
|                  my ($name, $encrypted) = split /\000/, $record->{data}, 2; | 
     if ( ! $rec->{'encrypted'} ) { | 
|                  next unless $encrypted; | 
         croak("No encrypted content!"); | 
|   | 
     } | 
|   | 
  | 
|                  $record->{plaintext}->{name} = $name; | 
     $self->{'digest'} ||= _calc_keys( $pass ); | 
|   | 
  | 
|                  my $decrypted = _crypt3des($encrypted, $self->{digest}, DECRYPT); | 
     my $decrypted = | 
|                  my ($account, $password, $description, $extra) | 
         _crypt3des( $rec->{'encrypted'}, $self->{'digest'}, $DECRYPT ); | 
|                        = split /\000/, $decrypted, 4; | 
     my ( $account, $password, $notes, $packeddate ) = split /$NULL/xm, | 
|   | 
           $decrypted, 4; | 
|   | 
  | 
|                  $record->{plaintext}->{account}     = defined $account     ? | 
     my %Modified; | 
|                          $account     : ''; | 
     if ($packeddate) { | 
|                  $record->{plaintext}->{password}    = defined $password    ? | 
         my $u = unpack 'n', $packeddate; | 
|                          $password    : ''; | 
         my $year  = (($u & 0xFE00) >> 9) + 4; # since 1900 | 
|                  $record->{plaintext}->{description} = defined $description ? | 
         my $month = (($u & 0x01E0) >> 5) - 1; # 0-11 | 
|                          $description : ''; | 
         my $day   = (($u & 0x001F) >> 0);     # 1-31 | 
|   | 
  | 
|                  #print "Name:      '$name'\n"; | 
         %Modified = ( | 
|                  #print "Encrypted: '$encrypted' - Length: " . length($encrypted) . "\n"; | 
             year   => $year, | 
|                  #print "    Hex:   '" . unpack("H*", $encrypted) . "'\n"; | 
             month  => $month || 0, | 
|                  #print "    Binary:'" . unpack("b*", $encrypted) . "'\n"; | 
             day    => $day   || 1, | 
|                  #print "Decrypted: '$decrypted' - Length: " . length($decrypted) . "\n"; | 
         ); | 
|                  #print "    Hex:   '" . unpack("H*", $decrypted) . "'\n"; | 
     } | 
|                  #print "    Binary:'" . unpack("b*", $decrypted) . "'\n"; | 
  | 
|                  #print "\n"; | 
  | 
|                  #print "Extra: $extra\n"; | 
  | 
|                  #exit; | 
  | 
|                  #-------------------------------------------------- | 
  | 
|                  # print "Account:     $account\n"; | 
  | 
|                  # print "Password:    $password\n"; | 
  | 
|                  # print "Description: $description\n"; | 
  | 
|                  #-------------------------------------------------- | 
  | 
|   | 
  | 
|          } | 
     return { | 
|   | 
         name       => $rec->{'name'}, | 
|   | 
         account    => $account, | 
|   | 
         password   => $password, | 
|   | 
         notes      => $notes, | 
|   | 
         lastchange => \%Modified, | 
|   | 
     }; | 
|   | 
 } | 
|   | 
  | 
|   | 
 sub Password { | 
|   | 
     my $self = shift; | 
|   | 
     my $pass = shift; | 
|   | 
     my $new_pass = shift; | 
|   | 
  | 
|   | 
     if (! $pass) { | 
|   | 
         delete $self->{password}; | 
|          return 1; | 
         return 1; | 
|   | 
     } | 
|   | 
  | 
|   | 
     if (! exists $self->{'records'}) { | 
|   | 
         # Give the PDB the first record that will hold the encrypted password | 
|   | 
         $self->{'records'} = [ $self->new_Record ]; | 
|   | 
  | 
|   | 
         return $self->_password_update($pass); | 
|   | 
     } | 
|   | 
  | 
|   | 
     if ($new_pass) { | 
|   | 
         my @accts = (); | 
|   | 
         foreach my $i (0..$#{ $self->{'records'} }) { | 
|   | 
             if ($i == 0) { | 
|   | 
                 push @accts, undef; | 
|   | 
                 next; | 
|   | 
             } | 
|   | 
             my $acct = $self->Decrypt($self->{'records'}->[$i], $pass); | 
|   | 
             if ( ! $acct ) { | 
|   | 
                 croak("Couldn't decrypt $self->{'records'}->[$i]->{'name'}"); | 
|   | 
             } | 
|   | 
             push @accts, $acct; | 
|   | 
         } | 
|   | 
  | 
|   | 
         if ( ! $self->_password_update($new_pass)) { | 
|   | 
             croak("Couldn't set new password!"); | 
|   | 
         } | 
|   | 
         $pass = $new_pass; | 
|   | 
  | 
|   | 
         foreach my $i (0..$#accts) { | 
|   | 
             next if $i == 0; | 
|   | 
             delete $self->{'records'}->[$i]->{'encrypted'}; | 
|   | 
             $self->Encrypt($self->{'records'}->[$i], $accts[$i], $pass); | 
|   | 
         } | 
|   | 
     } | 
|   | 
  | 
|   | 
     return $self->_password_verify($pass); | 
|  } | 
 } | 
|   | 
  | 
|  sub _calc_keys | 
 sub _calc_keys { | 
|  { | 
     my $pass = shift; | 
|          my $pass = shift; | 
     if (! defined $pass) { croak('No password defined!'); }; | 
|          die "No password defined!" unless defined $pass; | 
  | 
|   | 
  | 
|          my $digest = md5($pass); | 
     my $digest = md5($pass); | 
|   | 
  | 
|          my ($key1, $key2) = unpack('a8a8', $digest); | 
     my ( $key1, $key2 ) = unpack 'a8a8', $digest; | 
|          #-------------------------------------------------- | 
  | 
|          # print "key1: $key1: ", length $key1, "\n"; | 
  | 
|          # print "key2: $key2: ", length $key2, "\n"; | 
  | 
|          #-------------------------------------------------- | 
  | 
|   | 
  | 
|          $digest = unpack('H*', $key1 . $key2 . $key1); | 
     #-------------------------------------------------- | 
|          #-------------------------------------------------- | 
     # print "key1: $key1: ", length $key1, "\n"; | 
|          # print "Digest: ", $digest, "\n"; | 
     # print "key2: $key2: ", length $key2, "\n"; | 
|          # print length $digest, "\n"; | 
     #-------------------------------------------------- | 
|          #-------------------------------------------------- | 
  | 
|   | 
  | 
|          return $digest; | 
     $digest = unpack 'H*', $key1 . $key2 . $key1; | 
|   | 
  | 
|   | 
     #-------------------------------------------------- | 
|   | 
     # print "Digest: ", $digest, "\n"; | 
|   | 
     # print length $digest, "\n"; | 
|   | 
     #-------------------------------------------------- | 
|   | 
  | 
|   | 
     return $digest; | 
|  } | 
 } | 
|   | 
  | 
|  sub _keyring_verify | 
 sub _password_verify { | 
|  { | 
     my $self = shift; | 
|          my $self = shift; | 
     my $pass = shift; | 
|          my $pass = shift; | 
  | 
|   | 
  | 
|          die "No password specified!" unless $pass; | 
     if (! $pass) { croak('No password specified!'); }; | 
|          $self->{password} = $pass; | 
  | 
|   | 
  | 
|          # AFAIK the thing we use to test the password is | 
     if (defined $self->{'password'} && $pass eq $self->{'password'}) { | 
|          #     always in the first entry | 
         # already verified this password | 
|          my $data = $self->{records}->[1]->{data}; | 
         return 1; | 
|          #die "No encrypted password in file!" unless defined $data; | 
     } | 
|          return undef unless defined $data; | 
  | 
|   | 
  | 
|          $data =~ s/\0$//; | 
     # AFAIK the thing we use to test the password is | 
|   | 
     #     always in the first entry | 
|   | 
     my $data = $self->{'records'}->[0]->{'data'}; | 
|   | 
  | 
|          my $salt = substr($data, 0, $kSaltSize); | 
     #die "No encrypted password in file!" unless defined $data; | 
|   | 
     if ( ! defined $data) { return; }; | 
|   | 
  | 
|          my $msg = $salt . $pass; | 
     $data =~ s/$NULL$//xm; | 
|   | 
  | 
|          $msg .= "\0" x (MD5_CBLOCK - length($msg)); | 
     my $salt = substr $data, 0, $kSalt_Size; | 
|   | 
  | 
|          my $digest = md5($msg); | 
     my $msg = $salt . $pass; | 
|   | 
  | 
|          if ($data eq $salt . $digest) { | 
     $msg .= "\0" x ( $MD5_CBLOCK - length $msg ); | 
|                  # May as well generate the keys we need now, since we know the password is right | 
  | 
|                  $self->{digest} = _calc_keys($self->{password}); | 
     my $digest = md5($msg); | 
|                  if ($self->{digest}) { | 
  | 
|                          return 1; | 
     if ( $data eq $salt . $digest ) { | 
|                  } else { | 
  | 
|                          return undef; | 
 # May as well generate the keys we need now, since we know the password is right | 
|                  } | 
         $self->{'digest'} = _calc_keys($pass); | 
|          } else { | 
         if ( $self->{'digest'} ) { | 
|                  return undef; | 
             $self->{'password'} = $pass; | 
|          } | 
             return 1; | 
|   | 
         } | 
|   | 
     } | 
|   | 
     return; | 
|  } | 
 } | 
|   | 
  | 
|  sub _keyring_update | 
 sub _password_update { | 
|  { | 
  | 
|          # It is very important to Encrypt after calling this | 
  | 
|          #     (Although it is generally only called by Encrypt) | 
  | 
|          # because otherwise the data will be out of sync with the | 
  | 
|          # password, and that would suck! | 
  | 
|          my $self = shift; | 
  | 
|          my $pass = shift; | 
  | 
|   | 
  | 
|          die "No password specified!" unless $pass; | 
     # It is very important to Encrypt after calling this | 
|   | 
     #     (Although it is generally only called by Encrypt) | 
|   | 
     # because otherwise the data will be out of sync with the | 
|   | 
     # password, and that would suck! | 
|   | 
     my $self = shift; | 
|   | 
     my $pass = shift; | 
|   | 
  | 
|          # if the database already has a password in it | 
     if (! defined $pass) { croak('No password specified!'); }; | 
|          if ($self->{records}->[1]->{data}) { | 
  | 
|                  # Make sure everything is decrypted before we update the keyring | 
  | 
|                  $self->Decrypt() || return undef; | 
  | 
|          } | 
  | 
|   | 
  | 
|          my $salt; | 
     my $salt; | 
|          for (1..$kSaltSize) { | 
     for ( 1 .. $kSalt_Size ) { | 
|                  $salt .= chr(int(rand(255))); | 
         $salt .= chr int rand 255; | 
|          } | 
     } | 
|   | 
  | 
|          my $msg = $salt . $pass; | 
     my $msg = $salt . $pass; | 
|   | 
  | 
|          $msg .= "\0" x (MD5_CBLOCK - length($msg)); | 
     $msg .= "\0" x ( $MD5_CBLOCK - length $msg ); | 
|   | 
  | 
|          my $digest = md5($msg); | 
     my $digest = md5($msg); | 
|   | 
  | 
|          my $data = $salt . $digest;# . "\0"; | 
     my $data = $salt . $digest;    # . "\0"; | 
|   | 
  | 
|          # AFAIK the thing we use to test the password is | 
     # AFAIK the thing we use to test the password is | 
|          #     always in the first entry | 
     #     always in the first entry | 
|          $self->{records}->[1]->{data} = $data; | 
     $self->{'records'}->[0]->{'data'} = $data; | 
|   | 
  | 
|          $self->{password} = $pass; | 
     $self->{'password'} = $pass; | 
|          $self->{digest}   = _calc_keys($self->{password}); | 
     $self->{'digest'}   = _calc_keys( $self->{'password'} ); | 
|   | 
  | 
|          return 1; | 
     return 1; | 
|  } | 
 } | 
|   | 
  | 
|   | 
 sub _crypt3des { | 
|   | 
     my ( $plaintext, $passphrase, $flag ) = @_; | 
|   | 
  | 
|  # XXX It looks like they are using des_ecb2_encrypt so I dunno if that is different | 
     $passphrase   .= $SPACE x ( 16 * 3 ); | 
|  sub _crypt3des { | 
     my $cyphertext = $EMPTY; | 
|          my ( $plaintext, $passphrase, $flag ) = @_; | 
  | 
|   | 
  | 
|          $passphrase .= ' ' x (16*3); | 
     my $size = length $plaintext; | 
|          my $cyphertext = ""; | 
  | 
|   | 
  | 
|          my $size = length ( $plaintext ); | 
     #print "STRING: '$plaintext' - Length: " . (length $plaintext) . "\n"; | 
|          #print "STRING: '$plaintext' - Length: " . length($plaintext) . "\n"; | 
  | 
|   | 
  | 
|          my @C; | 
     my @C; | 
|          for ( 0..2 ) { | 
     for ( 0 .. 2 ) { | 
|                  $C[$_] = new Crypt::DES( pack( "H*", substr($passphrase, 16*$_, 16 ))); | 
         $C[$_] = | 
|          } | 
           new Crypt::DES( pack 'H*', ( substr $passphrase, 16 * $_, 16 )); | 
|   | 
     } | 
|   | 
  | 
|   | 
     for ( 0 .. ( ($size) / 8 ) ) { | 
|   | 
         my $pt = substr $plaintext, $_ * 8, 8; | 
|   | 
  | 
|  # XXX From Crypt::TripleDES | 
         #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
|  # http://search.cpan.org/src/VIPUL/Crypt-TripleDES-0.24/lib/Crypt/TripleDES.pm | 
         if (! length $pt) { next; }; | 
|  # | 
         if ( (length $pt) < 8 ) { | 
|  #    for ( 0 .. (($size)/8) -1 ) { | 
             if ($flag == $DECRYPT) { croak('record not 8 byte padded'); }; | 
|  #     my $pt = substr( $plaintext, $_*8, 8 ); | 
             my $len = 8 - (length $pt); | 
|  #        $pt = Crypt::PPDES::des_ecb_encrypt( $flag ? $keyvecs{0} : $keyvecs{2}, $flag, $pt ); | 
  | 
|  #        $pt = Crypt::PPDES::des_ecb_encrypt( $keyvecs{1}, (not $flag), $pt ); | 
  | 
|  #        $pt = Crypt::PPDES::des_ecb_encrypt( $flag ? $keyvecs{2} : $keyvecs{0}, $flag, $pt ); | 
  | 
|  #        $cyphertext .= $pt; | 
  | 
|  #    } | 
  | 
|   | 
  | 
|          for ( 0 .. (($size)/8) - 1) { | 
             #print "LENGTH: $len\n"; | 
|                  my $pt = substr( $plaintext, $_*8, 8 ); | 
             #print "Binary:    '" . unpack("b*", $pt) . "'\n"; | 
|                  #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
             $pt .= ($NULL x $len); | 
|                  if (length($pt) < 8) { | 
  | 
|                          die "record not 8 byte padded" if  $flag == DECRYPT; | 
  | 
|                          my $len = 8 - length($pt); | 
  | 
|                          #print "LENGTH: $len\n"; | 
  | 
|                          #print "Binary:    '" . unpack("b*", $pt) . "'\n"; | 
  | 
|                          $pt .= (chr(0) x $len);# . $pt; | 
  | 
|                          #print "Binary:    '" . unpack("b*", $pt) . "'\n"; | 
  | 
|                          #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
  | 
|                  } | 
  | 
|                  $pt = $C[0]->decrypt( $pt ); | 
  | 
|                  $pt = $C[1]->encrypt( $pt ); | 
  | 
|                  $pt = $C[2]->decrypt( $pt ); | 
  | 
|                  #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
  | 
|                  $cyphertext .= $pt; | 
  | 
|          } | 
  | 
|   | 
  | 
|          return substr ( $cyphertext, 0, $size ); | 
             #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
|   | 
             #print "Binary:    '" . unpack("b*", $pt) . "'\n"; | 
|   | 
         } | 
|   | 
         if ( $flag == $ENCRYPT ) { | 
|   | 
             $pt = $C[0]->encrypt($pt); | 
|   | 
             $pt = $C[1]->decrypt($pt); | 
|   | 
             $pt = $C[2]->encrypt($pt); | 
|   | 
         } | 
|   | 
         else { | 
|   | 
             $pt = $C[0]->decrypt($pt); | 
|   | 
             $pt = $C[1]->encrypt($pt); | 
|   | 
             $pt = $C[2]->decrypt($pt); | 
|   | 
         } | 
|   | 
  | 
|   | 
         #print "PT: '$pt' - Length: " . length($pt) . "\n"; | 
|   | 
         $cyphertext .= $pt; | 
|   | 
     } | 
|   | 
  | 
|   | 
     $cyphertext =~ s/$NULL+$//xm; | 
|   | 
  | 
|   | 
     #print "CT: '$cyphertext' - Length: " . length($cyphertext) . "\n"; | 
|   | 
  | 
|   | 
     return $cyphertext; | 
|  } | 
 } | 
|   | 
  | 
|  1; | 
 1; | 
|  __END__ | 
 __END__ | 
|   | 
  | 
|   | 
 =head1 NAME | 
|   | 
  | 
|   | 
 Palm::Keyring - Handler for Palm Keyring databases. | 
|   | 
  | 
|   | 
 =head1 DESCRIPTION | 
|   | 
  | 
|   | 
 The Keyring PDB handler is a helper class for the Palm::PDB package. It | 
|   | 
 parses Keyring for Palm OS databases.  See | 
|   | 
 L<http://gnukeyring.sourceforge.net/>. | 
|   | 
  | 
|   | 
 It has the standard Palm::PDB methods with 2 additional public methods. | 
|   | 
 Decrypt and Encrypt. | 
|   | 
  | 
|   | 
 It currently supports the v4 Keyring databases.  The v5 databases from | 
|   | 
 the pre-release keyring-2.0 are not supported. | 
|   | 
  | 
|   | 
 This module doesn't store the decrypted content.  It only keeps it until it | 
|   | 
 returns it to you or encrypts it. | 
|   | 
  | 
|   | 
 =head1 SYNOPSIS | 
|   | 
  | 
|   | 
     use Palm::PDB; | 
|   | 
     use Palm::Keyring; | 
|   | 
  | 
|   | 
     my $pass = 'password'; | 
|   | 
     my $file = 'Keys-Gtkr.pdb'; | 
|   | 
     my $pdb  = new Palm::PDB; | 
|   | 
     $pdb->Load($file); | 
|   | 
  | 
|   | 
     foreach (0..$#{ $pdb->{'records'} }) { | 
|   | 
         next if $_ = 0; # skip the password record | 
|   | 
         my $rec  = $pdb->{'records'}->[$_]; | 
|   | 
         my $acct = $pdb->Decrypt($rec, $pass); | 
|   | 
         print $rec->{'name'}, ' - ', $acct->{'account'}, "\n"; | 
|   | 
     } | 
|   | 
  | 
|   | 
 =head1 SUBROUTINES/METHODS | 
|   | 
  | 
|   | 
 =head2 new | 
|   | 
  | 
|   | 
     $pdb = new Palm::Keyring([$password]); | 
|   | 
  | 
|   | 
 Create a new PDB, initialized with the various Palm::Keyring fields | 
|   | 
 and an empty record list. | 
|   | 
  | 
|   | 
 Use this method if you're creating a Keyring PDB from scratch otherwise you | 
|   | 
 can just use Palm::PDB::new() before calling Load(). | 
|   | 
  | 
|   | 
 If you pass in a password, it will initalize the first record with the encrypted | 
|   | 
 password. | 
|   | 
  | 
|   | 
 =head2 Encrypt | 
|   | 
  | 
|   | 
     $pdb->Encrypt($rec, $acct[, $password]); | 
|   | 
  | 
|   | 
 Encrypts an account into a record, either with the password previously | 
|   | 
 used, or with a password that is passed. | 
|   | 
  | 
|   | 
 $rec is a record from $pdb->{'records'} or a new_Record(). | 
|   | 
 $acct is a hashref in the format below. | 
|   | 
  | 
|   | 
     my $acct = { | 
|   | 
         name       => $rec->{'name'}, | 
|   | 
         account    => $account, | 
|   | 
         password   => $password, | 
|   | 
         notes      => $notes, | 
|   | 
         lastchange => { | 
|   | 
             year  => 107, # years since 1900 | 
|   | 
             month =>   0, # 0-11, 0 = January, 11 = December | 
|   | 
             day   =>  30, # 1-31, same as localtime | 
|   | 
         }, | 
|   | 
     }; | 
|   | 
  | 
|   | 
 If you have changed anything other than the lastchange, or don't pass in a | 
|   | 
 lastchange key, Encrypt() will generate a new lastchange date for you. | 
|   | 
  | 
|   | 
 If you pass in a lastchange field that is different than the one in the | 
|   | 
 record, it will honor what you passed in. | 
|   | 
  | 
|   | 
 Encrypt() only uses the $acct->{'name'} if there is not already a $rec->{'name'}. | 
|   | 
  | 
|   | 
 =head2 Decrypt | 
|   | 
  | 
|   | 
     my $acct = $pdb->Decrypt($rec[, $password]); | 
|   | 
  | 
|   | 
 Decrypts the record and returns a hashref for the account as described | 
|   | 
 under Encrypt(). | 
|   | 
  | 
|   | 
     foreach (0..$#{ $pdb->{'records'}) { | 
|   | 
         next if $_ == 0; | 
|   | 
         my $rec = $pdb->{'records'}->[$_]; | 
|   | 
         my $acct = $pdb->Decrypt($rec[, $password]); | 
|   | 
         # do something with $acct | 
|   | 
     } | 
|   | 
  | 
|   | 
 =head2 Password | 
|   | 
  | 
|   | 
     $pdb->Password([$password[, $new_password]]); | 
|   | 
  | 
|   | 
 Either sets the password to be used to crypt, or if you pass $new_password, | 
|   | 
 changes the password on the database. | 
|   | 
  | 
|   | 
 If you have created a new $pdb, and you didn't set a password when you | 
|   | 
 called new(), you only need to pass one password and it will set that as | 
|   | 
 the password. | 
|   | 
  | 
|   | 
 If nothing is passed, it forgets the password that it was remembering. | 
|   | 
  | 
|   | 
 =head1 DEPENDENCIES | 
|   | 
  | 
|   | 
 Palm::StdAppInfo | 
|   | 
  | 
|   | 
 Digest::MD5 | 
|   | 
  | 
|   | 
 Crypt::DES | 
|   | 
  | 
|   | 
 Readonly | 
|   | 
  | 
|   | 
 =head1 THANKS | 
|   | 
  | 
|   | 
 I would like to thank the helpful Perlmonk shigetsu who gave me some great advice | 
|   | 
 and helped me get my first module posted.  L<http://perlmonks.org/?node_id=596998> | 
|   | 
  | 
|   | 
 I would also like to thank | 
|   | 
 Johan Vromans | 
|   | 
 E<lt>jvromans@squirrel.nlE<gt> -- | 
|   | 
 L<http://www.squirrel.nl/people/jvromans>. | 
|   | 
 He had his own Palm::KeyRing module that he posted a couple of days before | 
|   | 
 mine was ready and he was kind enough to let me have the namespace as well | 
|   | 
 as giving me some very helpful hints about doing a few things that I was | 
|   | 
 unsure of.  He is really great. | 
|   | 
  | 
|   | 
 =head1 BUGS AND LIMITATIONS | 
|   | 
  | 
|   | 
 Please report any bugs or feature requests to | 
|   | 
 C<bug-palm-keyring at rt.cpan.org>, or through the web interface at | 
|   | 
 L<http://rt.cpan.org>.  I will be notified, and then you'll automatically be | 
|   | 
 notified of progress on your bug as I make changes. | 
|   | 
  | 
|  =head1 AUTHOR | 
 =head1 AUTHOR | 
|   | 
  | 
|  Andrew Fresh E<lt>andrew@mad-techies.org<gt> | 
 Andrew Fresh E<lt>andrew@mad-techies.orgE<gt> | 
|   | 
  | 
|   | 
 =head1 LICENSE AND COPYRIGHT | 
|   | 
  | 
|   | 
 Copyright 2004, 2005, 2006, 2007 Andrew Fresh, All Rights Reserved. | 
|   | 
  | 
|   | 
 This program is free software; you can redistribute it and/or | 
|   | 
 modify it under the same terms as Perl itself. | 
|   | 
  | 
|  =head1 SEE ALSO | 
 =head1 SEE ALSO | 
|   | 
  | 
|  Palm::PDB(3) | 
 Palm::PDB(3) | 
|   | 
  | 
|  Palm::StdAppInfo(3) | 
 Palm::StdAppInfo(3) | 
|   | 
  | 
|  =cut | 
 The Keyring for Palm OS website: | 
|   | 
 L<http://gnukeyring.sourceforge.net/> | 
|   | 
  | 
|   | 
 Johan Vromans also has a wxkeyring app that now uses this module, available | 
|   | 
 from his website at L<http://www.vromans.org/johan/software/> |