File Coverage

blib/lib/Term/Screen.pm
Criterion Covered Total %
statement 15 231 6.4
branch 0 68 0.0
condition 0 36 0.0
subroutine 5 35 14.2
pod 28 29 96.5
total 48 399 12.0


line stmt bran cond sub pod time code
1             package Term::Screen;
2              
3 1     1   543 use 5.006;
  1         2  
  1         31  
4 1     1   4 use strict;
  1         1  
  1         25  
5 1     1   36 use warnings;
  1         2  
  1         966  
6              
7             our $VERSION = '1.05';
8              
9             =head1 NAME
10              
11             Term::Screen - A Simple all perl Term::Cap based screen positioning module
12              
13             =head1 SYNOPSIS
14              
15             require Term::Screen;
16              
17             $scr = Term::Screen->new();
18             unless ($scr) { die " Something's wrong \n"; }
19             $scr->clrscr();
20             $scr->at(5,3);
21             $scr->puts("this is some stuff");
22             $scr->at(10,10)->bold()->puts("hi!")->normal();
23             # you can concatenate many calls (not getch)
24             $c = $scr->getch(); # doesn't need Enter key
25             ...
26             if ($scr->key_pressed()) { print "ha you hit a key!"; }
27              
28              
29              
30             =head1 DESCRIPTION
31              
32             Term::Screen is a very simple screen positioning module that should
33             work wherever C does. It is set up for Unix using stty's but
34             these dependences are isolated by evals in the C constructor. Thus
35             you may create a child module implementing Screen with MS-DOS, ioctl,
36             or other means to get raw and unblocked input. This is not a replacement
37             for Curses -- it has no memory. This was written so that it could be
38             easily changed to fit nasty systems, and to be available first thing.
39              
40             The input functions getch, key_pressed, echo, and noecho are implemented
41             so as to work under a fairly standard Unix system. They use 'stty'
42             to set raw and no echo modes and turn on auto flush. All of these are
43             'eval'ed so that this class can be inherited for new definitions easily.
44              
45             Term::Screen was designed to be "required", then used with object syntax
46             as shown above. One quirk (which the author was used to so he didn't
47             care) is that for function key translation, no delay is set. So for many
48             terminals to get an esc character, you have to hit another char after it,
49             generally another esc.
50              
51             =head1 PUBLIC INTERFACE
52              
53             Term::Screen has a very minimal set of of fixed character terminal position
54             and character reading commands:
55              
56             =over 4
57              
58             =cut
59              
60             require Term::Cap;
61              
62             =item new()
63              
64             Initialize the screen. Does not clear the screen, but does home the cursor.
65              
66             =cut
67              
68             sub new
69             {
70 0     0 1   my ( $prototype, @args ) = @_;
71              
72 0   0       my $classname = ref($prototype) || $prototype;
73              
74 0           my ($ospeed);
75              
76             # adjust OSPEED below to your system.
77 0 0         if ( $^O ne "solaris" )
78             {
79 0           eval { $ospeed = `stty speed 2>/dev/null`; }; # Unixish way to get OSpeed - works
  0            
80             }
81             else
82             { # on Linux, Gnuish ...
83             # work around Solaris stty
84             eval
85 0           {
86 0           foreach (`stty 2>/dev/null`)
87             {
88 0 0         if (/^speed (\d+)/) { $ospeed = $1; last }
  0            
  0            
89             }
90             };
91             }
92 0 0 0       $ospeed = 9600 if ( !$ospeed || $@ );
93 0           my $term = Tgetent Term::Cap { 'TERM' => '', 'OSPEED' => $ospeed };
94              
95 0           my $this = {}; # create object
96 0           bless $this, $classname;
97 0           $this->term($term); # keep termcap entry reference
98 0           $this->{IN} = ''; # clear input buffer
99 0           $this->{ROWS} = 0;
100 0           $this->{COLS} = 0;
101 0           $this->resize(); # sets $this->{ROWS} & {COLS}
102 0           $this->{KEYS} = {}; # set up fn key hash of hashes
103 0           $this->get_fn_keys(); # define function key table from defaults
104 0           $this->at( 0, 0 ); # home cursor
105 0           $this->{ECHO} = 1; # start off echoing
106 0           $| = 1; # for output flush on writes
107             # wrapped so inherited versions can call with different input codes
108 0           eval { system('stty raw isig -echo 2>/dev/null'); }; # turn on raw input
  0            
109             # ignore errors
110 0           return $this;
111             }
112              
113             sub DESTROY
114             {
115 0     0     my $rc = $?;
116 0           system('stty -raw -isig echo 2>/dev/null');
117 0           $? = $rc;
118             }
119              
120              
121             =item term(term)
122              
123             Sets or Gets the Term::Cap object used by this object.
124              
125             =cut
126              
127             sub term
128             {
129 0     0 1   my ( $self, $term ) = @_;
130              
131 0 0 0       if ( defined $term && ref $term and UNIVERSAL::isa( $term, 'Term::Cap' ) )
      0        
132             {
133 0           $self->{TERM} = $term;
134             }
135 0           return $self->{TERM};
136             }
137              
138             =item rows(rows)
139              
140             Returns and/or sets the number of rows on the terminal.
141              
142             =cut
143              
144             sub rows
145             {
146 0     0 1   my ( $self, $rows ) = @_;
147              
148 0 0 0       if ( defined $rows and $rows =~ /\d+/ )
149             {
150 0           $self->{ROWS} = $rows;
151             }
152              
153 0           return $self->{ROWS};
154             }
155              
156             =item cols(cols)
157              
158             Returns and/or sets the number of cols on the terminal.
159              
160             =cut
161              
162             sub cols
163             {
164 0     0 1   my ( $self, $cols ) = @_;
165              
166 0 0 0       if ( defined $cols and $cols =~ /\d+/ )
167             {
168 0           $self->{COLS} = $cols;
169             }
170              
171 0           return $self->{COLS};
172             }
173              
174             =item at(row,col)
175              
176             Moves cursor to (row,col) where (0,0) is upper left corner, - if the spot is
177             illegal does whatever 'cm' in termcap does, since that is what it uses.
178              
179             =cut
180              
181             sub at
182             {
183 0     0 1   my ( $this, $r, $c ) = @_;
184 0 0         if ( $r < 0 ) { $r = 0; }
  0            
185 0 0         if ( $c < 0 ) { $c = 0; }
  0            
186 0 0         if ( $r >= $this->{ROWS} ) { $r = $this->{ROWS} - 1; }
  0            
187 0 0         if ( $c >= $this->{COLS} ) { $c = $this->{COLS} - 1; }
  0            
188 0           $this->term()->Tgoto( 'cm', $c, $r, *STDOUT );
189 0           return $this;
190             }
191              
192             =item resize(r,c)
193              
194             Tell screen the new number of rows & cols physically you can skip the r & c
195             and get new checked vals from stty or termcap. Term::Screen does not
196             handle resize signals internally, but you can do it by checking and updating
197             screen size using this function.
198              
199             =cut
200              
201             sub resize
202             {
203 0     0 1   my ( $this, $r, $c ) = @_;
204 0           my $size = '';
205              
206             # find screen size -- trying different methods
207 0 0 0       if ( $#_ != 2 || $r <= 0 || $c <= 0 )
      0        
208             {
209 0           $r = 0;
210 0           $c = 0;
211              
212 0 0         if ( $^O ne "solaris" )
213             {
214 0           eval { $size = `stty size`; }; # not portable but most accurate
  0            
215 0 0         if ( $size =~ /^\s*(\d+)\s+(\d+)\s*/ )
216             {
217 0           ( $r, $c ) = ( $1, $2 );
218             }
219             }
220             else
221             {
222              
223             # work around Solaris stty
224 0           eval {
225 0           foreach (`stty`)
226             {
227 0 0         if (/^rows = (\d+); columns = (\d+)/) {
228 0           $r = $1;
229 0           $c = $2;
230 0           last;
231             }
232             }
233             };
234             }
235             }
236 0 0 0       if ( $r == 0 || $c == 0 ) # try getting rows and cols some other way
237             {
238 0 0         if ( exists $ENV{'LINES'} ) { $r = $ENV{'LINES'}; }
  0            
239 0           else { $r = $this->term()->{'_li'}; } # this is often wrong
240 0 0         if ( exists $ENV{'COLUMNS'} ) { $c = $ENV{'COLUMNS'}; }
  0            
241 0           else { $c = $this->term()->{'_co'}; }
242             }
243 0           $this->{ROWS} = $r;
244 0           $this->{COLS} = $c;
245 0           return $this;
246             }
247              
248             =item normal()
249              
250             Turn off any highlightling (bold, reverse)
251              
252             =cut
253              
254             sub normal
255             {
256 0     0 1   my $this = shift;
257 0           $this->term()->Tputs( 'me', 1, *STDOUT );
258 0           return $this;
259             }
260              
261             =item bold()
262              
263             The md value from termcap - turn on bold usually
264              
265             =cut
266              
267             sub bold
268             {
269 0     0 1   my $this = shift;
270 0           $this->term()->Tputs( 'md', 1, *STDOUT );
271 0           return $this;
272             }
273              
274             =item reverse()
275              
276             The mr value from termcap - turn on reverse text often. these last
277             two default to whatever is available.
278              
279             =cut
280              
281             sub reverse
282             {
283 0     0 1   my $this = shift;
284 0           $this->term()->Tputs( 'mr', 1, *STDOUT );
285 0           return $this;
286             }
287              
288             =item curvis()
289              
290             The vs value from termcap - make cursor very visible
291              
292             =cut
293              
294             sub curvis
295             {
296 0     0 1   my $this = shift;
297 0           $this->term()->Tputs( 'vs', 1, *STDOUT );
298 0           return $this;
299             }
300              
301             =item curinvis()
302              
303             The vi value from termcap - make cursor invisible
304              
305             =cut
306             sub curinvis
307             {
308 0     0 1   my $this = shift;
309 0           $this->term()->Tputs( 'vi', 1, *STDOUT );
310 0           return $this;
311             }
312              
313              
314             =item clrscr()
315              
316             Clear the screen and home cursor
317              
318             =cut
319              
320             sub clrscr
321             {
322 0     0 1   my $this = shift;
323 0           $this->term()->Tputs( 'cl', 1, *STDOUT );
324 0           $this->{'rc'} = [ 0, 0 ];
325 0           return $this;
326             }
327              
328             =item clreol()
329              
330             Clear to the end of the line - cursor doesn't move
331              
332             =cut
333              
334             sub clreol
335             {
336 0     0 1   my $this = shift;
337 0 0         if ( exists( $this->term()->{'_ce'} ) )
338             {
339 0           $this->term()->Tputs( 'ce', 1, *STDOUT );
340             }
341 0           return $this;
342             }
343              
344             =item clreos()
345              
346             Clear to end of screen - right and down, cursor doesn't move.
347              
348             =cut
349              
350             sub clreos
351             {
352 0     0 1   my $this = shift;
353 0 0         if ( exists( $this->term()->{'_cd'} ) )
354             {
355 0           $this->term()->Tputs( 'cd', 1, *STDOUT );
356             }
357 0           return $this;
358             }
359              
360             =item il()
361              
362             Insert blank line before line cursor is on, moving lower lines down.
363              
364             =cut
365              
366             sub il
367             {
368 0     0 1   my $this = shift;
369 0           $this->term()->Tputs( 'al', 1, *STDOUT );
370 0           return $this;
371             }
372              
373             =item dl()
374              
375             Delete line cursor is on, moving lower lines up.
376              
377             =cut
378              
379             sub dl
380             {
381 0     0 1   my $this = shift;
382 0           $this->term()->Tputs( 'dl', 1, *STDOUT );
383 0           return $this;
384             }
385              
386             =item ic_exists()
387              
388             Insert character option is available.
389              
390             =cut
391              
392 0 0   0 1   sub ic_exists { ( exists( $_[0]->term()->{'ic'} ) ? 1 : 0 ); }
393              
394             {
395 1     1   5 no warnings 'once';
  1         1  
  1         104  
396             *exists_ic = \&ic_exists;
397             }
398              
399             =item ic()
400              
401             Insert character at current position move rest to the right.
402              
403             =cut
404              
405             sub ic
406             {
407 0     0 1   my $this = shift;
408 0           $this->term()->Tputs( 'ic', 1, *STDOUT );
409 0           $this;
410             }
411              
412             =item dc_exists()
413              
414             Delete char option exists and is available.
415              
416             =cut
417              
418 0 0   0 1   sub dc_exists { ( exists( $_[0]->term()->{'dc'} ) ? 1 : 0 ); }
419              
420             {
421 1     1   4 no warnings 'once';
  1         0  
  1         777  
422             *exists_dc = \&dc_exists;
423             }
424              
425             =item dc()
426              
427             Delete character at current position moving rest to the left.
428              
429             =cut
430              
431             sub dc
432             {
433 0     0 1   my $this = shift;
434 0           $this->term()->Tputs( 'dc', 1, *STDOUT );
435 0           return $this;
436             }
437              
438             =back
439              
440             The following are the I/O functions. They provide standard useful
441             single character reading values. getch returns either a single char or
442             the name of a function key when a key is pressed. The only exception is
443             when you hit a character that is the start of a function key sequence.
444             In this case getch keeps waiting for the next char to see if it is fn key.
445             Generally this is the escape key, and why you need to hit esc twice.
446             To get a stright char, just use the regular 'gets' perl function. You
447             will need to echo it yourself if you want.
448              
449             =over 4
450              
451             =item puts(str)
452              
453             Prints $s and returns the screen object. Used to do things like
454             C<$scr->at(10,0)->puts("Hi!")->at(0,0);>. You can just use
455             print if you want.
456              
457             =cut
458              
459 0     0 1   sub puts { print $_[1]; return $_[0]; }
  0            
460              
461             =item getch()
462              
463             Returns just a char in raw mode. Function keys are returned as their
464             capability names, e.g. the up key would return "ku". See the
465             C function for what a lot of the names are. This will wait
466             for next char if in a possible fn key string, so you would need to type
467             'esc' 'esc' most likely to get out of getch, since 'esc' is usually the
468             leading char for function keys. You can use perl's getc, to go 'underneath'
469             getch if you want. See the table in Screen::get_fn_keys() for more
470             information.
471              
472             =cut
473              
474             sub getch
475             {
476 0     0 1   my $this = shift;
477 0           my ( $c, $nc, $fn_flag ) = ( '', '', 0 );
478 0           my $partial_fn_str = '';
479              
480 0 0         if ( $this->{IN} ) { $c = chop( $this->{IN} ); }
  0            
481 0           else { sysread( STDIN, $c, 1 ); }
482              
483 0           $partial_fn_str = $c;
484 0           while ( exists( $this->{KEYS}{$partial_fn_str} ) )
485             { # in a possible function key sequence
486 0           $fn_flag = 1;
487 0 0         if ( $this->{KEYS}{$partial_fn_str} ) # key found
488             {
489 0           $c = $this->{KEYS}{$partial_fn_str};
490 0           $partial_fn_str = '';
491 0           last;
492             }
493             else # wait for another key to see if were in FN yet
494             {
495 0 0         if ( $this->{IN} ) { $partial_fn_str .= chop( $this->{IN} ); }
  0            
496             else
497             {
498 0           sysread(STDIN, $nc, 1);
499 0           $partial_fn_str .= $nc;
500             }
501             }
502             }
503 0 0 0       if ($fn_flag) # seemed like a fn key
    0          
504             {
505 0 0         if ($partial_fn_str) # oops not a fn key
506             {
507 0 0         if ( $partial_fn_str eq "\e\e" ) # take care of funny ESC case
508             {
509 0           $c = "\e";
510 0           $partial_fn_str = "";
511             }
512             else # buffer up the received chars
513             {
514 0           $this->{IN} = CORE::reverse($partial_fn_str) . $this->{IN};
515 0           $c = chop( $this->{IN} );
516 0 0 0       $this->puts($c) if ( $this->{ECHO} && ( $c ne "\e" ) );
517             }
518             }
519              
520             # if fn_key then never echo so do nothing here
521             }
522 0           elsif ( $this->{ECHO} && ( $c ne "\e" ) ) { $this->puts($c); } # regular key
523 0           return $c;
524             }
525              
526             =item def_key('name','input string')
527              
528             Lets you define your own function key sequence. 'name' is what will be
529             returned by getch. 'input string' is what the fn key sends literally. This
530             will override any prev definitions of the input. A whole bunch of defaults
531             are defined for xterms rxvt's, etc. in the get_fn_keys function.
532              
533             =cut
534              
535             sub def_key
536             {
537 0     0 1   my ( $this, $fn, $str ) = @_;
538              
539 0 0         $this->{KEYS}{$str} = $fn if ( $str ne '' );
540 0           while ( $str ne '' )
541             {
542 0           chop($str);
543 0 0         $this->{KEYS}{$str} = '' if ( $str ne '' );
544             }
545 0           return $this;
546             }
547              
548             =item key_pressed([sec])
549              
550             Returns true if there is a character waiting. You can pass an option time in
551             seconds to wait.
552              
553             =cut
554              
555             sub key_pressed
556             {
557 0     0 1   my ( $this, $seconds ) = @_;
558 0           my $readfields = '';
559 0           my $ready = 0;
560              
561 0 0         $seconds = 0 if ( !defined $seconds );
562 0           vec( $readfields, fileno(STDIN), 1 ) = 1; # set up to check STDIN
563 0           eval { $ready = select( $readfields, undef, undef, $seconds ); };
  0            
564 0           return $ready;
565             }
566              
567             =item echo()
568              
569             Tells getch to echo the input to the screen. (the default.)
570              
571             =cut
572              
573 0     0 1   sub echo { my $this = shift; $this->{ECHO} = 1; return $this; }
  0            
  0            
574              
575             =item noecho()
576              
577             Tells getch NOT to echo input to the screen.
578              
579             =cut
580              
581 0     0 1   sub noecho { my $this = shift; $this->{ECHO} = 0; return $this; }
  0            
  0            
582              
583             =item flush_input()
584              
585             Clears input buffer and removes any incoming chars.
586              
587             =cut
588              
589             sub flush_input
590             {
591 0     0 1   my $this = shift;
592 0           my $discard;
593 0           $this->{IN} = '';
594 0           while ( $this->key_pressed() ) { sysread(STDIN, $discard, 1); }
  0            
595 0           return $this;
596             }
597              
598             =item stuff_input(str)
599              
600             Lets you stuff chars into the input buffer to be read like keystrokes.
601             This is only the C method buffer, the underlying getc stuff
602             is not touched.
603              
604             =cut
605              
606             sub stuff_input
607             {
608 0     0 1   my ( $this, $str ) = @_;
609 0           $this->{IN} = CORE::reverse($str) . $this->{IN};
610 0           return $this;
611             }
612              
613             # internal functions
614              
615             # This function sets up the arrow keys from { ku kd kr kl }
616             # and the function keys from {k0 .. k9} with labels from { l0 .. l9}
617             # (if they exist of course.)
618             # This is all encoded in a funny way -- as a hash with the
619             # characters as keys - check the code. It makes checking fn keys easy.
620              
621             sub get_fn_keys
622             {
623 0     0 0   my $this = shift;
624 0           my $term = $this->term();
625 0           my @keys = qw/ke kh ku kd kl kr k0 k1 k2 k3 k4 k5 k6 k7 k8 k9/;
626 0           my ( $fn, $ufn, $lfn );
627              
628             # throw in some defaults (xterm & rxvt arrows);
629 0           $this->def_key( "ku", "\e[A" );
630 0           $this->def_key( "kd", "\e[B" );
631 0           $this->def_key( "kr", "\e[C" );
632 0           $this->def_key( "kl", "\e[D" );
633              
634             # PC keyboard fn keys for xterm (some of them)
635 0           $this->def_key( "k1", "\e[11~" );
636 0           $this->def_key( "k2", "\e[12~" );
637 0           $this->def_key( "k3", "\e[13~" );
638 0           $this->def_key( "k4", "\e[14~" );
639 0           $this->def_key( "k5", "\e[15~" );
640 0           $this->def_key( "k6", "\e[17~" );
641 0           $this->def_key( "k7", "\e[18~" );
642 0           $this->def_key( "k8", "\e[19~" );
643 0           $this->def_key( "k9", "\e[20~" );
644 0           $this->def_key( "k10", "\e[21~" );
645 0           $this->def_key( "k11", "\e[23~" );
646 0           $this->def_key( "k12", "\e[24~" );
647              
648 0           $this->def_key( "ins", "\e[2~" );
649 0           $this->def_key( "del", "\e[3~" );
650              
651 0           $this->def_key( "home", "\e[H" ); # mult defs are no problem
652 0           $this->def_key( "home", "\eO" ); # these are some I have found
653 0           $this->def_key( "end", "\eOw" );
654 0           $this->def_key( "end", "\eOe" );
655 0           $this->def_key( "pgup", "\e[5~" );
656 0           $this->def_key( "pgdn", "\e[6~" );
657              
658             # try to get anything useful out of termcap
659             # (not too accurate in many cases
660              
661 0           foreach $fn (@keys)
662             {
663 0           $ufn = '_' . $fn;
664 0           $lfn = $ufn;
665 0           $lfn =~ s/_k/_l/;
666              
667 0 0         if ( exists $term->{$ufn} )
668             {
669 0 0 0       if ( ( exists $term->{$lfn} ) && ( $term->{$lfn} ) )
670             {
671 0           $fn = substr( $lfn, 1 );
672             }
673 0           $this->def_key( $fn, $term->{$ufn} );
674             }
675             }
676 0           return $this;
677             }
678              
679             1;
680              
681             __END__