1#! perl 2 3package Term::ReadKey; 4 5# This also needs to be adjusted in the generated code below 6# and in the Makefile.PL 7use vars qw($VERSION); 8 9$VERSION = '2.38'; 10 11use Config; 12use File::Basename qw(&basename &dirname); 13use File::Spec; 14use Cwd; 15 16# List explicitly here the variables you want Configure to 17# generate. Metaconfig only looks for shell variables, so you 18# have to mention them as if they were shell variables, not 19# %Config entries. Thus you write 20# $startperl 21# to ensure Configure will look for $Config{startperl}. 22# Wanted: $archlibexp 23 24# This forces PL files to create target in same directory as PL file. 25# This is so that make depend always knows where to find PL derivatives. 26my $origdir = cwd; 27my $dir = dirname($0); 28chdir $dir; 29my $file = 'ReadKey.pm'; 30 31open OUT, ">", $file or die "Can't create $file: $!"; 32 33print "Creating $file\n"; 34 35print OUT <<'!FIRSTPART'; 36# -*- buffer-read-only: t -*- 37# 38# This file is auto-generated. ***ANY*** changes here will be lost 39# 40package Term::ReadKey; 41 42use strict; 43use warnings; 44 45=head1 NAME 46 47Term::ReadKey - A perl module for simple terminal control 48 49=head1 SYNOPSIS 50 51 use Term::ReadKey; 52 ReadMode 4; # Turn off controls keys 53 while (not defined ($key = ReadKey(-1))) { 54 # No key yet 55 } 56 print "Get key $key\n"; 57 ReadMode 0; # Reset tty mode before exiting 58 59=head1 DESCRIPTION 60 61Term::ReadKey is a compiled perl module dedicated to providing simple 62control over terminal driver modes (cbreak, raw, cooked, etc.,) support for 63non-blocking reads, if the architecture allows, and some generalized handy 64functions for working with terminals. One of the main goals is to have the 65functions as portable as possible, so you can just plug in "use 66Term::ReadKey" on any architecture and have a good likelihood of it working. 67 68Version 2.30.01: 69Added handling of arrows, page up/down, home/end, insert/delete keys 70under Win32. These keys emit xterm-compatible sequences. 71Works with Term::ReadLine::Perl. 72 73=over 4 74 75=item ReadMode MODE [, Filehandle] 76 77Takes an integer argument or a string synonym (case insensitive), which 78can currently be one of the following values: 79 80 INT SYNONYM DESCRIPTION 81 82 0 'restore' Restore original settings. 83 84 1 'normal' Change to what is commonly the default mode, 85 echo on, buffered, signals enabled, Xon/Xoff 86 possibly enabled, and 8-bit mode possibly disabled. 87 88 2 'noecho' Same as 1, just with echo off. Nice for 89 reading passwords. 90 91 3 'cbreak' Echo off, unbuffered, signals enabled, Xon/Xoff 92 possibly enabled, and 8-bit mode possibly enabled. 93 94 4 'raw' Echo off, unbuffered, signals disabled, Xon/Xoff 95 disabled, and 8-bit mode possibly disabled. 96 97 5 'ultra-raw' Echo off, unbuffered, signals disabled, Xon/Xoff 98 disabled, 8-bit mode enabled if parity permits, 99 and CR to CR/LF translation turned off. 100 101 102These functions are automatically applied to the STDIN handle if no 103other handle is supplied. Modes 0 and 5 have some special properties 104worth mentioning: not only will mode 0 restore original settings, but it 105cause the next ReadMode call to save a new set of default settings. Mode 1065 is similar to mode 4, except no CR/LF translation is performed, and if 107possible, parity will be disabled (only if not being used by the terminal, 108however. It is no different from mode 4 under Windows.) 109 110If you just need to read a key at a time, then modes 3 or 4 are probably 111sufficient. Mode 4 is a tad more flexible, but needs a bit more work to 112control. If you use ReadMode 3, then you should install a SIGINT or END 113handler to reset the terminal (via ReadMode 0) if the user aborts the 114program via C<^C>. (For any mode, an END handler consisting of "ReadMode 0" 115is actually a good idea.) 116 117If you are executing another program that may be changing the terminal mode, 118you will either want to say 119 120 ReadMode 1; # same as ReadMode 'normal' 121 system('someprogram'); 122 ReadMode 1; 123 124which resets the settings after the program has run, or: 125 126 $somemode=1; 127 ReadMode 0; # same as ReadMode 'restore' 128 system('someprogram'); 129 ReadMode 1; 130 131which records any changes the program may have made, before resetting the 132mode. 133 134=item ReadKey MODE [, Filehandle] 135 136Takes an integer argument, which can currently be one of the following 137values: 138 139 0 Perform a normal read using getc 140 -1 Perform a non-blocked read 141 >0 Perform a timed read 142 143If the filehandle is not supplied, it will default to STDIN. If there is 144nothing waiting in the buffer during a non-blocked read, then undef will be 145returned. In most situations, you will probably want to use C<ReadKey -1>. 146 147I<NOTE> that if the OS does not provide any known mechanism for non-blocking 148reads, then a C<ReadKey -1> can die with a fatal error. This will hopefully 149not be common. 150 151If MODE is greater then zero, then ReadKey will use it as a timeout value in 152seconds (fractional seconds are allowed), and won't return C<undef> until 153that time expires. 154 155I<NOTE>, again, that some OS's may not support this timeout behaviour. 156 157If MODE is less then zero, then this is treated as a timeout 158of zero, and thus will return immediately if no character is waiting. A MODE 159of zero, however, will act like a normal getc. 160 161I<NOTE>, there are currently some limitations with this call under Windows. 162It may be possible that non-blocking reads will fail when reading repeating 163keys from more then one console. 164 165 166=item ReadLine MODE [, Filehandle] 167 168Takes an integer argument, which can currently be one of the following 169values: 170 171 0 Perform a normal read using scalar(<FileHandle>) 172 -1 Perform a non-blocked read 173 >0 Perform a timed read 174 175If there is nothing waiting in the buffer during a non-blocked read, then 176undef will be returned. 177 178I<NOTE>, that if the OS does not provide any known mechanism for 179non-blocking reads, then a C<ReadLine 1> can die with a fatal 180error. This will hopefully not be common. 181 182I<NOTE> that a non-blocking test is only performed for the first character 183in the line, not the entire line. This call will probably B<not> do what 184you assume, especially with C<ReadMode> MODE values higher then 1. For 185example, pressing Space and then Backspace would appear to leave you 186where you started, but any timeouts would now be suspended. 187 188B<This call is currently not available under Windows>. 189 190=item GetTerminalSize [Filehandle] 191 192Returns either an empty array if this operation is unsupported, or a four 193element array containing: the width of the terminal in characters, the 194height of the terminal in character, the width in pixels, and the height in 195pixels. (The pixel size will only be valid in some environments.) 196 197I<NOTE>, under Windows, this function must be called with an B<output> 198filehandle, such as C<STDOUT>, or a handle opened to C<CONOUT$>. 199 200=item SetTerminalSize WIDTH,HEIGHT,XPIX,YPIX [, Filehandle] 201 202Return -1 on failure, 0 otherwise. 203 204I<NOTE> that this terminal size is only for B<informative> value, and 205changing the size via this mechanism will B<not> change the size of 206the screen. For example, XTerm uses a call like this when 207it resizes the screen. If any of the new measurements vary from the old, the 208OS will probably send a SIGWINCH signal to anything reading that tty or pty. 209 210B<This call does not work under Windows>. 211 212=item GetSpeed [, Filehandle] 213 214Returns either an empty array if the operation is unsupported, or a two 215value array containing the terminal in and out speeds, in B<decimal>. E.g, 216an in speed of 9600 baud and an out speed of 4800 baud would be returned as 217(9600,4800). Note that currently the in and out speeds will always be 218identical in some OS's. 219 220B<No speeds are reported under Windows>. 221 222=item GetControlChars [, Filehandle] 223 224Returns an array containing key/value pairs suitable for a hash. The pairs 225consist of a key, the name of the control character/signal, and the value 226of that character, as a single character. 227 228B<This call does nothing under Windows>. 229 230Each key will be an entry from the following list: 231 232 DISCARD 233 DSUSPEND 234 EOF 235 EOL 236 EOL2 237 ERASE 238 ERASEWORD 239 INTERRUPT 240 KILL 241 MIN 242 QUIT 243 QUOTENEXT 244 REPRINT 245 START 246 STATUS 247 STOP 248 SUSPEND 249 SWITCH 250 TIME 251 252Thus, the following will always return the current interrupt character, 253regardless of platform. 254 255 %keys = GetControlChars; 256 $int = $keys{INTERRUPT}; 257 258=item SetControlChars [, Filehandle] 259 260Takes an array containing key/value pairs, as a hash will produce. The pairs 261should consist of a key that is the name of a legal control 262character/signal, and the value should be either a single character, or a 263number in the range 0-255. SetControlChars will die with a runtime error if 264an invalid character name is passed or there is an error changing the 265settings. The list of valid names is easily available via 266 267 %cchars = GetControlChars(); 268 @cnames = keys %cchars; 269 270B<This call does nothing under Windows>. 271 272=back 273 274=head1 AUTHOR 275 276Kenneth Albanowski <kjahds@kjahds.com> 277 278Currently maintained by Jonathan Stowe <jns@gellyfish.co.uk> 279 280=head1 SUPPORT 281 282The code is maintained at 283 284 https://github.com/jonathanstowe/TermReadKey 285 286Please feel free to fork and suggest patches. 287 288 289=head1 LICENSE 290 291Prior to the 2.31 release the license statement was: 292 293 Copyright (C) 1994-1999 Kenneth Albanowski. 294 2001-2005 Jonathan Stowe and others 295 296 Unlimited distribution and/or modification is allowed as long as this 297 copyright notice remains intact. 298 299And was only stated in the README file. 300 301Because I believe the original author's intent was to be more open than the 302other commonly used licenses I would like to leave that in place. However if 303you or your lawyers require something with some more words you can optionally 304choose to license this under the standard Perl license: 305 306 This module is free software; you can redistribute it and/or modify it 307 under the terms of the Artistic License. For details, see the full 308 text of the license in the file "Artistic" that should have been provided 309 with the version of perl you are using. 310 311 This program is distributed in the hope that it will be useful, but 312 without any warranty; without even the implied warranty of merchantability 313 or fitness for a particular purpose. 314 315 316=cut 317 318use vars qw($VERSION); 319 320$VERSION = '2.38'; 321 322require Exporter; 323require DynaLoader; 324 325use vars qw(@ISA @EXPORT_OK @EXPORT); 326 327@ISA = qw(Exporter DynaLoader); 328 329# Items to export into callers namespace by default 330# (move infrequently used names to @EXPORT_OK below) 331 332@EXPORT = qw( 333 ReadKey 334 ReadMode 335 ReadLine 336 GetTerminalSize 337 SetTerminalSize 338 GetSpeed 339 GetControlChars 340 SetControlChars 341); 342 343@EXPORT_OK = qw(); 344 345bootstrap Term::ReadKey; 346 347# Should we use LINES and COLUMNS to try and get the terminal size? 348# Change this to zero if you have systems where these are commonly 349# set to erroneous values. (But if either are near zero, they won't be 350# used anyhow.) 351 352use vars qw($UseEnv $CurrentMode %modes); 353 354$UseEnv = 1; 355 356$CurrentMode = 0; 357 358%modes = ( # lowercase is canonical 359 original => 0, 360 restore => 0, 361 normal => 1, 362 noecho => 2, 363 cbreak => 3, 364 raw => 4, 365 'ultra-raw' => 5 366); 367 368# reduce Carp memory footprint, only load when needed 369sub croak { require Carp; goto &Carp::croak; } 370sub carp { require Carp; goto &Carp::carp; } 371 372sub ReadMode 373{ 374 my $mode = $modes{ lc $_[0] }; # lowercase is canonical 375 my $fh = normalizehandle( ( @_ > 1 ? $_[1] : \*STDIN ) ); 376 377 if ( defined($mode) ) { $CurrentMode = $mode } 378 elsif ( $_[0] =~ /^\d/ ) { $CurrentMode = $_[0] } 379 else { croak("Unknown terminal mode `$_[0]'"); } 380 381 SetReadMode($CurrentMode, $fh); 382} 383 384sub normalizehandle 385{ 386 my ($file) = @_; # allows fake signature optimization 387 388 no strict; 389 # print "Handle = $file\n"; 390 if ( ref($file) ) { return $file; } # Reference is fine 391 392 # if ($file =~ /^\*/) { return $file; } # Type glob is good 393 if ( ref( \$file ) eq 'GLOB' ) { return $file; } # Glob is good 394 395 # print "Caller = ",(caller(1))[0],"\n"; 396 return \*{ ( ( caller(1) )[0] ) . "::$file" }; 397} 398 399sub GetTerminalSize 400{ 401 my $file = normalizehandle( ( @_ > 0 ? $_[0] : \*STDOUT ) ); 402 403 my (@results, @fail); 404 405 if ( &termsizeoptions() & 1 ) # VIO 406 { 407 @results = GetTermSizeVIO($file); 408 push( @fail, "VIOGetMode call" ); 409 } 410 elsif ( &termsizeoptions() & 2 ) # GWINSZ 411 { 412 @results = GetTermSizeGWINSZ($file); 413 push( @fail, "TIOCGWINSZ ioctl" ); 414 } 415 elsif ( &termsizeoptions() & 4 ) # GSIZE 416 { 417 @results = GetTermSizeGSIZE($file); 418 push( @fail, "TIOCGSIZE ioctl" ); 419 } 420 elsif ( &termsizeoptions() & 8 ) # WIN32 421 { 422 @results = GetTermSizeWin32($file); 423 push( @fail, "Win32 GetConsoleScreenBufferInfo call" ); 424 } 425 else 426 { 427 @results = (); 428 } 429 430 if ( @results < 4 and $UseEnv ) 431 { 432 my ($C) = defined( $ENV{COLUMNS} ) ? $ENV{COLUMNS} : 0; 433 my ($L) = defined( $ENV{LINES} ) ? $ENV{LINES} : 0; 434 if ( ( $C >= 2 ) and ( $L >= 2 ) ) 435 { 436 @results = ( $C + 0, $L + 0, 0, 0 ); 437 } 438 push( @fail, "COLUMNS and LINES environment variables" ); 439 } 440 441 if ( @results < 4 && $^O ne 'MSWin32') 442 { 443 my ($prog) = "resize"; 444 445 # Workaround for Solaris path silliness 446 if ( -f "/usr/openwin/bin/resize" ) { 447 $prog = "/usr/openwin/bin/resize"; 448 } 449 450 my ($resize) = scalar(`$prog 2>/dev/null`); 451 if (defined $resize 452 and ( $resize =~ /COLUMNS\s*=\s*(\d+)/ 453 or $resize =~ /setenv\s+COLUMNS\s+'?(\d+)/ ) 454 ) 455 { 456 $results[0] = $1; 457 if ( $resize =~ /LINES\s*=\s*(\d+)/ 458 or $resize =~ /setenv\s+LINES\s+'?(\d+)/ ) 459 { 460 $results[1] = $1; 461 @results[ 2, 3 ] = ( 0, 0 ); 462 } 463 else 464 { 465 @results = (); 466 } 467 } 468 else 469 { 470 @results = (); 471 } 472 push( @fail, "resize program" ); 473 } 474 475 if ( @results < 4 && $^O ne 'MSWin32' ) 476 { 477 my ($prog) = "stty size"; 478 479 my ($stty) = scalar(`$prog 2>/dev/null`); 480 if (defined $stty 481 and ( $stty =~ /(\d+) (\d+)/ ) 482 ) 483 { 484 $results[0] = $2; 485 $results[1] = $1; 486 @results[ 2, 3 ] = ( 0, 0 ); 487 } 488 else 489 { 490 @results = (); 491 } 492 push( @fail, "stty program" ); 493 } 494 495 if ( @results != 4 ) 496 { 497 carp("Unable to get Terminal Size." 498 . join( "", map( " The $_ didn't work.", @fail ) )); 499 return undef; 500 } 501 502 @results; 503} 504 505!FIRSTPART 506 507close OUT; 508# preload the XS module needed for the blockoptions() expansions below 509# does not work with miniperl 510package Term::ReadKey; 511require DynaLoader; 512our @ISA = qw(DynaLoader); 513 514print "Bootstrapping the XS for blockoptions: "; 515bootstrap Term::ReadKey or die; 516print blockoptions()."\n"; 517 518open OUT, ">>", $file or die "Can't append to $file: $!"; 519print OUT "# blockoptions: \n"; 520if ( &blockoptions() & 1 ) # Use nodelay 521{ 522 print OUT "#nodelay\n"; 523 if ( &blockoptions() & 2 ) #poll 524 { 525 print OUT <<'!NO!SUBS!'; 526# poll 527sub ReadKey { 528 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 529 if (defined $_[0] && $_[0] > 0) { 530 if ($_[0]) { 531 return undef if &pollfile($File,$_[0]) == 0; 532 } 533 } 534 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1); } 535 my $value = getc $File; 536 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0); } 537 $value; 538} 539sub ReadLine { 540 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 541 if (defined $_[0] && $_[0] > 0) { 542 if ($_[0]) { 543 return undef if &pollfile($File,$_[0]) == 0; 544 } 545 } 546 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1) }; 547 my $value = scalar(<$File>); 548 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0) }; 549 $value; 550} 551!NO!SUBS! 552 553 } 554 elsif ( &blockoptions() & 4 ) #select 555 { 556 print OUT <<'!NO!SUBS!'; 557#select 558sub ReadKey { 559 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 560 if (defined $_[0] && $_[0] > 0) { 561 if ($_[0]) { return undef if &selectfile($File,$_[0]) == 0 } 562 } 563 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1); } 564 my $value = getc $File; 565 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0); } 566 $value; 567} 568sub ReadLine { 569 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 570 if (defined $_[0] && $_[0] > 0) { 571 if ($_[0]) { return undef if &selectfile($File,$_[0]) == 0 } 572 } 573 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1) }; 574 my $value = scalar(<$File>); 575 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0) }; 576 $value; 577} 578!NO!SUBS! 579 580 } 581 else 582 { #nothing 583 print OUT <<'!NO!SUBS!'; 584sub ReadKey { 585 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 586 if (defined $_[0] && $_[0] > 0) { 587 # Nothing better seems to exist, so I just use time-of-day 588 # to timeout the read. This isn't very exact, though. 589 $starttime = time; 590 $endtime = $starttime + $_[0]; 591 &setnodelay($File,1); 592 my $value; 593 while (time < $endtime) { # This won't catch wraparound! 594 $value = getc $File; 595 last if defined($value); 596 } 597 &setnodelay($File,0); 598 return $value; 599 } 600 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1); } 601 my $value = getc $File; 602 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0); } 603 $value; 604} 605sub ReadLine { 606 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 607 if (defined $_[0] && $_[0] > 0) { 608 # Nothing better seems to exist, so I just use time-of-day 609 # to timeout the read. This isn't very exact, though. 610 $starttime = time; 611 $endtime = $starttime + $_[0]; 612 &setnodelay($File,1); 613 my $value; 614 while (time < $endtime) { # This won't catch wraparound! 615 $value = scalar(<$File>); 616 last if defined($value); 617 } 618 &setnodelay($File,0); 619 return $value; 620 } 621 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,1) }; 622 my $value = scalar(<$File>); 623 if (defined $_[0] && $_[0] < 0) { &setnodelay($File,0) }; 624 $value; 625} 626!NO!SUBS! 627 628 } 629} 630else { 631 print OUT "#no nodelay\n"; 632 633 if ( &blockoptions() & 2 ) # Use poll 634 { 635 print OUT <<'!NO!SUBS!'; 636#poll 637sub ReadKey { 638 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 639 if (defined $_[0] && $_[0] != 0) { 640 return undef if &pollfile($File,$_[0]) == 0 641 } 642 getc $File; 643} 644sub ReadLine { 645 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 646 if (defined $_[0] && $_[0] != 0 ) { 647 return undef if &pollfile($File,$_[0]) == 0; 648 } 649 scalar(<$File>); 650} 651!NO!SUBS! 652 653 } 654 elsif ( &blockoptions() & 4 ) # Use select 655 { 656 print OUT <<'!NO!SUBS!'; 657#select 658sub ReadKey { 659 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 660 if (defined $_[0] && $_[0] != 0) { 661 return undef if &selectfile($File,$_[0]) == 0 662 } 663 getc $File; 664} 665sub ReadLine { 666 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 667 if (defined $_[0] && $_[0] != 0) { 668 return undef if &selectfile($File,$_[0]) == 0; 669 } 670 scalar(<$File>); 671} 672!NO!SUBS! 673 674 } 675 elsif ( &blockoptions() & 8 ) # Use Win32 676 { 677 print OUT <<'!NO!SUBS!'; 678#Win32 679sub ReadKey { 680 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 681 if ($_[0] || $CurrentMode >= 3) { 682 Win32PeekChar($File, $_[0]); 683 } else { 684 getc $File; 685 } 686 #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])}; 687 #getc $File; 688} 689sub ReadLine { 690 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 691 #if ($_[0]!=0) {return undef if !Win32PeekChar($File, $_[0])}; 692 #scalar(<$File>); 693 if ($_[0]) { 694 croak("Non-blocking ReadLine is not supported on this architecture") 695 } 696 scalar(<$File>); 697} 698!NO!SUBS! 699 700 } 701 else 702 { 703 print OUT <<'!NO!SUBS!'; 704sub ReadKey { 705 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 706 if ($_[0]) { 707 croak("Non-blocking ReadKey is not supported on this architecture") 708 } 709 getc $File; 710} 711sub ReadLine { 712 my $File = normalizehandle((@_>1?$_[1]:\*STDIN)); 713 if ($_[0]) { 714 croak("Non-blocking ReadLine is not supported on this architecture") 715 } 716 scalar(<$File>); 717} 718!NO!SUBS! 719 720 } 721} 722 723print OUT <<'EOF'; 7241; 725# ex: set ro: 726EOF 727 728close OUT; 729if (-s $file < 1000) { 730 warn "WARNING: $file probably too small"; 731} else { 732 print "Done\n"; 733} 734