File Coverage

blib/lib/Crypt/SecretBuffer.pm

Criterion	Covered	Total	%
statement	91	134	67.9
branch	33	106	31.1
condition	7	54	12.9
subroutine	16	16	100.0
pod	6	7	85.7
total	153	317	48.2

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

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.021';
   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= shift;
   my ($input_fh, %options);
   # First argument can be input_fh, or just straight key/value list.
   if (@_ && ref($_[0]) && (ref $_[0] eq 'GLOB' || ref($_[0])->can('getc'))) {
      croak "Expected even-length list of options" unless @_ & 1;
      ($input_fh, %options)= @_;
   } else {
      croak "Expected even-length list of options" if @_ & 1;
      %options= @_;
      $input_fh= delete $options{input_fh};
   }
   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;
   my ($reading_from, $writing_to)= ('supplied handle', 'supplied handle');
   if (!defined $input_fh) {
      # user is requesting a read from the controlling terminal
      if ($^O eq 'MSWin32') {
         open $input_fh, '+<', 'CONIN$' or croak 'open(CONIN$): '.$!;
         open $prompt_fh, '>', 'CONOUT$' or croak 'open(CONOUT$): '.$!
            unless defined $prompt_fh;
         $reading_from= 'CONIN$';
         $writing_to= 'CONOUT$';
      } else {
         open $input_fh, '+<', '/dev/tty' or croak "open(/dev/tty): $!";
         $prompt_fh= $input_fh unless defined $prompt_fh;
         $reading_from= $writing_to= '/dev/tty';
      }
   }
   if (!defined $prompt_fh && (defined $prompt || defined $char_mask)) {
      # Determine default prompt_fh
      # For terminals, if it was STDIN then the underlying descriptors or libc FILE handle
      # are probably read-only, so open a new writeable handle.  Also MSWin32 only has one
      # console, so do this even if it isn't currently set as STDIN.
      my $fd= fileno($input_fh);
      if (-t $input_fh && ((defined $fd && $fd == 0) || \*STDIN == $input_fh || $^O eq 'MSWin32')) {
         if ($^O eq 'MSWin32') {
            open $prompt_fh, '>', 'CONOUT$' or croak 'open(CONOUT$): '.$!;
            $writing_to= 'CONOUT$';
         } else {
            open $prompt_fh, '+<', '/dev/tty' or croak "open(/dev/tty): $!";
            $writing_to= '/dev/tty';
         }
      }
      # For sockets or tty, default to the same file descriptor as input_fh.
      # If the descriptor is read-only, things will fail, and it's the caller's
      # job to fix the bug.
      elsif (-S $input_fh || -t $input_fh) {
         $prompt_fh= $input_fh;
         $writing_to= 'input handle';
      }
      # Suppress prompt unless the handle looks like a TTY or Socket.  e.g. input from file
      # or pipe can't usefully be prompted.  It could be that the parent process created a
      # return pipe on STDOUT and wants to see the prompt there, but it would be too bold to
      # take a guess at that.  The caller can supply prompt_fh => \*STDOUT if they want to.
      else {
         $prompt= $char_mask= undef;
      }
   }
   # If the user wants control over the keypresses, need to disable line-editing mode.
   # ConsoleState obj with auto_restore restores the console state when it goes out of scope.
   my $input_by_chars= defined $char_mask || defined $char_count || defined $char_class;
   my $ttystate= Crypt::SecretBuffer::ConsoleState->maybe_new(
      handle => $input_fh,
      echo => 0,
      (line_input => 0)x!!$input_by_chars,
      auto_restore => 1
   );
   # Write the initial prompt
   if (defined $prompt) {
      $prompt_fh->print($prompt) && $prompt_fh->flush
         or croak "Failed to write $writing_to: $!";
   }
   my $start_len= $self->length;
   my $ret;
   if ($input_by_chars) {
      while (1) {
         $ret= $self->append_read($input_fh, 1)
            or last;
         # 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
               last;
            }
            # 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
                        or croak "Failed to write $writing_to: $!";
                  }
               }
            }
            # 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
                  or croak "Failed to write $writing_to: $!";
            }
            # If reached the char_count, return success
            last if $char_count && $self->length - $start_len == $char_count;
         }
      }
   }
   else {
      $ret= $self->_append_console_line($input_fh);
      if ($char_max && $self->length - $start_len > $char_max) {
         # truncate the input if char_max requested
         $self->length($start_len + $char_max);
      }
   }
   # If we're responsible for the prompt, also echo the newline to the user so that the caller
   # doesn't need to figure out what to use for $prompt_fh.
   $prompt_fh->print("\n") && $prompt_fh->flush
      if defined $prompt;

   return !$ret? $ret
      : $char_count? $self->length - $start_len == $char_count
      : 1;
}


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);
      my $dest_dir= File::Spec->catpath($vol, $dir, '');
      $fh= File::Temp->new(DIR => (length($dest_dir)? $dest_dir : File::Spec->curdir));
      $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__