1package Term::ReadPassword;
2
3use strict;
4use Term::ReadLine;
5use POSIX qw(:termios_h);
6my %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
20use vars qw(
21    $VERSION @ISA @EXPORT @EXPORT_OK
22    $ALLOW_STDIN %SPECIAL $SUPPRESS_NEWLINE $INPUT_LIMIT
23    $USE_STARS $STAR_STRING $UNSTAR_STRING
24);
25
26require 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
47sub read_password {
48    my($prompt, $idle_limit, $interruptable) = @_;
49    $prompt = '' unless defined $prompt;
50    $idle_limit = 0 unless defined $idle_limit;
51    $interruptable = 0 unless defined $interruptable;
52
53    # Let's open the TTY (rather than STDIN) if we can
54    local(*TTY, *TTYOUT);
55    my($in, $out) = Term::ReadLine->findConsole;
56    die "No console available" unless $in;
57    if (open TTY, "+<$in") {
58        # Cool
59    } elsif ($ALLOW_STDIN) {
60        open TTY, "<&STDIN"
61	    or die "Can't re-open STDIN: $!";
62    } else {
63        die "Can't open '$in' read/write: $!";
64    }
65
66    # And let's send the output to the TTY as well
67    if (open TTYOUT, ">>$out") {
68	# Cool
69    } elsif ($ALLOW_STDIN) {
70	# Well, let's allow STDOUT as well
71	open TTYOUT, ">>&STDOUT"
72	    or die "Can't re-open STDOUT: $!";
73    } else {
74	die "Can't open '$out' for output: $!";
75    }
76
77    # Don't buffer it!
78    select( (select(TTYOUT), $|=1)[0] );
79    print TTYOUT $prompt;
80
81    # Okay, now remember where everything was, so we can put it back when
82    # we're done
83    my $fd_tty = fileno(TTY);
84    my $term = POSIX::Termios->new();
85    $term->getattr($fd_tty);
86    my $original_flags = $term->getlflag();
87    my %original_cc;
88    for my $field_name (keys %CC_FIELDS) {
89        $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    my $flags = $original_flags & ~(ISIG | ECHO | ICANON);
96    $term->setlflag($flags);
97    if ($idle_limit) {
98	# $idle_limit is in seconds, so multiply by ten
99	$term->setcc(VTIME, 10 * $idle_limit);
100	# Continue running the program after that time, even if there
101	# weren't any characters typed
102	$term->setcc(VMIN, 0);
103    } else {
104	# No time limit, but...
105	$term->setcc(VTIME, 0);
106	# Continue as soon as one character has been struck
107	$term->setcc(VMIN, 1);
108    }
109
110    # Optionally echo stars in place of password characters. The
111    # $unstar_string uses backspace characters.
112    my $star_string = $USE_STARS ? ($STAR_STRING || '*') : '';
113    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    $term->setattr($fd_tty, TCSAFLUSH);
123
124    my $input = '';
125    my $return_value;
126KEYSTROKE:
127    while (1) {
128        my $new_keys = '';
129	my $count = sysread(TTY, $new_keys, 99);
130	# We're here, so either the idle_limit expired, or the user typed
131	# something.
132	if ($count) {
133	    for my $new_key (split //, $new_keys) {
134	        if (my $meaning = $SPECIAL{$new_key}) {
135		    if ($meaning eq 'ENT') {
136		        # Enter/return key
137			# Return what we have so far
138			$return_value = $input;
139			last KEYSTROKE;
140		    } elsif ($meaning eq 'DEL') {
141		        # Delete/backspace key
142			# Take back one char, if possible
143			if (length $input) {
144			    $input = substr $input, 0, length($input)-1;
145			    print TTYOUT $unstar_string;
146			}
147		    } elsif ($meaning eq 'NAK') {
148		        # Control-U (NAK)
149		        # Clear what we have read so far
150			for (1..length $input) {
151			    print TTYOUT $unstar_string;
152			}
153		        $input = '';
154		    } elsif ($interruptable and $meaning eq 'INT') {
155			# Breaking out of the program
156			# Return early
157			last KEYSTROKE;
158		    } else {
159		        # Just an ordinary keystroke
160			$input .= $new_key;
161			print TTYOUT $star_string;
162		    }
163		} else {
164		    # Not special
165		    $input .= $new_key;
166		    print TTYOUT $star_string;
167		}
168 	    }
169	    # Just in case someone sends a lot of data
170	    $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	    last KEYSTROKE;
176	}
177    }
178
179    # Done with waiting for input. Let's not leave the cursor sitting
180    # there, after the prompt.
181    print TTYOUT "\n" unless $SUPPRESS_NEWLINE;
182
183    # Let's put everything back where we found it.
184    $term->setlflag($original_flags);
185    while (my($field, $value) = each %original_cc) {
186        $term->setcc($CC_FIELDS{$field}, $value);
187    }
188    $term->setattr($fd_tty, TCSAFLUSH);
189    close(TTY);
190    close(TTYOUT);
191    $return_value;
192}
193
1941;
195__END__
196
197=head1 NAME
198
199Term::ReadPassword - Asking the user for a password
200
201=head1 SYNOPSIS
202
203  use Term::ReadPassword;
204  while (1) {
205    my $password = read_password('password: ');
206    redo unless defined $password;
207    if ($password eq 'flubber') {
208      print "Access granted.\n";
209      last;
210    } else {
211      print "Access denied.\n";
212      redo;
213    }
214  }
215
216=head1 DESCRIPTION
217
218This module lets you ask the user for a password in the traditional way,
219from the keyboard, without echoing.
220
221This is not intended for use over the web; user authentication over the
222web is another matter entirely. Also, this module should generally be used
223in conjunction with Perl's B<crypt()> function, sold separately.
224
225The B<read_password> function prompts for input, reads a line of text from
226the keyboard, then returns that line to the caller. The line of text
227doesn't include the newline character, so there's no need to use B<chomp>.
228
229While the user is entering the text, a few special characters are processed.
230The character delete (or the character backspace) will back up one
231character, removing the last character in the input buffer (if any). The
232character CR (or the character LF) will signal the end of input, causing the
233accumulated input buffer to be returned. Control-U will empty the input
234buffer. And, optionally, the character Control-C may be used to terminate
235the input operation. (See details below.) All other characters, even ones
236which would normally have special purposes, will be added to the input
237buffer.
238
239It is not recommended, though, that you use the as-yet-unspecified control
240characters in your passwords, as those characters may become meaningful in
241a future version of this module. Applications which allow the user to set
242their own passwords may wish to enforce this rule, perhaps with code
243something like this:
244
245    {
246      # Naked block for scoping and redo
247      my $new_pw = read_password("Enter your new password: ");
248      if ($new_pw =~ /([^\x20-\x7E])/) {
249        my $bad = unpack "H*", $1;
250	print "Your password may not contain the ";
251	print "character with hex code $bad.\n";
252	redo;
253      } elsif (length($new_pw) < 5) {
254        print "Your password must be longer than that!\n";
255	redo;
256      } elsif ($new_pw ne read_password("Enter it again: ")) {
257	print "Passwords don't match.\n";
258	redo;
259      } else {
260        &change_password($new_pw);
261	print "Your password is now changed.\n";
262      }
263    }
264
265The second parameter to B<read_password> is the optional C<idle_timeout>
266value. If it is a non-zero number and there is no keyboard input for that
267many seconds, the input operation will terminate. Notice that this is not
268an overall time limit, as the timer is restarted with each new character.
269
270The third parameter will optionally allow the input operation to be
271terminated by the user with Control-C. If this is not supplied, or is
272false, a typed Control-C will be entered into the input buffer just as any
273other character. In that case, there is no way from the keyboard to
274terminate the program while it is waiting for input. (That is to say, the
275normal ability to generate signals from the keyboard is suspended during
276the call to B<read_password>.)
277
278If the input operation terminates early (either because the idle_timeout
279was exceeded, or because a Control-C was enabled and typed), the return
280value will be C<undef>. In either case, there is no way provided to
281discover what (if anything) was typed before the early termination, or why
282the input operation was terminated.
283
284So as to discourage users from typing their passwords anywhere except at
285the prompt, any input which has been "typed ahead" before the prompt
286appears will be discarded. And whether the input operation terminates
287normally or not, a newline character will be printed, so that the cursor
288will not remain on the line after the prompt.
289
290=head1 BUGS
291
292Windows users will want Term::ReadPassword::Win32.
293
294This module has a poorly-designed interface, and should be thoroughly
295rethought and probably re-united with the Windows version.
296
297Users who wish to see password characters echoed as stars may set
298$Term::ReadPassword::USE_STARS to a true value. The bugs are that some
299terminals may not erase stars when the user corrects an error, and that
300using stars leaks information to shoulder-surfers.
301
302=head1 SECURITY
303
304You would think that a module dealing with passwords would be full of
305security features. You'd think that, but you'd be wrong. For example, perl
306provides no way to erase a piece of data from memory. (It's easy to erase
307it so that it can't be accessed from perl, but that's not the same thing
308as expunging it from the actual memory.) If you've entered a password,
309even if the variable that contained that password has been erased, it may
310be possible for someone to find that password, in plaintext, in a core
311dump. And that's just one potential security hole.
312
313In short, if serious security is an issue, don't use this module.
314
315=head1 LICENSE
316
317This program is free software; you may redistribute it, modify it, or
318both, under the same terms as Perl itself.
319
320=head1 AUTHOR
321
322Tom Phoenix <rootbeer@redcat.com>. Copyright (C) 2007 Tom Phoenix.
323
324=head1 SEE ALSO
325
326Term::ReadLine, L<perlfunc/crypt>, and your system's manpages for the
327low-level I/O operations used here.
328
329=cut
330