File: [local] / palm / Palm-Keyring / lib / Palm / Keyring.pm (download)
Revision 1.29, Mon Feb 19 00:22:42 2007 UTC (17 years, 5 months ago) by andrew
Branch: MAIN
Changes since 1.28: +454 -158 lines
support Encrypting and Packing v5 databases. At least in v4compatible mode. Need a test suite for the not v4 compatible, and updating the docs.
|
package Palm::Keyring;
# $RedRiver: Keyring.pm,v 1.28 2007/02/18 05:50:25 andrew Exp $
########################################################################
# Keyring.pm *** Perl class for Keyring for Palm OS databases.
#
# This started as Memo.pm, I just made it work for Keyring.
#
# 2006.01.26 #*#*# andrew fresh <andrew@cpan.org>
########################################################################
# Copyright (C) 2006, 2007 by Andrew Fresh
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
########################################################################
use strict;
use warnings;
use Carp;
use Data::Dumper;
use base qw/ Palm::StdAppInfo /;
use Digest::HMAC_SHA1 qw(hmac_sha1);
use Digest::SHA1 qw(sha1);
use Crypt::CBC;
use Digest::MD5 qw(md5);
use Crypt::DES;
my $ENCRYPT = 1;
my $DECRYPT = 0;
my $MD5_CBLOCK = 64;
my $kSalt_Size = 4;
my $EMPTY = q{};
my $SPACE = q{ };
my $NULL = chr 0;
my @CRYPTS = (
{ # None
name => 'None',
keylen => 8,
blocksize => 1,
default_iter => 500,
},
{ # DES-EDE3
name => 'DES_EDE3',
keylen => 24,
blocksize => 8,
DES_odd_parity => 1,
default_iter => 1000,
},
{ # AES128
name => 'Rijndael',
keylen => 16,
blocksize => 16,
default_iter => 100,
},
{ # AES256
name => 'Rijndael',
keylen => 32,
blocksize => 16,
default_iter => 250,
},
);
our $VERSION = 0.95;
sub new
{
my $classname = shift;
my $options = {};
# hashref arguments
if (ref $_[0] eq 'HASH') {
$options = shift;
}
# CGI style arguments
elsif ($_[0] =~ /^-[a-zA-Z0-9_]{1,20}$/) {
my %tmp = @_;
while ( my($key,$value) = each %tmp) {
$key =~ s/^-//;
$options->{lc $key} = $value;
}
}
else {
$options->{password} = shift;
$options->{version} = shift;
}
# Create a generic PDB. No need to rebless it, though.
my $self = $classname->SUPER::new();
$self->{name} = 'Keys-Gtkr'; # Default
$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;
# Set the version
$self->{version} = $options->{version} || 4;
# Set options
$self->{options} = $options;
# Set defaults
if ($self->{version} == 5) {
$self->{options}->{cipher} ||= 0; # 'None'
$self->{options}->{iterations} ||=
$CRYPTS[ $self->{options}->{cipher} ]{default_iter};
$self->{appinfo}->{cipher} ||= $self->{options}->{cipher};
$self->{appinfo}->{iter} ||= $self->{options}->{iterations};
};
if ( defined $options->{password} ) {
$self->Password($options->{password});
}
return $self;
}
sub import
{
Palm::PDB::RegisterPDBHandlers( __PACKAGE__, [ 'Gtkr', 'Gkyr' ], );
return 1;
}
# ParseRecord
sub ParseRecord
{
my $self = shift;
my $rec = $self->SUPER::ParseRecord(@_);
return $rec if ! exists $rec->{data};
if ($self->{version} == 4) {
# skip the first record because it contains the password.
return $rec if ! exists $self->{records};
my ( $name, $encrypted ) = split /$NULL/xm, $rec->{data}, 2;
return $rec if ! $encrypted;
$rec->{name} = $name;
$rec->{encrypted} = $encrypted;
delete $rec->{data};
} elsif ($self->{version} == 5) {
my $blocksize = $CRYPTS[ $self->{appinfo}->{cipher} ]{blocksize};
my ($field, $extra) = _parse_field($rec->{data});
my ($ivec, $encrypted) = unpack "A$blocksize A*", $extra;
if ($self->{options}->{v4compatible}) {
$rec->{name} = $field->{data};
} else {
$rec->{name} = $field;
}
$rec->{ivec} = $ivec;
$rec->{encrypted} = $encrypted;
} else {
die 'Unsupported Version';
return;
}
return $rec;
}
# PackRecord
sub PackRecord
{
my $self = shift;
my $rec = shift;
if ($self->{version} == 4) {
if ($rec->{encrypted}) {
if (! defined $rec->{name}) {
$rec->{name} = $EMPTY;
}
$rec->{data} = join $NULL, $rec->{name}, $rec->{encrypted};
delete $rec->{name};
delete $rec->{encrypted};
}
} elsif ($self->{version} == 5) {
my $field;
if ($rec->{name}) {
if ($self->{options}->{v4compatible}) {
$field = {
label => 'name',
font => 0,
data => $rec->{'name'},
};
} else {
$field = $rec->{name};
}
}
my $packed = '';
if ($field) {
$packed = _pack_field($field);
}
my $len = length $packed;
my $blocksize = $CRYPTS[ $self->{appinfo}->{cipher} ]{blocksize};
$rec->{data} = pack "A$len A$blocksize A*",
$packed, $rec->{ivec}, $rec->{encrypted};
} else {
die 'Unsupported Version';
}
return $self->SUPER::PackRecord($rec, @_);
}
# ParseAppInfoBlock
sub ParseAppInfoBlock
{
my $self = shift;
my $data = shift;
my $appinfo = {};
&Palm::StdAppInfo::parse_StdAppInfo($appinfo, $data);
# int8/uint8
# - Signed or Unsigned Byte (8 bits). C types: char, unsigned char
# int16/uint16
# - Signed or Unsigned Word (16 bits). C types: short, unsigned short
# int32/uint32
# - Signed or Unsigned Doubleword (32 bits). C types: int, unsigned int
# sz
# - Zero-terminated C-style string
if ($self->{version} == 4) {
# Nothing extra for version 4
} elsif ($self->{version} == 5) {
_parse_appinfo_v5($appinfo) || return;
} else {
die "Unsupported Version";
return;
}
return $appinfo;
}
sub _parse_appinfo_v5
{
my $appinfo = shift;
if (! exists $appinfo->{other}) {
# XXX Corrupt appinfo?
return;
}
my $unpackstr
= ("C1" x 8) # 8 uint8s in an array for the salt
. ("S1" x 2) # the iter (uint16) and the cipher (uint16)
. ("C1" x 8); # and finally 8 more uint8s for the hash
my (@salt, $iter, $cipher, @hash);
(@salt[0..7], $iter, $cipher, @hash[0..7])
= unpack $unpackstr, $appinfo->{other};
$appinfo->{salt} = sprintf "%02x" x 8, @salt;
$appinfo->{iter} = $iter;
$appinfo->{cipher} = $cipher;
$appinfo->{masterhash} = sprintf "%02x" x 8, @hash;
delete $appinfo->{other};
return $appinfo
}
# PackAppInfoBlock
sub PackAppInfoBlock
{
my $self = shift;
my $retval;
if ($self->{version} == 4) {
# Nothing to do for v4
} elsif ($self->{version} == 5) {
_pack_appinfo_v5($self->{appinfo});
} else {
die "Unsupported Version";
return;
}
return &Palm::StdAppInfo::pack_StdAppInfo($self->{appinfo});
}
sub _pack_appinfo_v5
{
my $appinfo = shift;
my $packstr
= ("C1" x 8) # 8 uint8s in an array for the salt
. ("S1" x 2) # the iter (uint16) and the cipher (uint16)
. ("C1" x 8); # and finally 8 more uint8s for the hash
my @salt = map { hex $_ } $appinfo->{salt} =~ /../gxm;
my @hash = map { hex $_ } $appinfo->{masterhash} =~ /../gxm;
my $packed = pack($packstr,
@salt,
$appinfo->{iter},
$appinfo->{cipher},
@hash
);
$appinfo->{other} = $packed;
return $appinfo
}
# Encrypt
sub Encrypt
{
my $self = shift;
my $rec = shift;
my $data = shift;
my $pass = shift || $self->{password};
if ( ! $pass && ! $self->{appinfo}->{key}) {
croak("password not set!\n");
}
if ( ! $rec) {
croak("Needed parameter 'record' not passed!\n");
}
if ( ! $data) {
croak("Needed parameter 'data' not passed!\n");
}
if ( $pass && ! $self->Password($pass)) {
croak("Incorrect Password!\n");
}
my $acct;
if ($rec->{encrypted}) {
$acct = $self->Decrypt($rec, $pass);
}
my $encrypted;
if ($self->{version} == 4) {
$self->{digest} ||= _calc_keys( $pass );
$encrypted = _encrypt_v4($data, $acct, $self->{digest});
$rec->{name} ||= $data->{name};
} elsif ($self->{version} == 5) {
my @recs = ($data, $acct);
my $name;
if ($self->{options}->{v4compatible}) {
$rec->{name} ||= $data->{name};
foreach my $rec (@recs) {
my @fields;
foreach my $k (sort keys %{ $rec }) {
my $field = {
label => $k,
font => 0,
data => $rec->{$k},
};
push @fields, $field;
}
$rec = \@fields;
}
}
my $ivec;
($encrypted, $ivec) = _encrypt_v5(
@recs,
$self->{appinfo}->{key},
$self->{appinfo}->{cipher},
);
if ($ivec) {
$rec->{ivec} = $ivec;
}
} else {
die "Unsupported Version";
}
if ($encrypted) {
if ($encrypted eq '1') {
return 1;
}
$rec->{attributes}{Dirty} = 1;
$rec->{attributes}{dirty} = 1;
$rec->{encrypted} = $encrypted;
return 1;
} else {
return;
}
}
sub _encrypt_v4
{
my $new = shift;
my $old = shift;
my $digest = shift;
$new->{account} ||= $EMPTY;
$new->{password} ||= $EMPTY;
$new->{notes} ||= $EMPTY;
my $changed = 0;
my $need_newdate = 0;
if ($old && %{ $old }) {
foreach my $key (keys %{ $new }) {
next if $key eq 'lastchange';
if ($new->{$key} ne $old->{$key}) {
$changed = 1;
last;
}
}
if ( exists $new->{lastchange} && exists $old->{lastchange} && (
$new->{lastchange}->{day} != $old->{lastchange}->{day} ||
$new->{lastchange}->{month} != $old->{lastchange}->{month} ||
$new->{lastchange}->{year} != $old->{lastchange}->{year}
)) {
$changed = 1;
$need_newdate = 0;
} else {
$need_newdate = 1;
}
} else {
$changed = 1;
}
# no need to re-encrypt if it has not changed.
return 1 if ! $changed;
my ($day, $month, $year);
if ($new->{lastchange} && ! $need_newdate ) {
$day = $new->{lastchange}->{day} || 1;
$month = $new->{lastchange}->{month} || 0;
$year = $new->{lastchange}->{year} || 0;
# XXX Need to actually validate the above information somehow
if ($year >= 1900) {
$year -= 1900;
}
} else {
$need_newdate = 1;
}
if ($need_newdate) {
($day, $month, $year) = (localtime)[3,4,5];
}
my $packed_date = _pack_keyring_date( {
year => $year,
month => $month,
day => $day,
});
my $plaintext = join $NULL,
$new->{account}, $new->{password}, $new->{notes}, $packed_date;
return _crypt3des( $plaintext, $digest, $ENCRYPT );
}
sub _encrypt_v5
{
my $new = shift;
my $old = shift;
my $key = shift;
my $cipher = shift;
my $ivec = shift || pack("C*",map {rand(256)} 1..8);
my $keylen = $CRYPTS[ $cipher ]{keylen};
my $cipher_name = $CRYPTS[ $cipher ]{name};
my $changed = 0;
my $need_newdate = 1;
my $date_index;
for (my $i = 0; $i < @{ $new }; $i++) {
if (
(exists $new->[$i]->{label_id} && $new->[$i]->{label_id} == 3) ||
(exists $new->[$i]->{label} && $new->[$i]->{label} eq 'lastchange')
) {
$date_index = $i;
if ( $old && $#{ $new } == $#{ $old } && (
$new->[$i]->{data}->{day} != $old->[$i]->{data}->{day} ||
$new->[$i]->{data}->{month} != $old->[$i]->{data}->{month} ||
$new->[$i]->{data}->{year} != $old->[$i]->{data}->{year}
)) {
$changed = 1;
$need_newdate = 0;
last;
}
} elsif ($old && $#{ $new } == $#{ $old }) {
my $n = join ':', %{ $new->[$i] };
my $o = join ':', %{ $old->[$i] };
if ($n ne $o) {
$changed = 1;
}
} elsif ($#{ $new } != $#{ $old }) {
$changed = 1;
}
}
if ($old && (! @{ $old }) && $date_index) {
$need_newdate = 0;
}
return 1, 0 if $changed == 0;
if ($need_newdate || ! defined $date_index) {
my ($day, $month, $year) = (localtime)[3,4,5];
my $date = {
year => $year,
month => $month,
day => $day,
};
if (defined $date_index) {
$new->[$date_index]->{data} = $date;
} else {
push @{ $new }, {
label => 'lastchange',
font => 0,
data => $date,
};
}
} else {
# XXX Need to actually validate the above information somehow
if ($new->[$date_index]->{data}->{year} >= 1900) {
$new->[$date_index]->{data}->{year} -= 1900;
}
}
my $decrypted;
foreach my $field (@{ $new }) {
$decrypted .= _pack_field($field);
}
my $encrypted;
if ($cipher_name eq 'None') {
# do nothing
$encrypted = $decrypted;
} elsif ($cipher_name eq 'DES_EDE3' or $cipher_name eq 'Rijndael') {
my $c = Crypt::CBC->new(
-literal_key => 1,
-key => $key,
-iv => $ivec,
-cipher => $cipher_name,
-keysize => $keylen,
-header => 'none',
-padding => 'oneandzeroes',
);
if (! $c) {
croak("Unable to set up encryption!");
}
$encrypted = $c->encrypt($decrypted);
} else {
die "Unsupported Version";
}
return $encrypted, $ivec;
}
# Decrypt
sub Decrypt
{
my $self = shift;
my $rec = shift;
my $pass = shift || $self->{password};
if ( ! $pass && ! $self->{appinfo}->{key}) {
croak("password not set!\n");
}
if ( ! $rec) {
croak("Needed parameter 'record' not passed!\n");
}
if ( ! $self->Password($pass)) {
croak("Invalid Password!\n");
}
if ( ! $rec->{encrypted} ) {
croak("No encrypted content!");
}
if ($self->{version} == 4) {
$self->{digest} ||= _calc_keys( $pass );
my $acct = _decrypt_v4($rec->{encrypted}, $self->{digest});
$acct->{name} ||= $rec->{name};
return $acct;
} elsif ($self->{version} == 5) {
my $fields = _decrypt_v5(
$rec->{encrypted}, $self->{appinfo}->{key},
$self->{appinfo}->{cipher}, $rec->{ivec},
);
if ($self->{options}->{v4compatible}) {
my %acct;
foreach my $f (@{ $fields }) {
$acct{ $f->{label} } = $f->{data};
}
$acct{name} ||= $rec->{name};
return \%acct;
} else {
return $fields;
}
} else {
die "Unsupported Version";
}
return;
}
sub _decrypt_v4
{
my $encrypted = shift;
my $digest = shift;
my $decrypted = _crypt3des( $encrypted, $digest, $DECRYPT );
my ( $account, $password, $notes, $packed_date )
= split /$NULL/xm, $decrypted, 4;
my $modified;
if ($packed_date) {
$modified = _parse_keyring_date($packed_date);
}
return {
account => $account,
password => $password,
notes => $notes,
lastchange => $modified,
};
}
sub _decrypt_v5
{
my $encrypted = shift;
my $key = shift;
my $cipher = shift;
my $ivec = shift;
my $keylen = $CRYPTS[ $cipher ]{keylen};
my $cipher_name = $CRYPTS[ $cipher ]{name};
my $decrypted;
if ($cipher_name eq 'None') {
# do nothing
$decrypted = $encrypted;
} elsif ($cipher_name eq 'DES_EDE3' or $cipher_name eq 'Rijndael') {
my $c = Crypt::CBC->new(
-literal_key => 1,
-key => $key,
-iv => $ivec,
-cipher => $cipher_name,
-keysize => $keylen,
-header => 'none',
-padding => 'oneandzeroes',
);
if (! $c) {
croak("Unable to set up encryption!");
}
$encrypted .= $NULL x $keylen; # pad out a keylen
$decrypted = $c->decrypt($encrypted);
} else {
die "Unsupported Version";
return;
}
my @fields;
while ($decrypted) {
my $field;
($field, $decrypted) = _parse_field($decrypted);
if (! $field) {
last;
}
push @fields, $field;
}
return \@fields;
}
# Password
sub Password
{
my $self = shift;
my $pass = shift;
my $new_pass = shift;
if (! $pass) {
delete $self->{password};
delete $self->{key};
return 1;
}
if (
($self->{version} == 4 && ! exists $self->{records}) ||
($self->{version} == 5 && ! exists $self->{appinfo}->{masterhash})
) {
if ($self->{version} == 4) {
# 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 $v4compat = $self->{options}->{v4compatible};
$self->{options}->{v4compatible} = 0;
my @accts = ();
foreach my $i (0..$#{ $self->{records} }) {
if ($self->{version} == 4 && $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) {
if ($self->{version} == 4 && $i == 0) {
next;
}
delete $self->{records}->[$i]->{encrypted};
$self->Encrypt($self->{records}->[$i], $accts[$i], $pass);
}
$self->{options}->{v4compatible} = $v4compat;
}
if (defined $self->{password} && $pass eq $self->{password}) {
# already verified this password
return 1;
}
if ($self->{version} == 4) {
# AFAIK the thing we use to test the password is
# always in the first entry
my $valid = _password_verify_v4($pass, $self->{records}->[0]->{data});
# May as well generate the keys we need now, since we know the password is right
if ($valid) {
$self->{digest} = _calc_keys($pass);
if ($self->{digest} ) {
$self->{password} = $pass;
return 1;
}
}
} elsif ($self->{version} == 5) {
return _password_verify_v5($pass, $self->{appinfo});
} else {
# XXX unsupported version
}
return;
}
sub _password_verify_v4
{
my $pass = shift;
my $data = shift;
if (! $pass) { croak('No password specified!'); };
# XXX die "No encrypted password in file!" unless defined $data;
if ( ! defined $data) { return; };
$data =~ s/$NULL$//xm;
my $salt = substr $data, 0, $kSalt_Size;
my $msg = $salt . $pass;
$msg .= "\0" x ( $MD5_CBLOCK - length $msg );
my $digest = md5($msg);
if (! $data eq $salt . $digest ) {
return;
}
return 1;
}
sub _password_verify_v5
{
my $pass = shift;
my $appinfo = shift;
my $salt = pack("H*", $appinfo->{salt});
my ($key, $hash) = _calc_key_v5(
$pass, $salt, $appinfo->{iter},
$CRYPTS[ $appinfo->{cipher} ]{keylen},
$CRYPTS[ $appinfo->{cipher} ]{DES_odd_parity},
);
#print "Key: '". unpack("H*", $key) . "'\n";
#print "Hash: '". $hash . "'\n";
#print "Hash: '". $appinfo->{masterhash} . "'\n";
if ($appinfo->{masterhash} eq $hash) {
$appinfo->{key} = $key;
} else {
return;
}
return $key;
}
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;
if ($self->{version} == 4) {
my $data = _password_update_v4($pass, @_);
if (! $data) {
carp("Failed to update password!");
return;
}
# AFAIK the thing we use to test the password is
# always in the first entry
$self->{records}->[0]->{data} = $data;
$self->{password} = $pass;
$self->{digest} = _calc_keys( $self->{password} );
return 1;
} elsif ($self->{version} == 5) {
my $cipher = shift || $self->{appinfo}->{cipher};
my $iter = shift || $self->{appinfo}->{iter};
my $salt = shift || 0;
my $hash = _password_update_v5(
$self->{appinfo}, $pass, $cipher, $iter, $salt
);
if (! $hash) {
carp("Failed to update password!");
return;
}
return 1;
} else {
croak("Unsupported version ($self->{version})");
}
return;
}
sub _password_update_v4
{
my $pass = shift;
if (! defined $pass) { croak('No password specified!'); };
my $salt;
for ( 1 .. $kSalt_Size ) {
$salt .= chr int rand 255;
}
my $msg = $salt . $pass;
$msg .= "\0" x ( $MD5_CBLOCK - length $msg );
my $digest = md5($msg);
my $data = $salt . $digest; # . "\0";
return $data;
}
sub _password_update_v5
{
my $appinfo = shift;
my $pass = shift;
my $cipher = shift;
my $iter = shift;
# I thought this needed to be 'blocksize', but apparently not.
#my $length = $CRYPTS[ $cipher ]{blocksize};
my $length = 8;
my $salt = shift || pack("C*",map {rand(256)} 1..$length);
my ($key, $hash) = _calc_key_v5(
$pass, $salt, $iter,
$CRYPTS[ $cipher ]->{keylen},
$CRYPTS[ $cipher ]->{DES_odd_parity},
);
$appinfo->{salt} = unpack "H*", $salt;
$appinfo->{iter} = $iter;
$appinfo->{cipher} = $cipher;
$appinfo->{key} = $key;
$appinfo->{masterhash} = $hash;
return $key;
}
sub _calc_keys
{
my $pass = shift;
if (! defined $pass) { croak('No password defined!'); };
my $digest = md5($pass);
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 "Digest: ", $digest, "\n";
# print length $digest, "\n";
#--------------------------------------------------
return $digest;
}
sub _calc_key_v5
{
my ($pass, $salt, $iter, $keylen, $dop) = @_;
my $key = _pbkdf2( $pass, $salt, $iter, $keylen, \&hmac_sha1 );
if ($dop) { $key = DES_odd_parity($key); }
my $hash = unpack("H*", substr(sha1($key.$salt),0, 8));
return $key, $hash;
}
sub _crypt3des
{
my ( $plaintext, $passphrase, $flag ) = @_;
$passphrase .= $SPACE x ( 16 * 3 );
my $cyphertext = $EMPTY;
my $size = length $plaintext;
#print "STRING: '$plaintext' - Length: " . (length $plaintext) . "\n";
my @C;
for ( 0 .. 2 ) {
$C[$_] =
new Crypt::DES( pack 'H*', ( substr $passphrase, 16 * $_, 16 ));
}
for ( 0 .. ( ($size) / 8 ) ) {
my $pt = substr $plaintext, $_ * 8, 8;
#print "PT: '$pt' - Length: " . length($pt) . "\n";
if (! length $pt) { next; };
if ( (length $pt) < 8 ) {
if ($flag == $DECRYPT) { croak('record not 8 byte padded'); };
my $len = 8 - (length $pt);
$pt .= ($NULL x $len);
}
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;
}
sub _parse_field
{
my $field = shift;
my @labels;
$labels[0] = 'name';
$labels[1] = 'account';
$labels[2] = 'password';
$labels[3] = 'lastchange';
$labels[255] = 'notes';
my ($len) = unpack "S1", $field;
if ($len + 4 > length $field) {
return undef, $field;
}
my $unpackstr = "S1 C1 C1 A$len";
if ($len % 2) {
# trim the 0/1 byte padding for next even address.
$unpackstr .= ' x'
}
$unpackstr .= ' A*';
my (undef, $label, $font, $data, $leftover)
= unpack $unpackstr, $field;
if ($label == 3) {
$data = _parse_keyring_date($data);
}
return {
#len => $len,
label => $labels[ $label ] || $label,
label_id => $label,
font => $font,
data => $data,
}, $leftover;
}
sub _pack_field
{
my $field = shift;
my %labels = (
name => 0,
account => 1,
password => 2,
lastchange => 3,
notes => 255,
);
my $label = $field->{label_id} || $labels{ $field->{label} };
my $font = $field->{font} || 0;
my $data = $field->{data} || '';
if ($label == 3) {
$data = _pack_keyring_date($data);
}
my $len = length $data;
my $packstr = "S1 C1 C1 A*";
my $packed = pack $packstr, ($len, $label, $font, $data);
if ($len % 2) {
# add byte padding for next even address.
$packed .= $NULL;
}
return $packed;
}
sub _parse_keyring_date
{
my $data = shift;
my $u = unpack 'n', $data;
my $year = (($u & 0xFE00) >> 9) + 4; # since 1900
my $month = (($u & 0x01E0) >> 5) - 1; # 0-11
my $day = (($u & 0x001F) >> 0); # 1-31
return {
year => $year,
month => $month || 0,
day => $day || 1,
};
}
sub _pack_keyring_date
{
my $d = shift;
my $year = $d->{year};
my $month = $d->{month};
my $day = $d->{day};
$year -= 4;
$month++;
return pack 'n', $day | ($month << 5) | ($year << 9);
}
sub _hexdump
{
my $prefix = shift; # What to print in front of each line
my $data = shift; # The data to dump
my $maxlines = shift; # Max # of lines to dump
my $offset; # Offset of current chunk
for ($offset = 0; $offset < length($data); $offset += 16)
{
my $hex; # Hex values of the data
my $ascii; # ASCII values of the data
my $chunk; # Current chunk of data
last if defined($maxlines) && ($offset >= ($maxlines * 16));
$chunk = substr($data, $offset, 16);
($hex = $chunk) =~ s/./sprintf "%02x ", ord($&)/ges;
($ascii = $chunk) =~ y/\040-\176/./c;
printf "%s %-48s|%-16s|\n", $prefix, $hex, $ascii;
}
}
sub _bindump
{
my $prefix = shift; # What to print in front of each line
my $data = shift; # The data to dump
my $maxlines = shift; # Max # of lines to dump
my $offset; # Offset of current chunk
for ($offset = 0; $offset < length($data); $offset += 8)
{
my $bin; # binary values of the data
my $ascii; # ASCII values of the data
my $chunk; # Current chunk of data
last if defined($maxlines) && ($offset >= ($maxlines * 8));
$chunk = substr($data, $offset, 8);
($bin = $chunk) =~ s/./sprintf "%08b ", ord($&)/ges;
($ascii = $chunk) =~ y/\040-\176/./c;
printf "%s %-72s|%-8s|\n", $prefix, $bin, $ascii;
}
}
# Thanks to Jochen Hoenicke <hoenicke@gmail.com>
# (one of the authors of Palm Keyring)
# for these next two subs.
# Usage pbkdf2(password, salt, iter, keylen, prf)
# iter is number of iterations
# keylen is length of generated key in bytes
# prf is the pseudo random function (e.g. hmac_sha1)
# returns the key.
sub _pbkdf2($$$$$)
{
my ($password, $salt, $iter, $keylen, $prf) = @_;
my ($k, $t, $u, $ui, $i);
$t = "";
for ($k = 1; length($t) < $keylen; $k++) {
$u = $ui = &$prf($salt.pack('N', $k), $password);
for ($i = 1; $i < $iter; $i++) {
$ui = &$prf($ui, $password);
$u ^= $ui;
}
$t .= $u;
}
return substr($t, 0, $keylen);
}
sub DES_odd_parity($) {
my $key = $_[0];
my ($r, $i);
my @odd_parity = (
1, 1, 2, 2, 4, 4, 7, 7, 8, 8, 11, 11, 13, 13, 14, 14,
16, 16, 19, 19, 21, 21, 22, 22, 25, 25, 26, 26, 28, 28, 31, 31,
32, 32, 35, 35, 37, 37, 38, 38, 41, 41, 42, 42, 44, 44, 47, 47,
49, 49, 50, 50, 52, 52, 55, 55, 56, 56, 59, 59, 61, 61, 62, 62,
64, 64, 67, 67, 69, 69, 70, 70, 73, 73, 74, 74, 76, 76, 79, 79,
81, 81, 82, 82, 84, 84, 87, 87, 88, 88, 91, 91, 93, 93, 94, 94,
97, 97, 98, 98,100,100,103,103,104,104,107,107,109,109,110,110,
112,112,115,115,117,117,118,118,121,121,122,122,124,124,127,127,
128,128,131,131,133,133,134,134,137,137,138,138,140,140,143,143,
145,145,146,146,148,148,151,151,152,152,155,155,157,157,158,158,
161,161,162,162,164,164,167,167,168,168,171,171,173,173,174,174,
176,176,179,179,181,181,182,182,185,185,186,186,188,188,191,191,
193,193,194,194,196,196,199,199,200,200,203,203,205,205,206,206,
208,208,211,211,213,213,214,214,217,217,218,218,220,220,223,223,
224,224,227,227,229,229,230,230,233,233,234,234,236,236,239,239,
241,241,242,242,244,244,247,247,248,248,251,251,253,253,254,254);
for ($i = 0; $i< length($key); $i++) {
$r .= chr($odd_parity[ord(substr($key, $i, 1))]);
}
return $r;
}
1;
__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
Andrew Fresh E<lt>andrew@cpan.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
Palm::PDB(3)
Palm::StdAppInfo(3)
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/sw_palmkeyring.html>