# @(#)$Id: Crypt.pm 245 2013-02-10 00:03:07Z pjf $

package Class::Usul::Crypt;

use strict;
use warnings;
use namespace::clean -except => 'meta';
use version; our $VERSION = qv( sprintf '0.11.%d', q$Rev: 245 $ =~ /\d+/gmx );

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

use Sub::Exporter::Progressive -setup => {
   exports => [ qw(decrypt encrypt cipher_list default_cipher) ],
   groups  => { default => [], },
};

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

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

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

sub cipher_list () {
   ( qw(Blowfish Rijndael Twofish) );
}

sub default_cipher () {
   q(Twofish);
}

# Private functions

sub __cipher {
   Crypt::CBC->new( -cipher => __cname( $_[ 0 ] ), -key => __token( $_[ 0 ] ) );
}

sub __cname {
   (is_hashref $_[ 0 ]) ? $_[ 0 ]->{cipher} || default_cipher : default_cipher;
}

sub __token {
   substr create_token( __inflate( $_[ 0 ] ) ), 0, 32;
}

sub __inflate {
   __compose( (is_hashref $_[ 0 ]) ? $_[ 0 ] : { salt => $_[ 0 ] || NUL } );
}

sub __compose {
   __prepare( __deref( $_[ 0 ]->{seed} ) // $SEED ).__deref( $_[ 0 ]->{salt} );
}

sub __deref {
   (is_coderef $_[ 0 ]) ? $_[ 0 ]->() : $_[ 0 ];
}

sub __prepare {
   my $y = $_[ 0 ]; my $x = " \t" x 8; $y =~ s{^$x|[^ \t]}{}g; __whiten( $y );
}

sub __whiten {
   my $y = $_[ 0 ] or return ''; $y =~ tr{ \t}{01}; $y = pack 'b*', $y; eval $y;
}

1;

=pod

=head1 Name

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

=head1 Version

0.11.$Revision: 245 $

=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} = 'Twofish'; # 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 ref with
I<salt> and I<seed> keys. The I<seed> attribute can be a code ref in which
case it will be called with no argument and the return value used

=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::Twofish> 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<Twofish>

=head2 __cipher

Lifted from L<Acme::Bleach> this recovers the default seed for the key
generator

Generates the key used by the C<encrypt> and C<decrypt> methods. The
seed is C<eval>'d in string context and then the salt is concatenated
onto it before being passed to
C<Class::Usul::Functions/create_token>. Uses this value as the key for
a L<Crypt::CBC> object which it creates and returns

=head1 Diagnostics

None

=head1 Dependencies

=over 3

=item L<Crypt::CBC>

=item L<Crypt::Twofish>

=item L<MIME::Base64>

=item L<Sub::Exporter>

=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<< <Support at RoxSoft.co.uk> >>

=head1 License and Copyright

Copyright (c) 2013 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__