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


line stmt bran cond sub pod time code
1             package Term::ReadPassword;
2              
3 2     2   3368 use strict;
  2         5  
  2         102  
4 2     2   2952 use Term::ReadLine;
  2         13377  
  2         401  
5 2     2   3247 use POSIX qw(:termios_h);
  2         21511  
  2         16  
6             my %CC_FIELDS = (
7             VEOF => VEOF,
8             VEOL => VEOL,
9             VERASE => VERASE,
10             VINTR => VINTR,
11             VKILL => VKILL,
12             VQUIT => VQUIT,
13             VSUSP => VSUSP,
14             VSTART => VSTART,
15             VSTOP => VSTOP,
16             VMIN => VMIN,
17             VTIME => VTIME,
18             );
19              
20 2         2458 use vars qw(
21             $VERSION @ISA @EXPORT @EXPORT_OK
22             $ALLOW_STDIN %SPECIAL $SUPPRESS_NEWLINE $INPUT_LIMIT
23             $USE_STARS $STAR_STRING $UNSTAR_STRING
24 2     2   5157 );
  2         5  
25              
26             require Exporter;
27              
28             @ISA = qw(Exporter);
29             @EXPORT = qw(
30             read_password
31             );
32             $VERSION = '0.11';
33              
34             # The special characters in the input stream
35             %SPECIAL = (
36             "\x03" => 'INT', # Control-C, Interrupt
37             "\x15" => 'NAK', # Control-U, NAK (clear buffer)
38             "\x08" => 'DEL', # Backspace
39             "\x7f" => 'DEL', # Delete
40             "\x0d" => 'ENT', # CR, Enter
41             "\x0a" => 'ENT', # LF, Enter
42             );
43              
44             # The maximum amount of data for the input buffer to hold
45             $INPUT_LIMIT = 1000;
46              
47             sub read_password {
48 0     0 0   my($prompt, $idle_limit, $interruptable) = @_;
49 0 0         $prompt = '' unless defined $prompt;
50 0 0         $idle_limit = 0 unless defined $idle_limit;
51 0 0         $interruptable = 0 unless defined $interruptable;
52              
53             # Let's open the TTY (rather than STDIN) if we can
54 0           local(*TTY, *TTYOUT);
55 0           my($in, $out) = Term::ReadLine->findConsole;
56 0 0         die "No console available" unless $in;
57 0 0         if (open TTY, "+<$in") {
    0          
58             # Cool
59             } elsif ($ALLOW_STDIN) {
60 0 0         open TTY, "<&STDIN"
61             or die "Can't re-open STDIN: $!";
62             } else {
63 0           die "Can't open '$in' read/write: $!";
64             }
65              
66             # And let's send the output to the TTY as well
67 0 0         if (open TTYOUT, ">>$out") {
    0          
68             # Cool
69             } elsif ($ALLOW_STDIN) {
70             # Well, let's allow STDOUT as well
71 0 0         open TTYOUT, ">>&STDOUT"
72             or die "Can't re-open STDOUT: $!";
73             } else {
74 0           die "Can't open '$out' for output: $!";
75             }
76              
77             # Don't buffer it!
78 0           select( (select(TTYOUT), $|=1)[0] );
79 0           print TTYOUT $prompt;
80              
81             # Okay, now remember where everything was, so we can put it back when
82             # we're done
83 0           my $fd_tty = fileno(TTY);
84 0           my $term = POSIX::Termios->new();
85 0           $term->getattr($fd_tty);
86 0           my $original_flags = $term->getlflag();
87 0           my %original_cc;
88 0           for my $field_name (keys %CC_FIELDS) {
89 0           $original_cc{$field_name} = $term->getcc($CC_FIELDS{$field_name});
90             }
91              
92             # What makes this setup different from the ordinary?
93             # No keyboard-generated signals, no echoing, no canonical input
94             # processing (like backspace handling)
95 0           my $flags = $original_flags & ~(ISIG | ECHO | ICANON);
96 0           $term->setlflag($flags);
97 0 0         if ($idle_limit) {
98             # $idle_limit is in seconds, so multiply by ten
99 0           $term->setcc(VTIME, 10 * $idle_limit);
100             # Continue running the program after that time, even if there
101             # weren't any characters typed
102 0           $term->setcc(VMIN, 0);
103             } else {
104             # No time limit, but...
105 0           $term->setcc(VTIME, 0);
106             # Continue as soon as one character has been struck
107 0           $term->setcc(VMIN, 1);
108             }
109              
110             # Optionally echo stars in place of password characters. The
111             # $unstar_string uses backspace characters.
112 0 0 0       my $star_string = $USE_STARS ? ($STAR_STRING || '*') : '';
113 0 0 0       my $unstar_string = $USE_STARS ? ($UNSTAR_STRING || "\b*\b \b") : '';
114              
115             # If there's anything already buffered, we should throw it out. This
116             # is to discourage users from typing their password before they see
117             # the prompt, since their keystrokes may be echoing on the screen.
118             #
119             # So this statement supposedly makes sure the prompt goes out, the
120             # unread input buffer is discarded, and _then_ the changes take
121             # effect. Thus, everything they typed ahead is (probably) echoed.
122 0           $term->setattr($fd_tty, TCSAFLUSH);
123              
124 0           my $input = '';
125 0           my $return_value;
126             KEYSTROKE:
127 0           while (1) {
128 0           my $new_keys = '';
129 0           my $count = sysread(TTY, $new_keys, 99);
130             # We're here, so either the idle_limit expired, or the user typed
131             # something.
132 0 0         if ($count) {
133 0           for my $new_key (split //, $new_keys) {
134 0 0         if (my $meaning = $SPECIAL{$new_key}) {
135 0 0 0       if ($meaning eq 'ENT') {
    0          
    0          
    0          
136             # Enter/return key
137             # Return what we have so far
138 0           $return_value = $input;
139 0           last KEYSTROKE;
140             } elsif ($meaning eq 'DEL') {
141             # Delete/backspace key
142             # Take back one char, if possible
143 0 0         if (length $input) {
144 0           $input = substr $input, 0, length($input)-1;
145 0           print TTYOUT $unstar_string;
146             }
147             } elsif ($meaning eq 'NAK') {
148             # Control-U (NAK)
149             # Clear what we have read so far
150 0           for (1..length $input) {
151 0           print TTYOUT $unstar_string;
152             }
153 0           $input = '';
154             } elsif ($interruptable and $meaning eq 'INT') {
155             # Breaking out of the program
156             # Return early
157 0           last KEYSTROKE;
158             } else {
159             # Just an ordinary keystroke
160 0           $input .= $new_key;
161 0           print TTYOUT $star_string;
162             }
163             } else {
164             # Not special
165 0           $input .= $new_key;
166 0           print TTYOUT $star_string;
167             }
168             }
169             # Just in case someone sends a lot of data
170 0 0         $input = substr($input, 0, $INPUT_LIMIT)
171             if length($input) > $INPUT_LIMIT;
172             } else {
173             # No count, so something went wrong. Assume timeout.
174             # Return early
175 0           last KEYSTROKE;
176             }
177             }
178              
179             # Done with waiting for input. Let's not leave the cursor sitting
180             # there, after the prompt.
181 0 0         print TTYOUT "\n" unless $SUPPRESS_NEWLINE;
182              
183             # Let's put everything back where we found it.
184 0           $term->setlflag($original_flags);
185 0           while (my($field, $value) = each %original_cc) {
186 0           $term->setcc($CC_FIELDS{$field}, $value);
187             }
188 0           $term->setattr($fd_tty, TCSAFLUSH);
189 0           close(TTY);
190 0           close(TTYOUT);
191 0           $return_value;
192             }
193              
194             1;
195             __END__