File Coverage

blib/lib/Palm/Keyring.pm

Criterion	Covered	Total	%
statement	136	574	23.6
branch	36	224	16.0
condition	14	173	8.0
subroutine	17	36	47.2
pod	9	9	100.0
total	212	1016	20.8

package Palm::Keyring;
# $RedRiver: Keyring.pm,v 1.45 2007/02/26 00:02:13 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
########################################################################
# 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 base qw/ Palm::StdAppInfo /;

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 = (
    {
        alias     => 'None',
        name      => 'None',
        keylen    => 8,
        blocksize => 1,
        default_iter => 500,
    },
    {
        alias     => 'DES-EDE3',
        name      => 'DES_EDE3',
        keylen    => 24,
        blocksize =>  8,
        DES_odd_parity => 1,
        default_iter => 1000,
    },
    {
        alias     => 'AES128',
        name      => 'Rijndael',
        keylen    => 16,
        blocksize => 16,
        default_iter => 100,
    },
    {
        alias     => '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'
        my $c = crypts($self->{options}->{cipher})
            or croak('Unknown cipher ' . $self->{options}->{cipher});
        $self->{options}->{iterations} ||= $c->{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;
}

# Accessors

sub crypts
{
    my $crypt = shift;
    if (! defined $crypt || ! length $crypt) {
        return;
    } elsif ($crypt =~ /\D/) {
        foreach my $c (@CRYPTS) {
            if ($c->{alias} eq $crypt) {
                return $c;
            }
        }
        # didn't find it.
        return;
    } else {
        return $CRYPTS[$crypt];
    }
}

# 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 $c = crypts( $self->{appinfo}->{cipher} )
            or croak('Unknown cipher ' . $self->{appinfo}->{cipher});
        my $blocksize = $c->{blocksize};
        my ($field, $extra) = _parse_field($rec->{data});
        delete $rec->{data};

        $rec->{name}      = $field->{data};
        $rec->{ivec}      = substr $extra, 0, $blocksize;
        $rec->{encrypted} = substr $extra, $blocksize;

    } 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}) {
            $field = {
                'label_id' => 1,
                'data'     => $rec->{name},
                'font'     => 0,
            };
        } else {
            $field = {
                'label_id' => $EMPTY,
                'data'     => $EMPTY,
                'font'     => 0,
            };
        }
        my $packed = _pack_field($field);

        $rec->{data} = join '', $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
        . ("n1" 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
        . ("n1" 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};
    my $ivec = shift;

    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 @accts = ($data, $acct);
        if ($self->{options}->{v4compatible}) {
            $rec->{name} ||= $data->{name};
            foreach my $a (@accts) {
                my @fields;
                foreach my $k (sort keys %{ $a }) {
                    my $field = {
                        label    => $k,
                        font     => 0,
                        data     => $a->{$k},
                    };
                    push @fields, $field;
                }
                $a = \@fields;
            }
        }

        ($encrypted, $ivec) = _encrypt_v5(
            @accts,
            $self->{appinfo}->{key},
            $self->{appinfo}->{cipher},
            $ivec,
        );
        if (defined $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;
    my $c = crypts($cipher) or croak('Unknown cipher ' . $cipher);

    if (! defined $ivec) {
        $ivec = pack("C*",map {rand(256)} 1..$c->{blocksize});
    }

    my $changed = 0;
    my $need_newdate = 1;
    my $date_index;
    for (my $i = 0; $i < @{ $new }; $i++) {
        if (
            ($new->[$i]->{label_id} && $new->[$i]->{label_id} == 3) ||
            ($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;
            }

        } 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 ($c->{name} eq 'None') {
        # do nothing
        $encrypted = $decrypted;

    } elsif ($c->{name} eq 'DES_EDE3' or $c->{name} eq 'Rijndael') {
        require Crypt::CBC;
        my $cbc = Crypt::CBC->new(
            -key         => $key,
            -literal_key => 1,
            -iv          => $ivec,
            -cipher      => $c->{name},
            -keysize     => $c->{keylen},
            -blocksize   => $c->{blocksize},
            -header      => 'none',
            -padding     => 'oneandzeroes',
        );

        if (! $c) {
            croak("Unable to set up encryption!");
        }

        $encrypted = $cbc->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 ( $pass && ! $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 $c = crypts($cipher) or croak('Unknown cipher ' . $cipher);

    my $decrypted;

    if ($c->{name} eq 'None') {
        # do nothing
        $decrypted = $encrypted;

    } elsif ($c->{name} eq 'DES_EDE3' or $c->{name} eq 'Rijndael') {
        require Crypt::CBC;
        my $cbc = Crypt::CBC->new(
            -key         => $key,
            -literal_key => 1,
            -iv          => $ivec,
            -cipher      => $c->{name},
            -keysize     => $c->{keylen},
            -blocksize   => $c->{blocksize},
            -header      => 'none',
            -padding     => 'oneandzeroes',
        );

        if (! $c) {
            croak("Unable to set up encryption!");
        }
        my $len = $c->{blocksize} - length($encrypted) % $c->{blocksize};
        $encrypted .= $NULL x $len;
        $decrypted  = $cbc->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->{appinfo}->{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($self->{appinfo}, $pass);
    } else {
        # XXX unsupported version
    }

    return;
}

sub _password_verify_v4
{
    require Digest::MD5;
    import Digest::MD5 qw(md5);

    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 ne $salt . $digest ) {
        return;
    }

    return 1;
}

sub _password_verify_v5
{
    my $appinfo = shift;
    my $pass    = shift;

    my $salt = pack("H*", $appinfo->{salt});

    my $c = crypts($appinfo->{cipher})
        or croak('Unknown cipher ' . $appinfo->{cipher});
    my ($key, $hash) = _calc_key_v5(
        $pass, $salt, $appinfo->{iter},
        $c->{keylen},
        $c->{DES_odd_parity},
    );

    #print "Iter: '" . $appinfo->{iter} . "'\n";
    #print "Key:  '". unpack("H*", $key) . "'\n";
    #print "Salt: '". unpack("H*", $salt) . "'\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
{
    require Digest::MD5;
    import Digest::MD5 qw(md5);

    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 $c = crypts($cipher) or croak('Unknown cipher ' . $cipher);
    my ($key, $hash) = _calc_key_v5(
        $pass, $salt, $iter,
        $c->{keylen},
        $c->{DES_odd_parity},
    );

    $appinfo->{salt}           = unpack "H*", $salt;
    $appinfo->{iter}           = $iter;
    $appinfo->{cipher}         = $cipher;
    $appinfo->{masterhash}     = $hash;
    $appinfo->{key}            = $key;

    return $key;
}

# Helpers

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) = @_;

    require Digest::HMAC_SHA1;
    import  Digest::HMAC_SHA1 qw(hmac_sha1);
    require Digest::SHA1;
    import  Digest::SHA1 qw(sha1);

    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
{
    require Crypt::DES;

    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 "n1", $field;
    if ($len + 4 > length $field) {
        return undef, $field;
    }
    my $unpackstr = "x2 C1 C1 A$len";
    my $offset    =   2 +1 +1 +$len;
    if ($len % 2) { # && $len + 4 < length $field) {
        # trim the 0/1 byte padding for next even address.
        $offset++;
        $unpackstr .= ' x'
    }

    my ($label, $font, $data) = unpack $unpackstr, $field;
    my $leftover = substr $field, $offset;

    if ($label && $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 $packed;
    if (defined $field) {
        my $label = $field->{label_id} || 0;
        if (defined $field->{label} && ! $label) {
            $label = $labels{ $field->{label} };
        }
        my $font  = $field->{font} || 0;
        my $data  = defined $field->{data} ? $field->{data} : $EMPTY;

        if ($label && $label == 3) {
            $data = _pack_keyring_date($data);
        }
        my $len = length $data;
        my $packstr = "n1 C1 C1 A*";

        $packed = pack $packstr, ($len, $label, $font, $data);

        if ($len % 2) {
            # add byte padding for next even address.
            $packed .= $NULL;
        }
    } else {
        my $packstr = "n1 C1 C1 x1";
        $packed = pack $packstr, 0, 0, 0;
    }

    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
# (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__