File Coverage

blib/lib/Term/ReadPassword.pm

Criterion	Covered	Total	%
statement	12	76	15.7
branch	0	44	0.0
condition	0	7	0.0
subroutine	4	5	80.0
pod	0	1	0.0
total	16	133	12.0

package Term::ReadPassword;

use strict;
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(
    $VERSION @ISA @EXPORT @EXPORT_OK
    $ALLOW_STDIN %SPECIAL $SUPPRESS_NEWLINE $INPUT_LIMIT
    $USE_STARS $STAR_STRING $UNSTAR_STRING
);

require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(
	read_password
);
$VERSION = '0.11_01';

# 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__