File Coverage

lib/Class/Usul/Crypt.pm

Criterion	Covered	Total	%
statement	31	31	100.0
branch			n/a
condition			n/a
subroutine	13	13	100.0
pod	4	4	100.0
total	48	48	100.0

package Class::Usul::Crypt;

use strict;
use warnings;

use Class::Usul::Constants qw( NUL );
use Class::Usul::Functions qw( create_token is_coderef is_hashref );
use Crypt::CBC;
use English                qw( -no_match_vars );
use Exporter 5.57          qw( import );
use MIME::Base64;
use Sys::Hostname;

our @EXPORT_OK = qw( cipher_list decrypt default_cipher encrypt );

my $DEFAULT = 'Twofish2'; my $SEED = do { local $RS = undef; <DATA> };

# Private functions
my $_decode = sub {
   my $v = $_[ 0 ]; $v =~ tr{ \t}{01}; pack 'b*', $v;
};

my $_prepare = sub {
   my $v = $_[ 0 ]; my $pad = " \t" x 8; $v =~ s{^$pad|[^ \t]}{}g; $v;
};

my $_dref = sub {
   (is_coderef $_[ 0 ]) ? ($_[ 0 ]->() // NUL) : ($_[ 0 ] // NUL);
};

my $_eval = sub {
   my $v = $_prepare->( $_[ 0 ] ); $v ? ((eval $_decode->( $v )) || NUL) : NUL;
};

my $_cipher_name = sub {
   (is_hashref $_[ 0 ]) ? $_[ 0 ]->{cipher} || $DEFAULT : $DEFAULT;
};

my $_compose = sub {
   $_eval->( $_dref->( $_[ 0 ]->{seed} ) || $SEED ).$_dref->( $_[ 0 ]->{salt} );
};

my $_new_crypt_cbc = sub {
   Crypt::CBC->new( -cipher => $_[ 0 ], -key => $_[ 1 ] );
};

my $_token = sub {
   create_token( $_compose->( $_[ 0 ] || {} ) );
};

my $_wards = sub {
   (is_hashref $_[ 0 ]) || !$_[ 0 ] ? $_token->( $_[ 0 ] ) : $_[ 0 ];
};

my $_cipher = sub {
   $_new_crypt_cbc->( $_cipher_name->( $_[ 0 ] ), $_wards->( $_[ 0 ] ) );
};

# Public functions
sub cipher_list () {
   return ( qw( Blowfish Rijndael Twofish2 ) );
}

sub decrypt (;$$) {
   return $_cipher->( $_[ 0 ] )->decrypt( decode_base64( $_[ 1 ] ) );
}

sub default_cipher () {
   return $DEFAULT;
}

sub encrypt (;$$) {
   return encode_base64( $_cipher->( $_[ 0 ] )->encrypt( $_[ 1 ] ), NUL );
}

1;

=pod

=head1 Name

Class::Usul::Crypt - Encryption / decryption functions

=head1 Synopsis

   use Class::Usul::Crypt qw(decrypt encrypt);

   my $args = q(); # OR
   my $args = 'salt'; # OR
   my $args = { salt => 'salt', seed => 'whiten this' };

   $args->{cipher} = 'Twofish2'; # Optionally

   my $base64_encrypted_text = encrypt( $args, $plain_text );

   my $plain_text = decrypt( $args, $base64_encrypted_text );

=head1 Description

Exports a pair of functions to encrypt / decrypt data. Obfuscates the default
encryption key

=head1 Configuration and Environment

The C<$key> can be a string (including the null string) or a hash reference
with I<salt> and I<seed> keys. The I<seed> attribute can be a code reference in
which case it will be called with no argument and the return value used

Lifted from L<Acme::Bleach> the default seed for the key generator has been
whitened and included in this source file

The seed is C<eval>'d in string context and then the salt is concatenated onto
it before being passed to L<create token|Class::Usul::Functions/create_token>.
Uses this value as the key for a L<Crypt::CBC> object

=head1 Subroutines/Methods

=head2 decrypt

   my $plain = decrypt( $salt || \%params, $encoded );

Decodes and decrypts the C<$encoded> argument and returns the plain
text result. See the L</encrypt> method

=head2 encrypt

   my $encoded = encrypt( $salt || \%params, $plain );

Encrypts the plain text passed in the C<$plain> argument and returns
it Base64 encoded. By default L<Crypt::Twofish2> is used to do the
encryption. The optional C<< $params->{cipher} >> attribute overrides this

=head2 cipher_list

   @list_of_ciphers = cipher_list();

Returns the list of ciphers supported by L<Crypt::CBC>. These may not
all be installed

=head2 default_cipher

   $ciper_name = default_cipher();

Returns I<Twofish2>

=head1 Diagnostics

None

=head1 Dependencies

=over 3

=item L<Crypt::CBC>

=item L<Crypt::Twofish2>

=item L<Exporter>

=item L<MIME::Base64>

=back

=head1 Incompatibilities

There are no known incompatibilities in this module

=head1 Bugs and Limitations

There are no known bugs in this module.
Please report problems to the address below.
Patches are welcome

=head1 Author

Peter Flanigan, C<< <[e-mail]> >>

=head1 License and Copyright

Copyright (c) 2017 Peter Flanigan. All rights reserved

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself. See L<perlartistic>

This program is distributed in the hope that it will be useful,
but WITHOUT WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE

=cut

# Local Variables:
# mode: perl
# tab-width: 3
# End:

__DATA__