File Coverage

blib/lib/Term/ReadPassword.pm

Criterion	Covered	Total	%
statement	18	82	21.9
branch	0	44	0.0
condition	0	7	0.0
subroutine	6	7	85.7
pod	0	1	0.0
total	24	141	17.0

package Term::ReadPassword;

use strict;
use warnings;

use Term::ReadLine;
use POSIX qw(:termios_h);
my %CC_FIELDS = (
	VEOF   => VEOF,
	VEOL   => VEOL,
	VERASE => VERASE,
	VINTR  => VINTR,
	VKILL  => VKILL,
	VQUIT  => VQUIT,
	VSUSP  => VSUSP,
	VSTART => VSTART,
	VSTOP  => VSTOP,
	VMIN   => VMIN,
	VTIME  => VTIME,
);

use vars qw(
	$ALLOW_STDIN %SPECIAL $SUPPRESS_NEWLINE $INPUT_LIMIT
	$USE_STARS $STAR_STRING $UNSTAR_STRING
);

use Exporter qw(import);

our @EXPORT = qw(
	read_password
);
our $VERSION = '0.11_02';

# The special characters in the input stream
%SPECIAL = (
	"\x03" => 'INT',    # Control-C, Interrupt
	"\x15" => 'NAK',    # Control-U, NAK (clear buffer)
	"\x08" => 'DEL',    # Backspace
	"\x7f" => 'DEL',    # Delete
	"\x0d" => 'ENT',    # CR, Enter
	"\x0a" => 'ENT',    # LF, Enter
);

# The maximum amount of data for the input buffer to hold
$INPUT_LIMIT = 1000;

sub read_password {
	my ( $prompt, $idle_limit, $interruptable ) = @_;
	$prompt        = '' unless defined $prompt;
	$idle_limit    = 0  unless defined $idle_limit;
	$interruptable = 0  unless defined $interruptable;

	# Let's open the TTY (rather than STDIN) if we can
	local ( *TTY, *TTYOUT );
	my ( $in, $out ) = Term::ReadLine->findConsole;
	die "No console available" unless $in;
	if ( open TTY, "+<$in" ) {

		# Cool
	}
	elsif ($ALLOW_STDIN) {
		open TTY, "<&STDIN"
			or die "Can't re-open STDIN: $!";
	}
	else {
		die "Can't open '$in' read/write: $!";
	}

	# And let's send the output to the TTY as well
	if ( open TTYOUT, ">>$out" ) {

		# Cool
	}
	elsif ($ALLOW_STDIN) {

		# Well, let's allow STDOUT as well
		open TTYOUT, ">>&STDOUT"
			or die "Can't re-open STDOUT: $!";
	}
	else {
		die "Can't open '$out' for output: $!";
	}

	# Don't buffer it!
	select( ( select(TTYOUT), $| = 1 )[0] );
	print TTYOUT $prompt;

	# Okay, now remember where everything was, so we can put it back when
	# we're done
	my $fd_tty = fileno(TTY);
	my $term   = POSIX::Termios->new();
	$term->getattr($fd_tty);
	my $original_flags = $term->getlflag();
	my %original_cc;
	for my $field_name ( keys %CC_FIELDS ) {
		$original_cc{$field_name} = $term->getcc( $CC_FIELDS{$field_name} );
	}

	# What makes this setup different from the ordinary?
	# No keyboard-generated signals, no echoing, no canonical input
	# processing (like backspace handling)
	my $flags = $original_flags & ~( ISIG | ECHO | ICANON );
	$term->setlflag($flags);
	if ($idle_limit) {

		# $idle_limit is in seconds, so multiply by ten
		$term->setcc( VTIME, 10 * $idle_limit );

		# Continue running the program after that time, even if there
		# weren't any characters typed
		$term->setcc( VMIN, 0 );
	}
	else {
		# No time limit, but...
		$term->setcc( VTIME, 0 );

		# Continue as soon as one character has been struck
		$term->setcc( VMIN, 1 );
	}

	# Optionally echo stars in place of password characters. The
	# $unstar_string uses backspace characters.
	my $star_string   = $USE_STARS ? ( $STAR_STRING   || '*' )        : '';
	my $unstar_string = $USE_STARS ? ( $UNSTAR_STRING || "\b*\b \b" ) : '';

	# If there's anything already buffered, we should throw it out. This
	# is to discourage users from typing their password before they see
	# the prompt, since their keystrokes may be echoing on the screen.
	#
	# So this statement supposedly makes sure the prompt goes out, the
	# unread input buffer is discarded, and _then_ the changes take
	# effect. Thus, everything they typed ahead is (probably) echoed.
	$term->setattr( $fd_tty, TCSAFLUSH );

	my $input = '';
	my $return_value;
KEYSTROKE:
	while (1) {
		my $new_keys = '';
		my $count = sysread( TTY, $new_keys, 99 );

		# We're here, so either the idle_limit expired, or the user typed
		# something.
		if ($count) {
			for my $new_key ( split //, $new_keys ) {
				if ( my $meaning = $SPECIAL{$new_key} ) {
					if ( $meaning eq 'ENT' ) {

						# Enter/return key
						# Return what we have so far
						$return_value = $input;
						last KEYSTROKE;
					}
					elsif ( $meaning eq 'DEL' ) {

						# Delete/backspace key
						# Take back one char, if possible
						if ( length $input ) {
							$input = substr $input, 0, length($input) - 1;
							print TTYOUT $unstar_string;
						}
					}
					elsif ( $meaning eq 'NAK' ) {

						# Control-U (NAK)
						# Clear what we have read so far
						for ( 1 .. length $input ) {
							print TTYOUT $unstar_string;
						}
						$input = '';
					}
					elsif ( $interruptable and $meaning eq 'INT' ) {

						# Breaking out of the program
						# Return early
						last KEYSTROKE;
					}
					else {
						# Just an ordinary keystroke
						$input .= $new_key;
						print TTYOUT $star_string;
					}
				}
				else {
					# Not special
					$input .= $new_key;
					print TTYOUT $star_string;
				}
			}

			# Just in case someone sends a lot of data
			$input = substr( $input, 0, $INPUT_LIMIT )
				if length($input) > $INPUT_LIMIT;
		}
		else {
			# No count, so something went wrong. Assume timeout.
			# Return early
			last KEYSTROKE;
		}
	}

	# Done with waiting for input. Let's not leave the cursor sitting
	# there, after the prompt.
	print TTYOUT "\n" unless $SUPPRESS_NEWLINE;

	# Let's put everything back where we found it.
	$term->setlflag($original_flags);
	while ( my ( $field, $value ) = each %original_cc ) {
		$term->setcc( $CC_FIELDS{$field}, $value );
	}
	$term->setattr( $fd_tty, TCSAFLUSH );
	close(TTY);
	close(TTYOUT);
	$return_value;
}

1;
__END__