File Coverage

blib/lib/Term/Visual.pm
Criterion Covered Total %
statement 15 15 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 20 20 100.0


line stmt bran cond sub pod time code
1             # $Id: Visual.pm,v 0.06 2003/01/14 23:00:18 lunartear Exp $
2             # Copyrights and documentation are after __END__.
3             package Term::Visual;
4 1     1   5379 use strict;
  1         1  
  1         29  
5 1     1   29 use warnings;
  1         2  
  1         30  
6 1     1   4 use vars qw($VERSION $REVISION $console);
  1         5  
  1         98  
7             $VERSION = '0.08';
8             $REVISION = do {my@r=(q$Revision: 0.08 $=~/\d+/g);sprintf"%d."."%02d"x$#r,@r};
9             #use Visual::StatusBar;
10 1     1   472 use Term::Visual::StatusBar;
  1         2  
  1         24  
11 1     1   795 use POE qw(Wheel::Curses Wheel::ReadWrite );
  1         48915  
  1         8  
12             use Curses;
13             use Carp;
14              
15             BEGIN {
16             my $debug_default = 0;
17              
18             $debug_default++ if defined $ENV{TV_DEBUG};
19             defined &DEBUG or eval "sub DEBUG () { $debug_default }";
20              
21             if (&DEBUG) {
22             my $debug_file = $ENV{TV_LOG_FILE} || 'term_visual.log';
23             defined &DEBUG_FILE or eval "sub DEBUG_FILE () { '$debug_file' }";
24             open ERRS, ">" . &DEBUG_FILE or croak "Can't open Debug file: $!";
25             }
26             }
27              
28             ### Term::Visual Constants.
29              
30             sub WINDOW () { 0 } # hash of windows and there properties
31             sub WINDOW_REV () { 1 } # window name => id key value pair for reverse lookups
32             sub PALETTE () { 2 } # Palette Element
33             sub PAL_COL_SEQ () { 3 } # Palette Color Sequence
34             sub CUR_WIN () { 4 } # holds the current window id
35             sub ERRLEVEL () { 5 } # Error Level boolean
36             sub ALIAS () { 6 } # Visterm's Alias
37             sub BINDINGS () { 7 } # key bindings
38             sub COMMON_INPUT () { 8 } # Common input boolean
39              
40             ### Palette Constants.
41              
42             sub PAL_PAIR () { 0 } # Index of the COLOR_PAIR in the palette.
43             sub PAL_NUMBER () { 1 } # Index of the color number in the palette.
44             sub PAL_DESC () { 2 } # Text description of the color.
45              
46             ### Title line constants.
47              
48             sub TITLE_LINE () { 0 } # Where the title goes.
49             sub TITLE_COL () { 0 }
50              
51              
52             sub current_window {
53             if (DEBUG) { print ERRS " Enter current_window\n"; }
54             my $self = shift;
55             return $self->[CUR_WIN];
56             }
57              
58              
59             sub CREATE_WINDOW_ID {
60             if (DEBUG) { print ERRS "Enter CREATE_WINDOW_ID\n"; }
61             my $self = shift;
62             my $id = 0;
63             my @list = sort {$a <=> $b} keys %{$self->[WINDOW]};
64             if (@list) {
65             my $high_number = $list[$#list] + 1;
66             for my $i (0..$high_number) {
67             next if (defined $list[$i] && $i == $list[$i]);
68             $id = $i; last;
69             }
70             }
71             return $id;
72             }
73              
74              
75             ### Mold the Object.
76              
77             sub new {
78             if (DEBUG) { print ERRS "Enter Visterm->new\n"; }
79             my $package = shift;
80             my %params = @_;
81             my $alias = delete $params{Alias};
82             my $errlevel = delete $params{Errlevel} || 0;
83             my $current_window = -1;
84              
85             my $common_input = delete $params{Common_Input};
86             # These options only make sense if Common_Input is specified
87             my $tabcomplete = delete $params{Tab_Complete};
88             my $history_size = delete $params{History_Size};
89              
90             my $self =
91             bless [ { }, # WINDOW stores window properties under each window id.
92             { }, # WINDOW_REV reverse window lookups.
93             { }, # Palette
94             0, # Palette Color Sequence
95             $current_window,
96             $errlevel, # Visterms error level.
97             $alias,
98             { }, # BINDINGS
99             $common_input ? {
100             History_Position => -1,
101             History_Size => $history_size,
102             Command_History => [ ],
103             Data => "",
104             Data_Save => "",
105             Cursor => 0,
106             Cursor_Save => 0,
107             Tab_Complete => $tabcomplete,
108             Insert => 1,
109             Edit_Position => 0,
110             } : undef,
111             ], $package;
112              
113             POE::Session->create
114             ( object_states =>
115             [ $self => # $_[OBJECT]
116             { _start => "start_terminal",
117             _stop => "terminal_stopped",
118             send_me_input => "register_input",
119             private_input => "got_curses_input",
120             got_stderr => "got_stderr",
121             shutdown => "shutdown",
122             } ],
123             args => [ $alias ],
124            
125             );
126              
127             return $self;
128             }
129              
130             sub got_stderr {
131             my ($self, $kernel, $stderr_line) = @_[OBJECT, KERNEL, ARG0];
132             my $window_id = $self->[CUR_WIN];
133              
134             if (DEBUG) { print ERRS $stderr_line, "\n"; }
135              
136             &print($self, $window_id,
137             "\0(stderr_bullet)" .
138             "2>" .
139             "\0(ncolor)" .
140             " " .
141             "\0(stderr_text)" .
142             $stderr_line );
143             }
144              
145             sub start_terminal {
146             if (DEBUG) { print ERRS "Enter start_terminal\n"; }
147             my ($kernel, $heap, $object, $alias) = @_[KERNEL, HEAP, OBJECT, ARG0];
148            
149             $kernel->alias_set( $alias );
150             $console = POE::Wheel::Curses->new( InputEvent => 'private_input');
151             use_default_colors();
152             my $old_mouse_events = 0;
153             mousemask(0, $old_mouse_events);
154              
155             #TODO See about adding support for a wheel mouse after defining old mouse
156             # events above, so that copy/paste will work as expected.
157              
158             ### Set Colors used by Visterm
159             _set_color( $object, stderr_bullet => "bright white on red",
160             stderr_text => "bright yellow on black",
161             ncolor => "white on black",
162             statcolor => "green on black",
163             st_frames => "bright cyan on blue",
164             st_values => "bright white on blue", );
165              
166              
167             ### Redirect STDERR into the terminal buffer.
168             use Symbol qw(gensym);
169              
170             # Pipe STDERR to a readable handle.
171             my $read_stderr = gensym();
172              
173             pipe($read_stderr, STDERR) or do
174             { open STDERR, ">&=2";
175             die "can't pipe STDERR: $!";
176             };
177              
178             $heap->{stderr_reader} = POE::Wheel::ReadWrite->new
179             ( Handle => $read_stderr,
180             Filter => POE::Filter::Line->new(),
181             Driver => POE::Driver::SysRW->new(),
182             InputEvent => "got_stderr",
183             );
184              
185             }
186              
187             ### create a curses window
188             ### TODO add error handling
189              
190             sub create_window {
191             if (DEBUG) { print ERRS "Enter create_window\n"; }
192             my $self = shift;
193             my %params = @_;
194             my $use_title = 1 unless defined $params{Use_Title};
195             my $use_status = 1 unless defined $params{Use_Status};
196             my $new_window_id = CREATE_WINDOW_ID($self);
197             my $window_name = $params{Window_Name} || $new_window_id;
198             my $input_prompt = $params{Input_Prompt} || "";
199             my $prompt_size = 0;
200             if (length $input_prompt) {
201             $prompt_size = length( $input_prompt ) ;
202             }
203             my $input;
204             if ($self->[COMMON_INPUT]) {
205             $input = $self->[COMMON_INPUT];
206             }
207             else {
208             $input = {
209             History_Position => -1,
210             History_Size => 50,
211             Command_History => [ ],
212             Data => "",
213             Data_Save => "",
214             Cursor => $prompt_size || 0,
215             Cursor_Save => 0,
216             Tab_Complete => undef,
217             Insert => 1,
218             Edit_Position => 0,
219             Prompt => $input_prompt,
220             Prompt_Size => $prompt_size,
221             };
222             }
223             # Allow override of possible global options
224             if ($params{History_Size}) {
225             $input->{History_Size} = $params{History_Size};
226             }
227             if ($params{Tab_Complete}) {
228             $input->{Tab_Complete} = $params{Tab_Complete};
229             }
230              
231             if (defined $new_window_id) {
232             if (DEBUG) { print ERRS "new_window_id is defined: $new_window_id\n"; }
233             if (!$self->[WINDOW]->{$new_window_id}) {
234             $self->[WINDOW]->{$new_window_id} =
235             { Buffer => [ ],
236             Buffer_Size => $params{Buffer_Size} || 500,
237             Input => $input,
238             Use_Title => $use_title,
239             Use_Status => $use_status,
240             Scrolled_Lines => 0,
241             Window_Id => $new_window_id,
242             Window_Name => $window_name };
243              
244             my $winref = $self->[WINDOW]->{$new_window_id};
245              
246             # Set the newly created window as the current window
247             $self->[CUR_WIN] = $new_window_id;
248              
249             $self->[WINDOW_REV]->{$window_name} = $new_window_id;
250              
251             # create the screen, statusbar, title, and entryline
252             # for this window instance
253              
254             if ($winref->{Use_Title}) {
255             $winref->{Title_Start} = 0;
256             $winref->{Title_Height} = 1;
257             $winref->{Title} = $params{Title} || "";
258              
259             $winref->{Screen_Start} = $winref->{Title_Start} + 1;
260              
261             $winref->{Window_Title} = newwin( $winref->{Title_Height},
262             $COLS,
263             $winref->{Title_Start},
264             0 );
265             # Should we die here??
266             die "No title!!" unless defined $winref->{Window_Title};
267              
268             my $title = $winref->{Window_Title};
269              
270             $title->bkgd($self->[PALETTE]->{st_frames}->[PAL_PAIR]);
271             $title->erase();
272             _refresh_title( $self, $new_window_id);
273             }
274              
275             if ($winref->{Use_Status}) {
276             $winref->{Status_Height} = $params{Status_Height} || 2;
277             $winref->{Status_Start} = $LINES - $winref->{Status_Height} - 1;
278              
279             #FIXME I think this got lost when the new design was implemented.
280             $winref->{Def_Status_Field} = [ ];
281              
282             $winref->{Screen_End} = $winref->{Status_Start} - 1;
283              
284             $winref->{Window_Status} = newwin( $winref->{Status_Height},
285             $COLS,
286             $winref->{Status_Start},
287             0 );
288             my $status = $winref->{Window_Status};
289             if (DEBUG) { print ERRS $status, " <-status in create_window\n"; }
290             $status->bkgd($self->[PALETTE]->{st_frames}->[PAL_PAIR]);
291             $status->erase();
292             $status->noutrefresh();
293              
294             $winref->{Status_Object} = Term::Visual::StatusBar->new();
295             set_status_format( $self, $new_window_id, %{$params{Status}});
296             $winref->{Status_Lines} = $winref->{Status_Object}->get();
297             if (DEBUG) { print ERRS "passed set_status_format in create_window\n"; }
298             }
299              
300             if ($winref->{Use_Title} && $winref->{Use_Status}) {
301             $winref->{Screen_Height} =
302             $winref->{Screen_End} - $winref->{Screen_Start} + 1;
303             }
304              
305             else {
306             $winref->{Screen_Start} = 0 unless defined $winref->{Screen_Start};
307             $winref->{Screen_End} = $LINES - 2 unless defined $winref->{Screen_End};
308             $winref->{Screen_Height} =
309             $winref->{Screen_End} - $winref->{Screen_Start} + 1
310             unless defined $winref->{Screen_Height};
311             }
312              
313             $winref->{Edit_Height} = 1;
314             $winref->{Edit_Start} = $LINES - 1;
315              
316             $winref->{Buffer_Last} = $winref->{Buffer_Size} - 1;
317             $winref->{Buffer_First} = $winref->{Screen_Height} - 1;
318             $winref->{Buffer_Visible} = $winref->{Screen_Height} - 1;
319              
320              
321             $winref->{Window_Edit} = newwin( $winref->{Edit_Height},
322             $COLS,
323             $winref->{Edit_Start},
324             0 );
325             my $edit = $winref->{Window_Edit};
326             $edit->scrollok(1);
327              
328             $winref->{Window_Screen} = newwin( $winref->{Screen_Height},
329             $COLS,
330             $winref->{Screen_Start},
331             0 );
332             my $screen = $winref->{Window_Screen};
333              
334             $screen->bkgd($self->[PALETTE]->{ncolor}->[PAL_PAIR]);
335             $screen->erase();
336             $screen->noutrefresh();
337              
338             $winref->{Buffer_Row} = $winref->{Buffer_Last};
339              
340             $winref->{Buffer} = [("") x $winref->{Buffer_Size}];
341              
342             _refresh_edit($self, $new_window_id);
343              
344              
345             # Flush updates.
346             doupdate();
347              
348             return $new_window_id;
349            
350             }
351             else {
352             if (DEBUG) { print ERRS "Window $params{Window_Name} already exists\n"; }
353             carp "Window $params{Window_Name} already exists";
354             }
355             }
356             else {
357             if (DEBUG) { print ERRS "Window $params{Window_Name} couldn't be created\n"; }
358             croak "Window $params{Window_Name} couldn't be created";
359             }
360             }
361              
362              
363             ### delete one or more windows ##TODO add error handling
364             ### $vt->delete_window($window_id);
365              
366             sub delete_window {
367             if (DEBUG) { print ERRS "Enter delete_window\n"; }
368             my $self = shift;
369             my $win;
370             for (@_) {
371             $win = $_;
372             my $name = get_window_name($self, $_);
373             delete $self->[WINDOW]->{$_};
374             delete $self->[WINDOW_REV]->{$name};
375             }
376             return unless defined $win;
377             my $new_win;
378             my $cur_win = $win;
379             # Select previous window
380             while (--$cur_win > 0) {
381             if (exists $self->[WINDOW]{$cur_win}) {
382             $new_win = $cur_win;
383             last;
384             }
385             }
386             # No previous window, select next window
387             unless (defined $new_win) {
388             $cur_win = $win;
389             while (++$cur_win <= keys %{$self->[WINDOW]}) {
390             if (exists $self->[WINDOW]{$cur_win}) {
391             $new_win = $cur_win;
392             last;
393             }
394             }
395             }
396             if (defined $new_win) {
397             change_window($self, $new_win);
398             }
399             elsif (DEBUG) {
400             print ERRS "We have no more windows!\n"
401             }
402             }
403              
404             ### check if a window exists
405              
406             sub validate_window {
407             if (DEBUG) { print ERRS "Enter validate_window\n"; }
408             my $self = shift;
409             my $query = shift;
410             if (DEBUG) { print ERRS "Validating: $query\n"; }
411             if ($query =~ /^\d+$/ && defined $self->[WINDOW]->{$query}) { return 1; }
412             elsif (defined $self->[WINDOW_REV]->{$query}) { return 1; }
413             else { return 0; }
414             }
415              
416             ### return a windows palette or a specific colorname's description
417             ### my %palette = $vt->get_palette(); # entire palette.
418             ### my ($color_desc, $another_desc) = $vt->get_palette($colorname, $somecolor); # color desc.
419              
420             sub get_palette {
421             my $self = shift;
422             my @result;
423             if ($#_ >= 0) {
424             for (@_) { push( @result, $self->[PALETTE]->{$_}->[PAL_DESC] ); }
425             return @result;
426             }
427             else {
428             for my $key (keys %{$self->[PALETTE]}) {
429             push( @result, $key, $self->[PALETTE]->{$key}->[PAL_DESC]);
430             }
431             return @result;
432             }
433              
434             }
435              
436             ### set the palette for a window
437              
438             sub set_palette {
439             if (DEBUG) { print ERRS "Enter set_palette\n"; }
440             my $self = shift;
441             if (DEBUG) { print ERRS "palette needs an even number of parameters\n" if @_ & 1; }
442             croak "palette needs an even number of parameters" if @_ & 1;
443             my %params = @_;
444             _set_color($self, %params);
445             }
446              
447             sub get_window_name {
448             my $self = shift;
449             my $id = shift;
450             if ($id =~ /^\d+$/) {
451             return $self->[WINDOW]->{$id}->{Window_Name};
452             }
453             else {
454             if (DEBUG) { print ERRS "$id is not a Window ID\n"; }
455             croak "$id is not a Window ID";
456             }
457             }
458              
459             sub get_window_id {
460             my $self = shift;
461             my $query = shift;
462             my $validity = validate_window($self, $query);
463             if ($validity) {
464             return $self->[WINDOW_REV]->{$query};
465             }
466             else {
467             if (DEBUG) { print ERRS "$query is not a Window Name\n"; }
468             croak "$query is not a Window Name";
469             }
470             }
471              
472             ### set the Title for a Window.
473              
474             sub set_title {
475             if (DEBUG) { print ERRS "Enter set_title\n"; }
476             my $self = shift;
477             my ($window_id, $title) = @_;
478             my $validity = validate_window($self, $window_id);
479             if ($validity) {
480             $self->[WINDOW]->{$window_id}->{Title} = $title;
481             if ($window_id == $self->[CUR_WIN]) {
482             _refresh_title( $self, $window_id );
483             doupdate();
484             }
485             }
486             else {
487             if (DEBUG) { print ERRS "Window $window_id is nonexistant\n"; }
488             croak "Window $window_id is nonexistant";
489             }
490             }
491              
492             ### get the Title for a Window.
493              
494             sub get_title {
495             my $self = shift;
496             my $window_id = shift;
497             my $validity = validate_window($self, $window_id);
498             if ($validity) {
499             return $self->[WINDOW]->{$window_id}->{Title};
500             }
501             else {
502             if (DEBUG) { print ERRS "Window $window_id is nonexistant\n"; }
503             croak "Window $window_id is nonexistant";
504             }
505             }
506              
507             ### print lines to window
508             ### a window_id must be given as the first argument.
509              
510             sub print {
511             if (DEBUG) { print ERRS "Enter print\n"; }
512             my $self = shift;
513             my $window_id = shift;
514             if (!validate_window($self, $window_id)) {
515             if (DEBUG) { print ERRS "Can't print to nonexistant Window $window_id\n"; }
516             croak "Can't print to nonexistant Window $window_id";
517             }
518              
519             my @lines;
520             foreach my $l (@_) {
521             foreach my $ll (split(/\n/,$l)) {
522             $ll =~ s/\r//g;
523             push(@lines,$ll);
524             }
525             }
526              
527             my $winref = $self->[WINDOW]->{$window_id};
528              
529             foreach (@lines) {
530              
531             # Start a new line in the scrollback buffer.
532              
533             push @{$winref->{Buffer}}, "";
534             $winref->{Scrolled_Lines}++;
535             my $column = 1;
536              
537             # Build a scrollback line. Stuff surrounded by \0() does not take
538             # up screen space, so account for that while wrapping lines.
539              
540             my $last_color = "\0(ncolor)";
541             while (length) {
542              
543             # Unprintable color codes.
544             if (s/^(\0\([^\)]+\))//) {
545             $winref->{Buffer}->[-1] .= $last_color = $1;
546             next;
547             }
548              
549             # Wordwrap visible stuff.
550             if (s/^([^\0]+)//) {
551             my @words = split /(\s+)/, $1;
552             foreach my $word (@words) {
553             unless (defined $word) {
554             warn "undefined word";
555             next;
556             }
557              
558             while ($column + length($word) >= $COLS) {
559             # maybe this word length should be configurable
560             if (length($word) > 20) {
561             # save the word
562             my $preword = $word;
563             # shorten the word to the end of the line
564             $word = substr($word,0,($COLS - $column));
565             # add the word
566             $winref->{Buffer}->[-1] .= "$word\0(ncolor)";
567             $word = '';
568              
569             # put the last color on the next line and wrap
570             push @{$winref->{Buffer}}, $last_color;
571             $winref->{Scrolled_Lines}++;
572             # slice the unmodified word
573             $word = substr($preword,($COLS - $column));
574             $column = 1;
575             next;
576             } else {
577             $winref->{Buffer}->[-1] .= "\0(ncolor)";
578             push @{$winref->{Buffer}}, $last_color;
579             }
580             $winref->{Scrolled_Lines}++;
581             $column = 1;
582             next if $word =~ /^\s+$/;
583             }
584             $winref->{Buffer}->[-1] .= $word;
585             $column += length($word);
586             $word = '';
587             }
588             }
589             }
590             }
591              
592             # Keep the scrollback buffer a tidy length.
593             splice(@{$winref->{Buffer}}, 0, @{$winref->{Buffer}} - $winref->{Buffer_Size})
594             if @{$winref->{Buffer}} > $winref->{Buffer_Size};
595              
596             # Refresh the buffer when it's all done.
597             if ($self->[CUR_WIN] == $window_id) {
598             _refresh_buffer($self, $window_id);
599             _refresh_edit($self, $window_id);
600             doupdate();
601             }
602             }
603              
604             ## Register key bindings
605              
606             sub bind {
607             my $self = shift;
608             carp "invalid arugments to ->bindings()" if @_ & 1;
609             my %bindings = @_;
610             for (keys %bindings) {
611             my $key = _parse_key($_)
612             or carp "Invalid escape sequence $_";
613             $self->[BINDINGS]{$key} = $bindings{$_};
614             }
615             }
616              
617             ## UnRegister key bindings
618              
619             sub unbind {
620             my $self = shift;
621             for (@_) {
622             my $key = _parse_key($_)
623             or carp "Invalid escape sequence $_";
624             delete $self->[BINDINGS]{$key};
625             }
626             }
627              
628             sub _parse_key {
629             my ($key) = @_;
630             my $esc = '';
631             while ($key =~ s/^(A(?:lt)|C(?:trl)?)-//i) {
632             my $in = uc $1;
633             if (substr($in, 0, 1) eq 'C') {
634             $esc .= '^'
635             }
636             elsif (substr($in, 0, 1) eq 'A') {
637             $esc .= '^[';
638             }
639             else {
640             die "We should not get here: $_";
641             }
642             }
643              
644             if (length($key) == 1) {
645             return $esc . $key;
646             }
647             else {
648             return $esc . "KEY_" . uc($key);
649             }
650             }
651              
652             ### Register an input handler thing.
653              
654             sub register_input {
655             if (DEBUG) { print ERRS "Enter register_input\n"; }
656             my ($kernel, $heap, $sender, $event) = @_[KERNEL, HEAP, SENDER, ARG0];
657              
658             # Remember the remote session and the event it wants to receive with
659             # input. This saves the sender's ID (instead of a reference)
660             # because references mess with Perl's garbage collection.
661              
662             $heap->{input_session} = $sender->ID();
663             $heap->{input_event} = $event;
664            
665             # Increase the sender's reference count so the session stays alive
666             # while the terminal is active. We'll decrease the reference count
667             # in _stop so it can go away when the terminal does.
668            
669             $kernel->refcount_increment( $sender->ID(), "terminal link" );
670              
671             }
672              
673             ### Get input from the Curses thing.
674              
675             sub got_curses_input {
676             if (DEBUG) { print ERRS "Enter got_curses_input\n"; }
677             my ($self, $kernel, $heap, $key) = @_[OBJECT, KERNEL, HEAP, ARG0];
678              
679             my $window_id = $self->[CUR_WIN];
680             my $winref = $self->[WINDOW]->{$window_id};
681             $key = uc(keyname($key)) if $key =~ /^\d{2,}$/;
682             $key = uc(unctrl($key)) if $key lt " " or $key gt "~";
683              
684             # If it's a meta key, save it.
685             if ($key eq '^[') {
686             $winref->{Input}{Prefix} .= $key;
687             return;
688             }
689              
690             # If there was a saved prefix, recall it.
691             if ($winref->{Input}{Prefix}) {
692             $key = $winref->{Input}{Prefix} . $key;
693             $winref->{Input}{Prefix} = '';
694             }
695              
696             ### Handle internal keystrokes here. Page up, down, arrow keys, etc.
697              
698             # key bindings
699             if (exists $self->[BINDINGS]{$key} and $heap->{input_session}) {
700             $kernel->post( $heap->{input_session}, $self->[BINDINGS]{$key},
701             $key, $winref, $window_id
702             );
703             return;
704             }
705              
706             # Beginning of line.
707             if ($key eq '^A' or $key eq 'KEY_HOME') {
708             if ($winref->{Input}{Cursor}) {
709             if ($winref->{Input}{Prompt_Size}) {
710             $winref->{Input}{Cursor} = $winref->{Input}{Prompt_Size};
711             } else {
712             $winref->{Input}{Cursor} = 0;
713             }
714             _refresh_edit($self, $window_id);
715             doupdate();
716             }
717             return;
718             }
719              
720             # Back one character.
721             if ($key eq 'KEY_LEFT') {
722             if ($winref->{Input}{Cursor}) {
723             if($winref->{Input}{Prompt}) {
724             if($winref->{Input}{Cursor} > $winref->{Input}{Prompt_Size}) {
725             $winref->{Input}{Cursor}--;
726             }
727             } else {
728             $winref->{Input}{Cursor}--;
729             }
730             _refresh_edit($self, $window_id);
731             doupdate();
732             }
733             return;
734             }
735             if (DEBUG) { print ERRS $key, "\n"; }
736             # Switch Windows to the left Shifted left arrow
737             #FIXME come up with a better fix. KEY_LEFT didnt work for me.
738             if ($key eq 'ð' or $key eq '^[KEY_LEFT') {
739             $window_id--;
740             change_window($self, $window_id );
741             return;
742             }
743              
744             # Switch Windows to the right Shifted right arrow
745             #FIXME come up with a better fix. KEY_RIGHT didnt work for me.
746             if ($key eq 'î' or $key eq '^[KEY_RIGHT') {
747             $window_id++;
748             change_window($self, $window_id );
749             return;
750             }
751              
752             # Interrupt.
753             if ($key eq '^\\') {
754              
755             $kernel->alias_remove($self->[ALIAS]);
756             delete $heap->{stderr_reader};
757             undef $console;
758             if (defined $heap->{input_session}) {
759             delete $heap->{input_session};
760             }
761             $kernel->signal($kernel, "UIDESTROY");
762             return;
763             }
764              
765             # Delete a character.
766             if ($key eq '^D' or $key eq 'KEY_DC') {
767             my $csize = $winref->{Input}{Cursor} - $winref->{Input}{Prompt_Size};
768             if ($csize < length($winref->{Input}{Data})) {
769             substr($winref->{Input}{Data}, $winref->{Input}{Cursor} - $winref->{Input}{Prompt_Size}, 1) = '';
770             _refresh_edit($self, $window_id);
771             doupdate();
772             }
773             return;
774             }
775              
776             # End of line.
777             if ($key eq '^E' or $key eq 'KEY_LL') {
778             if ($winref->{Input}{Cursor} < length($winref->{Input}{Data})) {
779             $winref->{Input}{Cursor} = length($winref->{Input}{Data});
780             _refresh_edit($self, $window_id);
781             doupdate();
782             }
783             return;
784             }
785              
786             # Forward character.
787             if ($key eq '^F' or $key eq 'KEY_RIGHT') {
788             if (($winref->{Input}{Cursor} - $winref->{Input}{Prompt_Size}) < length($winref->{Input}{Data})) {
789             $winref->{Input}{Cursor}++;
790             _refresh_edit($self, $window_id);
791             doupdate();
792             }
793             return;
794             }
795              
796             # Backward delete character.
797             if ($key eq '^H' or $key eq "^?" or $key eq 'KEY_BACKSPACE') {
798             if ($winref->{Input}{Cursor}) {
799             if ($winref->{Input}{Cursor} > ($winref->{Input}{Prompt_Size} )) {
800             $winref->{Input}{Cursor}--;
801             substr($winref->{Input}{Data}, $winref->{Input}{Cursor} - $winref->{Input}{Prompt_Size}, 1) = '';
802             _refresh_edit($self, $window_id);
803             doupdate();
804             }
805             }
806             return;
807             }
808              
809             # Accept line.
810             if ($key eq '^J' or $key eq '^M') {
811             $kernel->post( $heap->{input_session}, $heap->{input_event},
812             $winref->{Input}{Data}, undef
813             );
814              
815             # And enter the line into the command history.
816             command_history( $self, $window_id, 0 );
817             return;
818             }
819              
820             # Kill to EOL.
821             if ($key eq '^K') {
822             if ($winref->{Input}{Cursor} < length($winref->{Input}{Data})) {
823             substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) = '';
824             _refresh_edit($self, $window_id);
825             doupdate();
826             }
827             return;
828             }
829              
830             # Refresh screen.
831             if ($key eq '^L' or $key eq 'KEY_RESIZE') {
832              
833             # Refresh the title line.
834             _refresh_title($self, $window_id);
835              
836             # Refresh the status lines.
837             _refresh_status( $self, $window_id);
838              
839             # Refresh the buffer.
840             _refresh_buffer($self, $window_id);
841              
842             # Refresh the edit line.
843             _refresh_edit($self, $window_id);
844              
845             # Flush updates.
846             doupdate();
847              
848             return;
849             }
850              
851             # Next in history.
852             if ($key eq '^N' ) {
853             command_history( $self, $window_id, 2 );
854             return;
855             }
856              
857             # Previous in history.
858             if ($key eq '^P' ) {
859             command_history( $self, $window_id, 1 );
860             return;
861             }
862              
863             # Display input status.
864             if ($key eq '^Q') {
865             &print( $self, $window_id, # <- can I do this better?
866             "\0(statcolor)******",
867             "\0(statcolor)*** cursor is at $winref->{Input}{Cursor}",
868             "\0(statcolor)*** input is: ``$winref->{Input}{Data}''",
869             "\0(statcolor)*** scrolled lines: $winref->{Scrolled_Lines}",
870             "\0(statcolor)*** screen height: " . $winref->{Screen_Height},
871             "\0(statcolor)*** buffer row: $winref->{Buffer_Row}",
872             "\0(statcolor)*** scrollback height: " . scalar(@{$winref->{Buffer}}),
873             "\0(statcolor)******"
874             );
875             return;
876             }
877              
878             # Transpose characters.
879             if ($key eq '^T') {
880             if ($winref->{Input}{Cursor} > 0 and $winref->{Input}{Cursor} < length($winref->{Input}{Data})) {
881             substr($winref->{Input}{Data}, $winref->{Input}{Cursor}-1, 2) =
882             reverse substr($winref->{Input}{Data}, $winref->{Input}{Cursor}-1, 2);
883             _refresh_edit($self, $window_id);
884             doupdate();
885             }
886             return;
887             }
888              
889             # Discard line.
890             if ($key eq '^U') {
891             if (length($winref->{Input}{Data})) {
892             $winref->{Input}{Data} = '';
893             $winref->{Input}{Cursor} = 0;
894             _refresh_edit($self, $window_id);
895             doupdate();
896             }
897             return;
898             }
899              
900             # Word rubout.
901             if ($key eq '^W' or $key eq '^[^H') {
902             if ($winref->{Input}{Cursor}) {
903             substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor}) =~ s/(\S*\s*)$//;
904             $winref->{Input}{Cursor} -= length($1);
905             _refresh_edit($self, $window_id);
906             doupdate();
907             }
908             return;
909             }
910              
911             # First in history.
912             if ($key eq '^[<') {
913             # TODO
914             return;
915             }
916              
917             # Last in history.
918             if ($key eq '^[>') {
919             # TODO
920             return;
921             }
922              
923             # Capitalize from cursor on. Requires uc($key)
924             if (uc($key) eq '^[C') {
925              
926             # If there's text to capitalize.
927             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\s*)(\S+)/) {
928              
929             # Track leading space, and uppercase word.
930             my $space = $1; $space = '' unless defined $space;
931             my $word = ucfirst(lc($2));
932              
933             # Replace text with the uppercase version.
934             substr( $winref->{Input}{Data},
935             $winref->{Input}{Cursor} + length($space), length($word)
936             ) = $word;
937              
938             $winref->{Input}{Cursor} += length($space . $word);
939             _refresh_edit($self, $window_id);
940             doupdate();
941             }
942             return;
943             }
944              
945             # Uppercase from cursor on. Requires uc($key)
946             if (uc($key) eq '^[U') {
947              
948             # If there's text to uppercase.
949             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\s*)(\S+)/) {
950              
951             # Track leading space, and uppercase word.
952             my $space = $1; $space = '' unless defined $space;
953             my $word = uc($2);
954              
955             # Replace text with the uppercase version.
956             substr( $winref->{Input}{Data},
957             $winref->{Input}{Cursor} + length($space), length($word)
958             ) = $word;
959              
960             $winref->{Input}{Cursor} += length($space . $word);
961             _refresh_edit($self, $window_id);
962             doupdate();
963             }
964             return;
965             }
966              
967             # Lowercase from cursor on. Requires uc($key)
968             if (uc($key) eq '^[L') {
969              
970             # If there's text to uppercase.
971             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\s*)(\S+)/) {
972              
973             # Track leading space, and uppercase word.
974             my $space = $1; $space = '' unless defined $space;
975             my $word = lc($2);
976              
977             # Replace text with the uppercase version.
978             substr( $winref->{Input}{Data},
979             $winref->{Input}{Cursor} + length($space), length($word)
980             ) = $word;
981              
982             $winref->{Input}{Cursor} += length($space . $word);
983             _refresh_edit($self, $window_id);
984             doupdate();
985             }
986             return;
987             }
988              
989             # Forward one word. Requires uc($key)
990             if (uc($key) eq '^[F') {
991             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\s*\S+)/) {
992             $winref->{Input}{Cursor} += length($1);
993             _refresh_edit($self, $window_id);
994             doupdate();
995             }
996             return;
997             }
998              
999             # Backward one word. This needs uc($key).
1000             if (uc($key) eq '^[B') {
1001             if (substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor}) =~ /(\S+\s*)$/) {
1002             $winref->{Input}{Cursor} -= length($1);
1003             _refresh_edit($self, $window_id);
1004             doupdate();
1005             }
1006             return;
1007             }
1008              
1009             # Delete a word forward. This needs uc($key).
1010             if (uc($key) eq '^[D') {
1011             if ($winref->{Input}{Cursor} < length($winref->{Input}{Data})) {
1012             substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ s/^(\s*\S*\s*)//;
1013             _refresh_edit($self, $window_id);
1014             doupdate();
1015             }
1016             return;
1017             }
1018              
1019             # Transpose words. This needs uc($key).
1020             if (uc($key) eq '^[T') {
1021             my ($previous, $left, $space, $right, $rest);
1022              
1023             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}, 1) =~ /\s/) {
1024             my ($left_space, $right_space);
1025             ($previous, $left, $left_space) =
1026             ( substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor}) =~ /^(.*?)(\S+)(\s*)$/
1027             );
1028             ($right_space, $right, $rest) =
1029             ( substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\s+)(\S+)(.*)$/
1030             );
1031             $space = $left_space . $right_space;
1032             }
1033             elsif ( substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor}) =~
1034             /^(.*?)(\S+)(\s+)(\S*)$/
1035             ) {
1036             ($previous, $left, $space, $right) = ($1, $2, $3, $4);
1037             if (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\S*)(.*)$/) {
1038             $right .= $1 if defined $1;
1039             $rest = $2;
1040             }
1041             }
1042             elsif (substr($winref->{Input}{Data}, $winref->{Input}{Cursor}) =~ /^(\S+)(\s+)(\S+)(.*)$/
1043             ) {
1044             ($left, $space, $right, $rest) = ($1, $2, $3, $4);
1045             if ( substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor}) =~ /^(.*?)(\S+)$/ ) {
1046             $previous = $1;
1047             $left = $2 . $left;
1048             }
1049             }
1050             else {
1051             return;
1052             }
1053              
1054             $previous = '' unless defined $previous;
1055             $rest = '' unless defined $rest;
1056              
1057             $winref->{Input}{Data} = $previous . $right . $space . $left . $rest;
1058             $winref->{Input}{Cursor} = length($previous. $left . $space . $right);
1059              
1060             _refresh_edit($self, $window_id);
1061             doupdate();
1062             return;
1063             }
1064              
1065             # Toggle insert mode.
1066             if ($key eq 'KEY_IC') {
1067             $winref->{Input}{Insert} = !$winref->{Input}{Insert};
1068             return;
1069             }
1070             # If the window is scrolled up go back to the beginning.
1071             if ($key eq 'KEY_SELECT') {
1072             $winref->{Buffer_Row} = $winref->{Buffer_Last};
1073             _refresh_buffer($self, $window_id);
1074             _refresh_edit($self, $window_id);
1075             doupdate();
1076             return;
1077             }
1078              
1079             # Scroll back a page.
1080             if ($key eq 'KEY_PPAGE') {
1081             if ($winref->{Buffer_Row} > $winref->{Buffer_First}) {
1082             $winref->{Buffer_Row} -= $winref->{Screen_Height};
1083             if ($winref->{Buffer_Row} < $winref->{Buffer_First}) {
1084             $winref->{Buffer_Row} = $winref->{Buffer_First}
1085             }
1086             _refresh_buffer($self, $window_id);
1087             _refresh_edit($self, $window_id);
1088             doupdate();
1089             }
1090             return;
1091             }
1092              
1093             # Scroll forward a page.
1094             if ($key eq 'KEY_NPAGE') {
1095             if ($winref->{Buffer_Row} < $winref->{Buffer_Last}) {
1096             $winref->{Buffer_Row} += $winref->{Screen_Height};
1097             if ($winref->{Buffer_Row} > $winref->{Buffer_Last}) {
1098             $winref->{Buffer_Row} = $winref->{Buffer_Last};
1099             }
1100             _refresh_buffer($self, $window_id);
1101             _refresh_edit($self, $window_id);
1102             doupdate();
1103             }
1104             return;
1105             }
1106              
1107             # Scroll back a line.
1108             if ($key eq 'KEY_UP') {
1109             if ($winref->{Buffer_Row} > $winref->{Buffer_First}) {
1110             $winref->{Buffer_Row}--;
1111             _refresh_buffer($self, $window_id);
1112             _refresh_edit($self, $window_id);
1113             doupdate();
1114             }
1115             return;
1116             }
1117              
1118             # Scroll forward a line.
1119             if ($key eq 'KEY_DOWN') {
1120             if ($winref->{Buffer_Row} < $winref->{Buffer_Last}) {
1121             $winref->{Buffer_Row}++;
1122             _refresh_buffer($self, $window_id);
1123             _refresh_edit($self, $window_id);
1124             doupdate();
1125             }
1126             return;
1127             }
1128              
1129             if ($key eq "^I") {
1130             if ($winref->{Input}{Tab_Complete}) {
1131             my $left = substr($winref->{Input}{Data}, 0, $winref->{Input}{Cursor});
1132             my $right = substr($winref->{Input}{Data}, $winref->{Input}{Cursor});
1133             my @str = $winref->{Input}{Tab_Complete}->($left, $right);
1134             my $complete_word = $1 if $left =~ /(\S+)\s*\z/;
1135             $left =~ s/\Q$complete_word\E\s*\z// if $complete_word;
1136             if (@str == 1) {
1137             my $data = $left . $str[0];
1138             $winref->{Input}{Data} = $data . $right;
1139             $winref->{Input}{Cursor} = length $data;
1140             _refresh_edit($self, $window_id);
1141             doupdate();
1142             }
1143             elsif (@str) {
1144             # complete to something they all have in common
1145             my $shortest = '';
1146             for (@str) {
1147             if (!length($shortest) or length($_) < length $shortest) {
1148             $shortest = $_;
1149             }
1150             }
1151             my $i = length $shortest;
1152             for (@str) {
1153             while (substr($shortest, 0, $i) ne substr($_, 0, $i) and $i) {
1154             $i--;
1155             }
1156             last unless $i;
1157             }
1158             if ($i) {
1159             $winref->{Input}{Data} = $left . substr($shortest, 0, $i) . $right;
1160             $winref->{Input}{Cursor} = length($left) + $i;
1161             }
1162             my $table = columnize(
1163             Items => \@str,
1164             MaxWidth => $COLS
1165             );
1166             for (split /\n/, $table) {
1167             &print($self, $window_id, $_);
1168             }
1169             }
1170             }
1171             return;
1172             }
1173              
1174             ### Not an internal keystroke. Add it to the input buffer.
1175             #FIXME double check if this is needed...
1176             $key = chr(ord($1)-64) if $key =~ /^\^([@-_BC])$/;
1177              
1178             # Inserting or overwriting in the middle of the input.
1179             if ($winref->{Input}{Cursor} < length($winref->{Input}{Data})) {
1180             if ($winref->{Input}{Insert}) {
1181             substr($winref->{Input}{Data}, $winref->{Input}{Cursor}, 0) = $key;
1182             }
1183             else {
1184             substr($winref->{Input}{Data}, $winref->{Input}{Cursor}, length($key)) = $key;
1185             }
1186             }
1187              
1188             # Appending.
1189             else {
1190             $winref->{Input}{Data} .= $key;
1191             }
1192              
1193             $winref->{Input}{Cursor} += length($key);
1194             _refresh_edit($self, $window_id);
1195             doupdate();
1196             return;
1197             }
1198              
1199             sub columnize {
1200             croak "Arguments to columnize must be a hash" if @_ & 1;
1201             my %opts = @_;
1202              
1203             my $width = delete $opts{MaxWidth};
1204             $width = 80 unless defined $width;
1205             croak "Invalid width $width" if $width <= 0;
1206              
1207             my $padding = delete $opts{Padding};
1208             $padding = 2 unless defined $padding;
1209             croak "Invalid padding $padding" if $padding < 0;
1210              
1211             my $max_columns = delete $opts{MaxColumns};
1212             $max_columns = 10 unless defined $max_columns;
1213             croak "Invalid max columns $max_columns" if $max_columns <= 0;
1214              
1215             my $items = delete $opts{Items};
1216             croak "Items must be an array reference"
1217             unless ref($items) eq 'ARRAY';
1218              
1219             croak "Unknown arguments: '", join("', '", sort keys %opts), "'"
1220             if keys %opts;
1221              
1222             for my $i (reverse 2 .. $max_columns) {
1223             my $n = 0;
1224             my @cols;
1225             my $num_rows = 0;
1226             for (0 .. $#{$items}) {
1227             push @{$cols[$n++]}, $items->[$_];
1228             unless (($_ + 1) % $i) {
1229             $n = 0;
1230             $num_rows++;
1231             }
1232             }
1233             my @long;
1234             for $n (0 .. $#cols) {
1235             for my $item (@{$cols[$n]}) {
1236             if (!$long[$n] or length($item) > $long[$n]) {
1237             $long[$n] = length $item;
1238             }
1239             }
1240             }
1241             my $total = 0;
1242             for (@long) {
1243             $total += $_ + $padding;
1244             }
1245             next if $total > $width;
1246             my $table = '';
1247             for (0 .. $num_rows) {
1248             my $row;
1249             for $n (0 .. $#cols) {
1250             my $item = $cols[$n][$_];
1251             last unless defined $item;
1252             $row .= $item . (' ' x ($long[$n] - length($item) + $padding));
1253             }
1254             $table .= $row . "\n";
1255             }
1256             return $table;
1257             last;
1258             }
1259             return join("\n", @$items) . "\n";
1260             }
1261             ##FIXME Has this been replaced with _parse_key() ??
1262             my %ctrl_to_visible;
1263             BEGIN {
1264             for (0..31) {
1265             $ctrl_to_visible{chr($_)} = chr($_+64);
1266             }
1267             }
1268              
1269             ### Common thing. Refresh the buffer on the screen.
1270             ## Pass in $self and a window_id
1271              
1272             sub _refresh_buffer {
1273             if (DEBUG) { print ERRS "Enter _refresh_buffer\n"; }
1274             my $self = shift;
1275             my $window_id = shift;
1276             my $winref = $self->[WINDOW]->{$window_id};
1277             my $screen = $winref->{Window_Screen};
1278              
1279             if ($window_id != $self->[CUR_WIN]) { return; }
1280             # Adjust the buffer row to compensate for any scrolling we encounter
1281             # while in scrollback.
1282              
1283             if ($winref->{Buffer_Row} < $winref->{Buffer_Last}) {
1284             $winref->{Buffer_Row} -= $winref->{Scrolled_Lines};
1285             }
1286              
1287             # Don't scroll up past the start of the buffer.
1288              
1289             if ($winref->{Buffer_Row} < $winref->{Buffer_First}) {
1290             $winref->{Buffer_Row} = $winref->{Buffer_First};
1291             }
1292              
1293             # Don't scroll down past the bottom of the buffer.
1294              
1295             if ($winref->{Buffer_Row} > $winref->{Buffer_Last}) {
1296             $winref->{Buffer_Row} = $winref->{Buffer_Last};
1297             }
1298              
1299             # Now splat the last N lines onto the screen.
1300              
1301             $screen->erase();
1302             $screen->noutrefresh();
1303              
1304             $winref->{Scrolled_Lines} = 0;
1305              
1306             my $screen_y = 0;
1307             my $buffer_y = $winref->{Buffer_Row} - $winref->{Buffer_Visible};
1308             while ($screen_y < $winref->{Screen_Height}) {
1309             $screen->move($screen_y, 0);
1310             $screen->clrtoeol();
1311             $screen->noutrefresh();
1312              
1313             next if $buffer_y < 0;
1314             next if $buffer_y > $winref->{Buffer_Last};
1315              
1316             my $line = $winref->{Buffer}->[$buffer_y]; # does this work?
1317             my $column = 1;
1318             while (length $line) {
1319             while ($line =~ s/^\0\(([^)]+)\)//) {
1320             my $cmd = $1;
1321             if ($cmd =~ /blink_(on|off)/) {
1322             if ($1 eq 'on') { $screen->attron(A_BLINK); }
1323             if ($1 eq 'off') { $screen->attroff(A_BLINK); }
1324             $screen->noutrefresh();
1325             }
1326             elsif ($cmd =~ /bold_(on|off)/) {
1327             if ($1 eq 'on') { $screen->attron(A_BOLD); }
1328             if ($1 eq 'off') { $screen->attroff(A_BOLD); }
1329             $screen->noutrefresh();
1330             }
1331             elsif ($cmd =~ /underline_(on|off)/) {
1332             if ($1 eq 'on') { $screen->attron(A_UNDERLINE); }
1333             if ($1 eq 'off') { $screen->attroff(A_UNDERLINE); }
1334             $screen->noutrefresh();
1335             }
1336             else {
1337             $screen->attrset($self->[PALETTE]->{$cmd}->[PAL_PAIR]);
1338             $screen->noutrefresh();
1339             }
1340             }
1341              
1342             if ($line =~ s/^([^\0]+)//x) {
1343              
1344             # TODO: This needs to be revised so it cuts off the last word,
1345             # not omits it entirely.
1346             # Has this been fixed already??
1347             next if $column >= $COLS;
1348             if ($column + length($1) > $COLS) {
1349             my $word = $1;
1350             substr($word, ($column + length($1)) - $COLS - 1) = '';
1351             $screen->addstr($word);
1352             }
1353             else {
1354             $screen->addstr($1);
1355             }
1356             $column += length($1);
1357             $screen->noutrefresh();
1358             }
1359             }
1360              
1361             $screen->attrset($self->[PALETTE]->{ncolor}->[PAL_PAIR]);
1362             $screen->noutrefresh();
1363             $screen->clrtoeol();
1364             $screen->noutrefresh();
1365             }
1366             continue {
1367             $screen_y++;
1368             $buffer_y++;
1369             }
1370             }
1371              
1372             # Internal function to set the color palette for a window.
1373              
1374             sub _set_color {
1375             if (DEBUG) { print ERRS "Enter _set_color\n"; }
1376             my $self= shift;
1377             # my $window_id = shift;
1378             # my $winref = $self->[WINDOW]->{$window_id};
1379             my %params = @_;
1380              
1381             my %color_table =
1382             ( bk => COLOR_BLACK, black => COLOR_BLACK,
1383             bl => COLOR_BLUE, blue => COLOR_BLUE,
1384             br => COLOR_YELLOW, brown => COLOR_YELLOW,
1385             fu => COLOR_MAGENTA, fuschia => COLOR_MAGENTA,
1386             cy => COLOR_CYAN, cyan => COLOR_CYAN,
1387             gr => COLOR_GREEN, green => COLOR_GREEN,
1388             ma => COLOR_MAGENTA, magenta => COLOR_MAGENTA,
1389             re => COLOR_RED, red => COLOR_RED,
1390             wh => COLOR_WHITE, white => COLOR_WHITE,
1391             ye => COLOR_YELLOW, yellow => COLOR_YELLOW,
1392             de => -1, default => -1,
1393             );
1394              
1395             my %attribute_table =
1396             ( al => A_ALTCHARSET,
1397             alt => A_ALTCHARSET,
1398             alternate => A_ALTCHARSET,
1399             blink => A_BLINK,
1400             blinking => A_BLINK,
1401             bo => A_BOLD,
1402             bold => A_BOLD,
1403             bright => A_BOLD,
1404             dim => A_DIM,
1405             fl => A_BLINK,
1406             flash => A_BLINK,
1407             flashing => A_BLINK,
1408             hi => A_BOLD,
1409             in => A_INVIS,
1410             inverse => A_REVERSE,
1411             inverted => A_REVERSE,
1412             invisible => A_INVIS,
1413             inviso => A_INVIS,
1414             lo => A_DIM,
1415             low => A_DIM,
1416             no => A_NORMAL,
1417             norm => A_NORMAL,
1418             normal => A_NORMAL,
1419             pr => A_PROTECT,
1420             prot => A_PROTECT,
1421             protected => A_PROTECT,
1422             reverse => A_REVERSE,
1423             rv => A_REVERSE,
1424             st => A_STANDOUT,
1425             stand => A_STANDOUT,
1426             standout => A_STANDOUT,
1427             un => A_UNDERLINE,
1428             under => A_UNDERLINE,
1429             underline => A_UNDERLINE,
1430             underlined => A_UNDERLINE,
1431             underscore => A_UNDERLINE,
1432             );
1433              
1434              
1435             for my $color_name (keys %params) {
1436              
1437             my $description = $params{$color_name};
1438             my $foreground = 0;
1439             my $background = 0;
1440             my $attributes = 0;
1441              
1442             # Which is an alias to foreground or background depending on what
1443             # state we're in.
1444             my $which = \$foreground;
1445              
1446             # Clean up the color description.
1447             $description =~ s/^\s+//;
1448             $description =~ s/\s+$//;
1449             $description = lc($description);
1450              
1451             # Parse the description.
1452             foreach my $word (split /\s+/, $description) {
1453              
1454             # The word "on" means we're switching to background.
1455             if ($word eq 'on') {
1456             $which = \$background;
1457             next;
1458             }
1459              
1460             # If it's a color name, combine its value with the foreground or
1461             # background, whichever is currently selected.
1462             if (exists $color_table{$word}) {
1463             $$which |= $color_table{$word};
1464             next;
1465             }
1466              
1467             # If it's an attribute, it goes with attributes.
1468             if (exists $attribute_table{$word}) {
1469             $attributes |= $attribute_table{$word};
1470             next;
1471             }
1472              
1473             # Otherwise it's an error.
1474             if (DEBUG) { print ERRS "unknown color keyword \"$word\"\n"; }
1475             croak "unknown color keyword \"$word\"";
1476             }
1477              
1478             # If the palette already has that color, redefine it.
1479             if (exists $self->[PALETTE]->{$color_name}) {
1480             my $old_color_number = $self->[PALETTE]->{$color_name}->[PAL_NUMBER];
1481             init_pair($old_color_number, $foreground, $background);
1482             $self->[PALETTE]->{$color_name}->[PAL_PAIR] =
1483             COLOR_PAIR($old_color_number) | $attributes;
1484             }
1485             else {
1486             my $new_color_number = ++$self->[PAL_COL_SEQ];
1487             init_pair($new_color_number, $foreground, $background);
1488             $self->[PALETTE]->{$color_name} =
1489             [ COLOR_PAIR($new_color_number) | $attributes, # PAL_PAIR
1490             $new_color_number, # PAL_NUMBER
1491             $description, # PAL_DESC
1492             ];
1493             }
1494             }
1495             }
1496              
1497             ### The terminal stopped. Remove the reference count for the remote
1498             ### session.
1499              
1500             sub terminal_stopped {
1501             if (DEBUG) { print ERRS "Enter terminal_stopped\n"; }
1502             my ($kernel, $heap) = @_[KERNEL, HEAP];
1503             $kernel->alias_remove($_[OBJECT][ALIAS]);
1504             delete $heap->{stderr_reader};
1505             undef $console;
1506              
1507             if (defined $heap->{input_session}) {
1508             $kernel->refcount_decrement( $heap->{input_session}, "terminal link" );
1509             delete $heap->{input_session};
1510             }
1511             }
1512              
1513             sub change_window {
1514             if (DEBUG) { print ERRS "change_window called\n"; }
1515             my $self = shift;
1516             my $window_id = shift;
1517             my @list = sort {$a <=> $b} keys %{$self->[WINDOW]};
1518              
1519             if (@list) {
1520             if ($window_id == -1) {
1521             $window_id = $list[$#list];
1522             }
1523             elsif ($window_id > $list[$#list]) {
1524             $window_id = 0;
1525             }
1526             }
1527              
1528             my $validity = validate_window($self, $window_id);
1529             if ($validity) {
1530             $self->[CUR_WIN] = $window_id;
1531             update_window( $self, $window_id );
1532             }
1533             }
1534              
1535             sub update_window {
1536             my $self = shift;
1537             my $window_id = shift;
1538              
1539             _refresh_title( $self, $window_id );
1540             _refresh_buffer( $self, $window_id );
1541             _refresh_status( $self, $window_id );
1542             _refresh_edit( $self, $window_id );
1543             doupdate();
1544             }
1545              
1546             sub _refresh_title {
1547             if (DEBUG) { print ERRS "Enter _refresh_title\n"; }
1548             my ($self, $window_id) = @_;
1549             my $winref = $self->[WINDOW]->{$window_id};
1550             my $title = $winref->{Window_Title};
1551              
1552             if ($window_id != $self->[CUR_WIN]) { return; }
1553              
1554             $title->move(TITLE_LINE, TITLE_COL);
1555             $title->attrset($self->[PALETTE]->{st_values}->[PAL_PAIR]);
1556             $title->noutrefresh();
1557             $title->addstr($winref->{Title}) unless !$winref->{Title};
1558             $title->noutrefresh();
1559             $title->clrtoeol();
1560             $title->noutrefresh();
1561             doupdate();
1562             }
1563              
1564             sub _refresh_edit {
1565             if (DEBUG) { print ERRS "Enter _refresh_edit\n"; }
1566             my $self = shift;
1567             my $window_id = shift;
1568             my $winref = $self->[WINDOW]->{$window_id};
1569             my $edit = $winref->{Window_Edit};
1570             my $visible_input = $winref->{Input}{Data};
1571              
1572             # If the cursor is after the last visible edit position, scroll the
1573             # edit window left so the cursor is back on-screen.
1574              
1575             if ($winref->{Input}{Cursor} - $winref->{Input}{Edit_Position} >= $COLS) {
1576             $winref->{Input}{Edit_Position} = $winref->{Input}{Cursor} - $COLS + 1;
1577             }
1578              
1579             # If the cursor is moving left of the middle of the screen, scroll
1580             # things to the right so that both sides of the cursor may be seen.
1581              
1582             elsif ($winref->{Input}{Cursor} - $winref->{Input}{Edit_Position} < ($COLS >> 1)) {
1583             $winref->{Input}{Edit_Position} = $winref->{Input}{Cursor} - ($COLS >> 1);
1584             $winref->{Input}{Edit_Position} = 0 if $winref->{Input}{Edit_Position} < 0;
1585             }
1586              
1587             # If the cursor is moving right of the middle of the screen, scroll
1588             # things to the left so that both sides of the cursor may be seen.
1589              
1590             elsif ( $winref->{Input}{Cursor} <= length($winref->{Input}{Data}) - ($COLS >> 1) + 1 ){
1591             $winref->{Input}{Edit_Position} = $winref->{Input}{Cursor} - ($COLS >> 1);
1592             }
1593              
1594             # Condition $visible_input so it really is.
1595             $visible_input = substr($visible_input, $winref->{Input}{Edit_Position}, $COLS-1);
1596              
1597             $edit->attron(A_NORMAL);
1598             $edit->erase();
1599             $edit->noutrefresh();
1600             if ($winref->{Input}{Prompt}) {
1601             $visible_input = $winref->{Input}{Prompt} . $visible_input;
1602             }
1603             while (length($visible_input)) {
1604             if ($visible_input =~ /^[\x00-\x1f]/) {
1605             $edit->attron(A_UNDERLINE);
1606             while ($visible_input =~ s/^([\x00-\x1f])//) {
1607             $edit->addstr($ctrl_to_visible{$1});
1608             }
1609             }
1610             if ($visible_input =~ s/^([^\x00-\x1f]+)//) {
1611             $edit->attroff(A_UNDERLINE);
1612             $edit->addstr($1);
1613             }
1614             }
1615              
1616             $edit->noutrefresh();
1617             $edit->move( 0, $winref->{Input}{Cursor} - $winref->{Input}{Edit_Position} );
1618             $edit->noutrefresh();
1619             }
1620              
1621             ### Set or call command history lines.
1622              
1623             sub command_history {
1624             if (DEBUG) { print ERRS "Enter command_history\n"; }
1625             my $self = shift;
1626             my $window_id = shift;
1627             my $flag = shift;
1628             my $winref = $self->[WINDOW]->{$window_id};
1629              
1630             if ($flag == 0) { #add to command history
1631              
1632             # Add to the command history. Discard the oldest item if the
1633             # history size is bigger than our maximum length.
1634              
1635             unshift(@{$winref->{Input}{Command_History}}, $winref->{Input}{Data});
1636             pop(@{$winref->{Input}{Command_History}}) if @{$winref->{Input}{Command_History}} > $winref->{Input}{History_Size};
1637              
1638             # Reset the input, saved input, and history position. Repaint the
1639             # edit box.
1640              
1641             $winref->{Input}{Data_Save} = $winref->{Input}{Data} = "";
1642             $winref->{Input}{Cursor_Save} = $winref->{Input}{Cursor} = $winref->{Input}{Prompt_Size} || 0;
1643             $winref->{Input}{History_Position} = -1;
1644              
1645             _refresh_edit($self, $window_id);
1646             doupdate();
1647              
1648             return;
1649             }
1650              
1651             if ($flag == 1) { # get last history 'KEY_UP'
1652              
1653             # At <0 command history, we save the input and move into the
1654             # command history. The saved input will be used in case we come
1655             # back.
1656              
1657             if ($winref->{Input}{History_Position} < 0) {
1658             if (@{$winref->{Input}{Command_History}}) {
1659             $winref->{Input}{Data_Save} = $winref->{Input}{Data};
1660             $winref->{Input}{Cursor_Save} = $winref->{Input}{Cursor};
1661             $winref->{Input}{Data} =
1662             $winref->{Input}{Command_History}->[++$winref->{Input}{History_Position}];
1663             $winref->{Input}{Cursor} = length($winref->{Input}{Data});
1664             if ($winref->{Input}{Prompt_Size}) {
1665             $winref->{Input}{Cursor} += $winref->{Input}{Prompt_Size};
1666             }
1667             _refresh_edit($self, $window_id);
1668             doupdate();
1669             }
1670             }
1671              
1672             # If we're not at the end of the command history, then we go
1673             # farther back.
1674              
1675             elsif ($winref->{Input}{History_Position} < @{$winref->{Input}{Command_History}} - 1) {
1676             $winref->{Input}{Data} = $winref->{Input}{Command_History}->[++$winref->{Input}{History_Position}];
1677             $winref->{Input}{Cursor} = length($winref->{Input}{Data});
1678             if ($winref->{Input}{Prompt_Size}) {
1679             $winref->{Input}{Cursor} += $winref->{Input}{Prompt_Size};
1680             }
1681             _refresh_edit($self, $window_id);
1682             doupdate();
1683             }
1684              
1685             return;
1686             }
1687              
1688             if ($flag == 2) { # get next history 'KEY_DOWN'
1689              
1690             # At 0th command history. Switch to saved input.
1691             unless ($winref->{Input}{History_Position}) {
1692             $winref->{Input}{Data} = $winref->{Input}{Data_Save};
1693             $winref->{Input}{Cursor} = $winref->{Input}{Cursor_Save};
1694             $winref->{Input}{History_Position}--;
1695             _refresh_edit($self, $window_id);
1696             doupdate();
1697             }
1698              
1699             # At >0 command history. Move towards 0.
1700             elsif ($winref->{Input}{History_Position} > 0) {
1701             $winref->{Input}{Data} = $winref->{Input}{Command_History}->[--$winref->{Input}{History_Position}];
1702             $winref->{Input}{Cursor} = length($winref->{Input}{Data});
1703             if ($winref->{Input}{Prompt_Size}) {
1704             $winref->{Input}{Cursor} += $winref->{Input}{Prompt_Size};
1705             }
1706             _refresh_edit($self, $window_id);
1707             doupdate();
1708             }
1709              
1710             return;
1711             }
1712              
1713             warn "unknown flag $flag";
1714             }
1715              
1716             sub set_status_field {
1717             if (DEBUG) { print ERRS "Enter set_status_field\n"; }
1718             my $self = shift;
1719             my $window_id = shift;
1720             my $validity = validate_window($self, $window_id);
1721             if ($validity) {
1722             my $winref = $self->[WINDOW]->{$window_id};
1723             my $status_obj = $winref->{Status_Object};
1724             $winref->{Status_Lines} = $status_obj->set(@_);
1725             _refresh_status($self, $window_id);
1726             _refresh_edit($self, $window_id);
1727             doupdate();
1728              
1729             }
1730             }
1731              
1732             sub set_status_format {
1733             if (DEBUG) { print ERRS "Enter set_status_format\n"; }
1734             my $self = shift;
1735             my $window_id = shift;
1736             my %status_formats = @_;
1737             if (DEBUG) { print ERRS %status_formats, " <-status_formats\n"; }
1738             my $validity = validate_window($self, $window_id);
1739             if ($validity) {
1740             my $winref = $self->[WINDOW]->{$window_id};
1741             my $status_obj = $winref->{Status_Object};
1742             if (DEBUG) { print ERRS "calling status_obj->set_format\n"; }
1743             $status_obj->set_format(%status_formats);
1744             if (DEBUG) { print ERRS "calling status_obj->get\n"; }
1745             $winref->{Status_Lines} = $status_obj->get();
1746             if (DEBUG) { print ERRS "calling refresh_status\n"; }
1747             # Update the status line.
1748             _refresh_status( $self, $window_id );
1749             if (DEBUG) { print ERRS "returned from refresh_status\n"; }
1750             doupdate();
1751             }
1752             }
1753              
1754             sub _refresh_status {
1755             if (DEBUG) { print ERRS "Enter _refresh_status\n"; }
1756             my ($self, $window_id) = (shift, shift);
1757              
1758             if ($window_id != $self->[CUR_WIN]) { return; }
1759              
1760             my ($row, $value);
1761             my $winref = $self->[WINDOW]->{$window_id};
1762             my $status = $winref->{Window_Status};
1763             my @status_lines = @{$winref->{Status_Lines}};
1764             while (@status_lines) {
1765             if (DEBUG) { print ERRS "in main while loop of refresh_status\n"; }
1766             $row = shift @status_lines;
1767             $value = shift @status_lines;
1768             if (DEBUG) { print ERRS "$row <-row value-> $value\n"; }
1769             if (DEBUG) { print ERRS $status, "<-status ref\n"; }
1770             $status->move( $row, 0 );
1771              
1772             # Parse the value. Stuff surrounded by ^C is considered color
1773             # names. This interferes with epic/mirc colors.
1774              
1775             while (defined $value and length $value) {
1776             if (DEBUG) { print ERRS "while defined value and length value in refresh_status\n"; }
1777             if ($value =~ s/^\0\(([^\)]+)\)//) {
1778             if (DEBUG) { print ERRS "value matched", '^\0\(([^\)]+)\)', "\n"; }
1779             $status->attrset($self->[PALETTE]->{$1}->[PAL_PAIR]);
1780             $status->noutrefresh();
1781             }
1782             if ($value =~ s/^([^\0]+)//) {
1783             if (DEBUG) { print ERRS "value matched", '^([^\0]+)', "\n"; }
1784             $status->addstr($1);
1785             $status->noutrefresh();
1786             }
1787             }
1788             }
1789              
1790             # Clear to the end of the line, and refresh the status bar.
1791             $status->attrset($self->[PALETTE]->{st_frames}->[PAL_PAIR]);
1792             $status->noutrefresh();
1793             $status->clrtoeol();
1794             $status->noutrefresh();
1795              
1796             }
1797              
1798             sub set_input_prompt {
1799             if (DEBUG) { print ERRS "Enter set_input_prompt\n"; }
1800             my $self = shift;
1801             my $window_id = shift;
1802             my $prompt = shift;
1803             my $validity = validate_window($self, $window_id);
1804             if ($validity) {
1805             my $winref = $self->[WINDOW]->{$window_id};
1806             $winref->{Input}{Cursor} -= $winref->{Input}{Prompt_Size};
1807             $winref->{Input}{Prompt} = $prompt;
1808             $winref->{Input}{Cursor} = $winref->{Input}{Prompt_Size} = length $prompt;
1809             _refresh_edit($self, $window_id);
1810             doupdate();
1811             }
1812             }
1813              
1814             sub set_errlevel {}
1815             sub get_errlevel {}
1816              
1817             sub debug {
1818             my $self = shift;
1819             if (DEBUG) { for (@_) { print ERRS "$_\n";} }
1820             else { carp "turn on debugging in Term::Visual or define sub Term::Visual::DEBUG () { 1 }; before use Term::Visual; in your program"; }
1821              
1822             }
1823              
1824             sub shutdown {
1825             my $self = shift;
1826              
1827             $poe_kernel->post($self->[ALIAS], "_stop");
1828              
1829             # $_[KERNEL]->alias_remove($_[OBJECT][ALIAS]);
1830             # delete $_[HEAP]->{stderr_reader};
1831             # undef $console;
1832             # if (defined $_[HEAP]->{input_session}) {
1833             # $_[KERNEL]->post( $_[HEAP]->{input_session}, $_[HEAP]->{input_event},
1834             # undef, 'interrupt' );
1835              
1836             #clean up, and close Term::Visual's session so that the only thing that is left is client side, and when ^\ is punched in, clean up things that would leak otherwise, and interrupt?
1837              
1838             # }
1839             }
1840              
1841             1;
1842              
1843             __END__