package SecureString;
use 5.010;
use strict; use warnings; use re 'taint'; use autodie;
our $VERSION = 0.0000;# Created: 2011-07-18

use Carp qw/ confess cluck /;
use overload
  'bool' => \&_string,
  '""' => \&_string,
  '0+' => \&_number,
;

use Hash::Util::FieldHash qw(id register);
my %STRING;

sub new {
  my ($class, $value, %opt) = @_;
  my $self = bless
    { obfuscator => \&_default_obfuscator,
      cache_masked => 1,
      recompute_masked => 1,
      %opt
    }, $class;

  register( $self, \%STRING );
  $self->set( $value );
  return $self;
}

sub set {
  my $self = shift;
  $STRING{id $self} = shift;
  delete $$self{masked} if $$self{recompute_masked} and $$self{obfuscator};
  return $self;
}


sub get {
  my $self = shift;
  return $self unless $self->_match_caller( $$self{allow} );# Default allow all
  return $STRING{id $self};
}


sub get_masked {
  my $self = shift;
  return $$self{masked} if $$self{masked};
  my $masked;
  $masked = $$self{obfuscator}->($STRING{id $self}) if $$self{obfuscator};
  $masked //= 'XXXXX';
  $$self{masked} = $masked if $$self{cache_masked};
  return $masked;
}


## Completely untested:
sub STORABLE_freeze {
  my ($self, $cloning) = @_;
  # Allow cloning, but do not save value when storing
  my $value = $cloning ? $STRING{id $self} : $self->get_masked;
  return ($value, $self);
}

sub STORABLE_thaw {
  my ($self, $cloning, $value, $obj) = @_;
  %$self = %$obj;
  $STRING{id $self} = $value;
}

## Doesn't work:
sub yaml_dump {
  my $self = shift;
  YAML::Node->new( $self->get_masked );
}


sub _string {
  my $self = shift;
  if ($$self{cluck} and (1 eq $$self{cluck} or $self->_match_caller( $$self{cluck} ))) {
    $self->_show_caller("Attempt to access string value of ".$self->get_masked);
    cluck "\n";
  }
  return $self->get_masked unless $self->_match_caller( $$self{auto_get} || [] );# Default do not match
  return $STRING{id $self};
}

sub _number {
  confess "Attempted to use SecureString as a number";
}


sub _show_caller {
  my ($self, $msg, $level) = @_;
  $level = $level ? $level + 1 : 2;
  my ($pkg, $file, $line, $sub) = $self->_caller($level);
  print STDERR "$msg at $sub($line)";
}


sub _caller {
  my ($self, $level) = @_;
  my ($pkg, $file, $line) = caller($level);
  my (undef, undef, undef, $sub) = caller($level+1);
  $_ //= "" for $pkg, $file, $line, $sub;
  $sub ||= "${pkg}::";
  return ($pkg, $file, $line, $sub);
}

sub _match_caller {
  my ($self, $match, $level) = @_;
  return 1 unless $match;
  $level = $level ? $level + 1 : 2;
  my @caller = $self->_caller($level);
  for ('ARRAY' eq ref($match) ? @$match : $match) {
    return 1 if $self->_match_caller_item( $_, $level+1, @caller );
  }
  return 0;
}

sub _match_caller_item {
  my ($self, $match, $level, $pkg, $file, $line, $sub) = @_;
  given (ref($match)) {
    when ('')        { return 1 if $match eq $pkg or $match eq "$sub()" or $match eq "$sub($line)" }
    when ('Regexp')  { return 1 if "$sub($line)" =~ $match }
    when ('CODE')    { return 1 if $match->($level+1, $pkg, $file, $line, $sub) }
    defult { die "Do not know how to match caller against item of type $_" }
  }
  return 0;
}

sub _default_obfuscator { "X"x(length($_[0])) }




1;

__END__

=pod

=head1 NAME

SecureString - Obfuscated strings exept when you need them

=head1 SYNOPSIS

 use strict;
 use SecureString;

 # for simple cases (beware passing value from -get() to external modules!):
 my $CreditCardNumber = SecureString->new( "1234567887654321" );
 say STDERR "DEBUG: Got a CCN ($CreditCardNumber)";   # DEBUG: Got a CCN (XXXXXXXXXXXXXXXX)
 say "The real CCN: ", $CreditCardNumber->get;        # The real CCN: 1234567887654321


 # more complex:
 use YAML;
 my $CreditCardNumber = SecureString->new( "1234567887654321",
     auto_get => qr/^Business::OnlinePayment/,        # probably a bit too permissive
     allow => "My::Secure::Module",
     obfuscator => sub { "XXXXXXXXXXXX".substr($_[0], -4) },
 );

 my %tx_info = ( card_number => $CreditCardNumber, ... );
 print Dump \%tx_info;                                # "card_number: XXXXXXXXXXXX4321"

 my $tx = new Business::OnlinePayment("AuthorizeNet");
 $tx->content( %tx_info );
 $tx->submit;                                         # sends actual card number to AuthorizeNet


 # debugging and diagnosis (stack trace whenever stringified)
 #   Use stack traces to set appropriate "auto_get" above
 my $CreditCardNumber = SecureString->new( "1234567887654321",
     cluck => 1,
 );


=head1 DESCRIPTION

Creates a value which will be obfuscated unless accessed in a particular
way. Access can be restricted to specific classes or even specific
subroutines/methods.

There are no methods which unconditionally return the unmasked string
value, thus even code which attempts to walk all defined methods (but who
does that!?) will fail to output the unmasked value unless it has been
granted permission.


TODO: Storable and YAML hooks have been defined so that these modules can
be safely used with SecureStrings. Patches accepted to support any other
serialization modules. The unmasked string is stored "inside-out" so that
at worst, unsupported serialization modules will export only the
non-sensitive configuration data.


=head1 USAGE

=head3 new

=over 4

=item auto_get

ArrayRef or single item describing packages and/or subs for which
stringification should yield the unmasked value. This allows you to pass
SecureStrings to external dependencies and have them stringify to their
unmasked value only when necessary.

=item allow

ArrayRef or single item describing packages and/or subs for which calling
the C<get> method will yield the unmasked value. If allow is not specified,
the C<get> method will always return the unmasked value.

=item obfuscator

CODE reference which takes a sensitive (unmasked) value as its first
argument and returns a safe (masked) value. The default obfuscator returns
a string of "X"s equal to the length of the sensitive value.

=item masked

Explicitly specify the masked string value.

=item cluck

When "1", stringification will print a stack trace to STDERR for debugging
purposes. May also be an ArrayRef or single item describing packages and/or
subs for which stringification should print a stack trace.

=back

=head3 set

 $str->set( $value )

Set the unmasked string value to C<$value>. ** Note C<$str = $value> is WRONG!

=head3 get

 $str->get()

Attempts to get unmasked value. Will silently return the masked value if
the C<allow> parameter was set at object construction time and the current
caller is not allowed to access the unmasked value.

=head3 get_masked

 $str->get_masked()

Unconditionally returns the masked value for all callers.

=head1 CALLER SPECIFICATION

The C<allow>, C<auto_get>, and C<cluck> parameters accept caller
descriptions. These can take the form of:

=over 4

=item string

Must exactly match the immediate caller's C<CLASS>, C<CLASS::SUBNAME()>, or
C<CLASS::SUBNAME(LINE_NO)>. For example:

 "main"                # anywhere in main package
 "main::()"            # outside any sub in main
 "main::foo()"         # anywhere in sub foo of package main
 "main::(34)"          # line 34 outside any sub in main
 "main::foo(42)"       # line 42 in sub foo of package main

 # Similarly for package "My::Class"
 "My::Class"
 "My::Class::()"
 "My::Class::foo()"
 "My::Class::(45)"
 "My::Class::foo(67)"

Of course, including a line number in the specification is rather fragile
so shouldn't be used in most situations.

=item Regexp

Will be applied to the C<CLASS::SUBNAME(LINE_NO)> form of the caller.

=item CODEREF

Will be passed arguments: $level, $pkg, $file, $line, $sub

from the perspective of the code ref. The level may be used to walk up the
call stack if necessary. Example which matches all authentication methods
in My::Class:

 sub {
   my ($level, $pkg, $file, $line, $sub) = @_;
   return ( $pkg eq "My::Class" and $sub =~ /^_?authenticate/ );
 }

=back

=head3 Inheritance and importing

Class and sub name will always be the class and sub name from the
parent/exporting class. For example:

 my $CC = SecureString->new( "12345", cluck => 1 );

 package My::Class;
 sub foo {
   say $CC;
 }
 foo();                # Attempt to access string value of XXXXX at My::Class::foo(62)

 package bar;
 our @ISA = ("My::Class");
 *baz = \&My::Class::foo;
 bar->foo();           # Attempt to access string value of XXXXX at My::Class::foo(62)
 baz();                # Attempt to access string value of XXXXX at My::Class::foo(62)

=head1 SERIALIZATION SUPPORT

In general, this module will serialize to the masked value. The one
exception is C<Storable::dclone()> which, like thread cloning, doesn't
really count as serialization and therefore gets a proper copy of the
SecureString object.

When possible, serialization will collapse to a plain (masked) string
though some serialization hooks to not allow changing object type (or
serializing a blessed object to an unblessed scalar) so in these cases,
deserialization will construct a SecureString whose masked and unmasked
values are the same (both are the original masked values).

=head2 Stable Support

No serializer hooks are considered stable at this time

=head2 Experimental Support

=head3 Storable

Does not (as far as I can tell) allow changing type to unblessed scalar,
thus C<thaw(freeze($secure_string))> will produce a SecureString of the
masked value.

Storable allows dclone to be treated specially. Therefore, since dclone can
not result in accidental information leakage, C<dclone($secure_string)>
produces a usable (the unmasked value remains in tact) SecureString.

=head3 YAML

Alas, doesn't work...

=head1 INTERNAL (PRIVATE) METHODS

=head3 _string

Clucks if appropriate then returns masked value unless the auto_get
parameter matches the current caller.

=head3 _number

Simply dies. Numerical overloading calls this so that masked values are
never used in calculations.

=head3 _show_caller

 $self->_show_caller( $message, $level = 1 )

Displays message to STDERR and current caller spec (as would be matched by C<_match_caller>.

=head3 _caller

 my ($pkg, $file, $line, $sub) = $self->_caller( $level )

Compute a caller by our definition.

=head3 _match_caller

 $self->_match_caller( $match_data, $level = 1 )

Computes caller information and loops over match items attempting to find
any match. If C<$match_data> is undefined, then match succeeds. If
C<$match_data> is an empty array, the match fails.

=head3 _match_caller_item

 $self->_match_caller_item( $match, $level, @caller )

Returns true if C<$match> matches the current C<@caller> (at C<$level>).
Can handle scalar, Regexp, or CODE match types. Dies on any other match
types.

=head3 _default_obfuscator

Returns string of "X"s equal in length to first argument.

=head1 AUTHOR

 Dean Serenevy
 dean@serenevy.net
 http://dean.serenevy.net/

=head1 COPYRIGHT

This module is Copyright (c) 2011 Dean Serenevy. All rights reserved.

You may distribute under the terms of either the GNU General Public License
or the Artistic License, as specified in the Perl README file or L<perlartistic>.

=head1 DISCLAIMER OF WARRANTY

BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR
THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO
THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE
SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR, OR CORRECTION.

IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL
ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE
THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR
DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL
DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING
BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES
SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE
WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN
ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.