File Coverage

blib/lib/Crypt/SecretBuffer.pm

Criterion	Covered	Total	%
statement	82	112	73.2
branch	25	68	36.7
condition	4	24	16.6
subroutine	16	16	100.0
pod	6	7	85.7
total	133	227	58.5

package Crypt::SecretBuffer;
# VERSION
# ABSTRACT: Prevent accidentally leaking a string of sensitive data
$Crypt::SecretBuffer::VERSION = '0.020';

use strict;
use warnings;
use Carp;
use IO::Handle;
use Scalar::Util ();
use parent qw( DynaLoader );
use overload '""' => \&stringify,
             'cmp' => \&memcmp;

sub dl_load_flags {0x01} # Share extern symbols with other modules
bootstrap Crypt::SecretBuffer;


{
   package Crypt::SecretBuffer::Exports;
$Crypt::SecretBuffer::Exports::VERSION = '0.020';
   use Exporter 'import';
   @Crypt::SecretBuffer::Exports::EXPORT_OK= qw(
      secret_buffer secret span unmask_secrets_to memcmp
      NONBLOCK AT_LEAST ISO8859_1 ASCII UTF8 UTF16LE UTF16BE HEX BASE64
      MATCH_MULTI MATCH_REVERSE MATCH_NEGATE MATCH_ANCHORED MATCH_CONST_TIME
   );
}

# Some of the exported functions are not methods, so instead of having them in the object's
# namespace I put them in the ::Exports namespace.  Importing from Crypt::SecretBuffer is
# equivalent to importing from Crypt::SecretBuffer::Exports.
sub import {
   splice(@_, 0, 1, 'Crypt::SecretBuffer::Exports');
   goto \&Crypt::SecretBuffer::Exports::import;
}

# For "use Inline -with => 'Crypt::SecretBuffer';" but lazy-load the data.
sub Inline {
   require Crypt::SecretBuffer::Install::Files;
   goto \&Crypt::SecretBuffer::Install::Files::Inline;
}


sub stringify_mask {
   my $self= shift;
   if (@_) {
      $self->{stringify_mask}= shift;
      return $self;
   }
   $self->{stringify_mask}
}


sub append_console_line {
   my ($self, $handle, %options)= @_;
   my ($prompt, $prompt_fh, $char_mask, $char_count, $char_max, $char_class)
      = delete @options{qw( prompt prompt_fh char_mask char_count char_max char_class )};
   warn "unknown option: ".join(', ', keys %options)
      if keys %options;
   if (!$prompt_fh && (defined $prompt || defined $char_mask)) {
      my $fd= fileno($handle);
      if (defined $fd && $fd >= 0) {
         $prompt_fh= IO::Handle->new_from_fd($fd, 'w');
      } elsif ($handle == \*STDIN) {
         $prompt_fh= \*STDOUT;
      } else {
         $prompt_fh= $handle;
      }
   }
   # If the user wants control over the keypresses, need to disable line-editing mode
   my $input_by_chars= defined $char_mask || defined $char_count || defined $char_class;
   my $ttystate= Crypt::SecretBuffer::ConsoleState->maybe_new(
      handle => $handle,
      echo => 0,
      (line_input => 0)x!!$input_by_chars,
      auto_restore => 1
   );
   if (defined $prompt) {
      $prompt_fh->print($prompt);
      $prompt_fh->flush;
   }
   my $start_len= $self->length;
   if ($input_by_chars) {
      while (1) {
         $self->append_read($handle, 1)
            or return undef;
         # Handle control characters
         my $end_pos= $self->length - 1;
         if ($self->index(qr/[\0-\x1F\x7F]/, $end_pos) == $end_pos) {
            # If it is \r or \n, end.  If char_count was requested, and we didn't
            # end by that logic, then we don't have the requested char count, so
            # return false.
            if ($self->index(qr/[\r\n]/, $end_pos) == $end_pos) {
               $self->length($end_pos); # remove CR or LF
               return !$char_count;
            }
            # handle backspace
            elsif ($self->index(qr/[\b\x7F]/, $end_pos) == $end_pos) {
               $self->length($end_pos); # remove backspace
               if ($self->length > $start_len) {
                  $self->length($self->length-1); # remove previous char
                  # print a backspace + space + backspace to erase the final mask character
                  if (length $char_mask) {
                     $prompt_fh->print(
                        ("\b" x length $char_mask)
                       .(" "  x length $char_mask)
                       .("\b" x length $char_mask));
                     $prompt_fh->flush;
                  }
               }
            }
            # just ignore any other control char
            else {
               $self->length($end_pos);
            }
         }
         elsif ($char_class && $self->index($char_class, $end_pos) == -1) {
            # not part of the permitted char class
            $self->length($end_pos);
         }
         elsif ($char_max && $self->length - $start_len > $char_max) {
            # refuse to add more characters
            $self->length($end_pos);
         }
         else {
            # char added
            if (length $char_mask) {
               $prompt_fh->print($char_mask);
               $prompt_fh->flush;
            }
            # If reached the char_count, return success
            return 1
               if $char_count && $self->length - $start_len >= $char_count;
         }
      }
   }
   else {
      my $ret= $self->_append_console_line($handle);
      if ($char_max && $self->length - $start_len > $char_max) {
         # truncate the input if char_max requested
         $self->length($start_len + $char_max);
      }
      return $ret;
   }
}


sub as_pipe {
   my $self= shift;
   pipe(my ($r, $w)) or die "pipe: $!";
   $self->write_async($w);
   close($w); # XS dups the file handle if it is writing async from a thread
   return $r;
}


sub load_file {
   my ($self, $path)= @_;
   open my $fh, '<', $path or croak "open($path): $!";
   my $blocksize= -s $path;
   while (1) {
      my $got= $self->append_sysread($fh, $blocksize);
      defined $got or croak "sysread($path): $!";
      last if $got == 0;
      # should have read the whole thing first try, but file could be changing, so keep going
      # at 16K intervals until EOF.
      $blocksize= 16*1024 if $blocksize > 16*1024;
   }
   close($fh) or croak "close($path): $!";
   return $self;
}


sub save_file {
   my ($self, $path, $overwrite)= @_;
   my $fh;
   my $cur_path= "$path";
   if (!$overwrite) {
      -e $path and croak "File '$path' already exists";
      # I don't think there's an atomic way to create-without-overwrite in perl, so try this..
      open $fh, '>>', $path or croak "open($path): $!";
      croak "File '$path' already exists"
         if -s $fh > 0;
   } elsif ($overwrite eq 'rename') {
      require File::Temp;
      require File::Spec;
      my ($vol, $dir, $file)= File::Spec->splitpath($path);
      $fh= File::Temp->new(DIR => File::Spec->catpath($vol, $dir, ''));
      $cur_path= "$fh";
   } else {
      open $fh, '>', $path or croak "open($path): $!";
   }
   my $wrote= 0;
   while ($wrote < $self->length) {
      my $w= $self->syswrite($fh, $self->length - $wrote);
      defined $w or croak "syswrite($cur_path): $!";
      $wrote += $w;
   }
   close($fh) or croak "close($cur_path): $!";
   if ($overwrite eq 'rename') {
      rename($cur_path, $path) or croak "rename($cur_path -> $path): $!";
      $fh->unlink_on_destroy(0);
   }
   return $self;
}


# avoid depending on namespace::clean
delete @{Crypt::SecretBuffer::}{qw( carp croak confess )};

require Crypt::SecretBuffer::Span;
1;

__END__