File Coverage

blib/lib/Crypt/SecretBuffer.pm

Criterion	Covered	Total	%
statement	152	218	69.7
branch	79	166	47.5
condition	34	97	35.0
subroutine	18	18	100.0
pod	6	7	85.7
total	289	506	57.1

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

use strict;
use warnings;
use Carp;
use IO::Handle;
use Scalar::Util ();
use Time::HiRes;
use Fcntl ();
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.024';
   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
      _wait_fh_readable
   );
}

# 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 %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;
      %options= (input_fh => @_);
   } else {
      croak "Expected even-length list of options" if @_ & 1;
      %options= @_;
   }

   # This routine can resume where it left off by keeping most variables in %state
   my $state= delete $options{state} || {};

   # If 'start_len' is set, it means the prompt was already started and this is a continuation.
   # The prompt is only printed on the initial call, unless they set 're_prompt'.
   my $print_prompt= defined $state->{start_len}? delete $state->{re_prompt} : defined $options{prompt};
   $state->{start_len}= $self->length
      unless defined $state->{start_len};

   # copy new parameters into state hash
   for (qw( input_fh prompt prompt_fh char_mask char_count char_max char_class utf8 )) {
      $state->{$_}= delete $options{$_}
         if exists $options{$_};
   }
   # the default char_class for utf8 is the set of valid printable characters
   $state->{char_class} ||= qr/[\p{Print}]/
      if $state->{utf8};

   # local vars for convenience
   my ($input_fh, $prompt_fh, $char_mask, $char_count, $char_max, $char_class, $start_len, $utf8)
      = @{$state}{qw( input_fh prompt_fh char_mask char_count char_max char_class start_len utf8)};

   # timeout is per-call
   my $timeout= delete $options{timeout};

   warn "unknown option: ".join(', ', keys %options)
      if keys %options;

   # Resolve input file handle if not specified
   if (!defined $input_fh) {
      # undef is a request to read from the controlling terminal
      if ($^O eq 'MSWin32') {
         open $input_fh, '+<', 'CONIN$' or croak 'open(CONIN$): '.$!;
         $state->{reading_from}= 'CONIN$';
         unless (defined $state->{prompt_fh}) {
            open $prompt_fh, '>', 'CONOUT$' or croak 'open(CONOUT$): '.$!;
            $state->{prompt_fh}= $prompt_fh;
            $state->{writing_to}= 'CONOUT$';
         }
      } else {
         open $input_fh, '+<', '/dev/tty' or croak "open(/dev/tty): $!";
         $state->{reading_from}= '/dev/tty';
         unless (defined $state->{prompt_fh}) {
            $state->{prompt_fh}= $state->{input_fh};
            $state->{writing_to}= '/dev/tty';
         }
      }
      $state->{input_fh}= $input_fh;
   } else {
      $state->{reading_from} ||= 'supplied_handle';
   }

   # Resolve prompt file handle if required and not specified
   if (defined $state->{prompt} || defined $char_mask) {
      if (!defined $prompt_fh) {
         # 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$): '.$!;
               $state->{writing_to}= 'CONOUT$';
            } else {
               open $prompt_fh, '+<', '/dev/tty' or croak "open(/dev/tty): $!";
               $state->{writing_to}= '/dev/tty';
            }
            $state->{prompt_fh}= $prompt_fh;
         }
         # 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) {
            $state->{prompt_fh}= $prompt_fh= $input_fh;
            $state->{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 {
            delete @{$state}{qw( prompt char_mask )};
         }
      } else {
         $state->{writing_to} ||= 'supplied_handle';
      }
   }

   # 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 || defined $timeout
                    || $utf8;
   $state->{ttystate} ||= Crypt::SecretBuffer::ConsoleState->maybe_new(handle => $input_fh);
   my $ttystate= $state->{ttystate};
   if ($ttystate && $ttystate->echo) {
      $ttystate->auto_restore(1);
      $ttystate->echo(0);
   }
   if ($ttystate && $ttystate->line_input && $input_by_chars) {
      $ttystate->auto_restore(1);
      $ttystate->line_input(0);
   }
   # Write the initial prompt
   if ($print_prompt) {
      my $suffix= '';
      if (defined $start_len && defined $char_mask) {
         my $n= $self->len - $start_len;
         if ($n && $utf8) {
            $n= 0;
            my $span= $self->span(pos => $start_len, encoding => 'UTF-8');
            ++$n while $span->len && eval { $span->ltrim(qr/./) };
         }
         $suffix= $char_mask x $n;
      }
      $prompt_fh->print($state->{prompt} . $suffix) && $prompt_fh->flush
         or croak "Failed to write $state->{writing_to}: $!";
   }
   my $ret;
   if ($input_by_chars) {
      read_loop: while (1) {
         if (defined $timeout) {
            my $start_t= Time::HiRes::time();
            if (Crypt::SecretBuffer::Exports::_wait_fh_readable($input_fh, $timeout)) {
               # deduct from timeout
               $timeout -= Time::HiRes::time() - $start_t;
               $timeout= 0 if $timeout < 0;
            } else {
               # use EINTR to signal a timeout was reached, same as if we'd used alarm()
               $!= Errno::EINTR();
               $ret= undef;
               last;
            }
         }
         # Windows Console events can deliver UTF-16 characters which we can transcode to UTF-8
         if ($utf8 && $ttystate && $^O eq 'MSWin32') {
            $ret= eval { $ttystate->_append_console_char($self) };
            unless (defined $ret) {
               # Errors about invalid surrogate pairs probably need seen by the user
               # because their unicode input is not reaching the buffer reliably.
               if ($@ =~ /surrogate/) {
                  my $msg= "\nWarning: $@.  Your console settings are probably wrong.\n";
                  $prompt_fh? $prompt_fh->print($msg) : warn $msg;
               }
               $ret= undef;
               last;
            }
            next unless $ret; # false means no complete character yet, try again
         } else {
            $ret= $self->append_read($input_fh, 1)
               or last; # EOF or system error
         }
         my $end_pos= $self->length - 1;
         # Handle control characters
         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 $state->{writing_to}: $!";
                  }
               }
            }
            # just ignore any other control char
            else {
               $self->length($end_pos);
            }
         }
         elsif ($utf8) {
            # count chars, and also find out if there are invalid or incomplete characters
            my $span= $self->span(pos => ($start_len || 0), encoding => 'UTF-8');
            my $count= 0;
            while ($span->len) {
               my $ch= eval { $span->parse($char_class) };
               unless ($ch) {
                  if (!defined $ch) {
                     # partial character? loop again until we get all of it.
                     $span->encoding(0);
                     my $ch_len= $span->starts_with(qr/[\xC0-\xDF]/)? 2
                               : $span->starts_with(qr/[\xE0-\xEF]/)? 3
                               : 4;
                     next read_loop if $span->len < $ch_len;
                     # else it's an invalid UTF-8 sequence.  Hard to say what the right thing to
                     # do is here, but since passwords need to be an exact match, lets delete
                     # the invalid chars and emit a warning that hopefully the user can see.
                     my $msg= "\nWarning: discarding invalid UTF-8 sequence.  Your console settings are probably wrong.\n";
                     $prompt_fh? $prompt_fh->print($msg) : warn $msg;
                  }
                  # else just not a permitted character. Truncate / ignore it.
                  $self->length($span->pos);
                  last;
               }
               if ($char_max && $count >= $char_max) {
                  # truncate at max chars
                  $self->length($ch->pos);
                  last;
               }
               ++$count;
            }
            # char added successfully; show progress
            if (length $char_mask) {
               $prompt_fh->print($char_mask) && $prompt_fh->flush
                  or croak "Failed to write $state->{writing_to}: $!";
            }
            # If reached the char_count, return success
            last if $char_count && $count == $char_count;
         }
         else {
            if ($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 $state->{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);
      }
   }
   # timeout or system error (including EINTR and EAGAIN)
   if (!defined $ret) {
      return undef;
   }
   # 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 $state->{prompt};
   # Not a temporary failuire.  Wipe the state.
   %$state= ();
   return !$ret? 0
        : $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 $chunksize= -s $fh;
   if (!$chunksize) {
      $chunksize= sysseek($fh, 0, Fcntl::SEEK_END());
      sysseek($fh, 0, Fcntl::SEEK_SET());
   }
   $chunksize ||= 64*1024; # if stat doesn't report size and not seekable, just try 64K
   while (1) {
      my $got= $self->append_sysread($fh, $chunksize);
      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 64K intervals until EOF.
      $chunksize= 64*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__