03_disp_slang.pm

   1 # s-lang output for DCT, by Shiar
   2
   3 # 1.13.0 200411042100 - menu i/o functions
   4 #                     - refresh hook renamed to showall
   5 # 1.12.0 200411032145 - define main loop
   6 #                     - use slang key reading functions
   7 # 1.11.0 200410291300 - basic output using Term::Slang (ported from Curses)
   8
   9 use strict;
  10 use warnings;
  11
  12 use Term::Slang qw(:all);
  13
  14 use vars qw(%falias $path);
  15 require $path."termcommon.pm";
  16
  17 push @{$hook{init}}, sub {
  18         SLtt_get_terminfo and exit;
  19         SLang_init_tty(-1, 0, 1);
  20         SLsmg_init_smg;
  21         SLtt_set_color(1, 0, 'black', 'lightgray');
  22
  23         END { SLsmg_reset_smg; SLang_reset_tty; } # shutdown display system
  24
  25         # where are $SLtt_Screen_Rows and $SLtt_Screen_Cols?
  26         ($set{height}, $set{width}) = SLtt_get_screen_size;
  27         $set{height} -= 3;
  28         $set{menushow} = int($set{width}/(4+$set{width}/20))+1;  # menu items to show simultaneously
  29 }; # init
  30
  31 push @{$hook{showerror}}, sub {
  32         my $error = shift;
  33         SLsmg_draw_box(0, 0, 3, length($error)+4);
  34         SLsmg_gotorc(1, 1);
  35         SLsmg_write_string(" $error ");
  36         SLsmg_refresh;
  37
  38         SLang_getkey;  # wait for confirm
  39         SLang_getkey while SLang_input_pending(0)==1; # clear key buffer
  40 }; # showerror
  41
  42 push @{$hook{showstack}}, sub {
  43         for (0..@stack-1) {
  44                 SLsmg_gotorc($set{height}-$_, 1);
  45                 SLsmg_write_string("$_: ".showval($stack[$_], $set{base}));  # prompt
  46                 SLsmg_erase_eol;
  47         } # show stack
  48         SLsmg_gotorc($set{height}-@stack, 1);
  49         SLsmg_erase_eol;
  50 }; # showstack
  51
  52 push @{$hook{showmenu}}, sub {
  53         SLsmg_gotorc($set{height}+2, 1);
  54         SLsmg_erase_eol;
  55         my $nr = -1;
  56         for (grep exists $menu[0][$_], $menu[0][0]+1..$menu[0][0]+$set{menushow}) {
  57                 $nr++;
  58                 next unless defined $menu[0][$_];
  59                 my $sub = (my $s = $menu[0][$_]) =~ s/>[\w ]+$//;
  60                 SLsmg_gotorc($set{height}+2, $set{width}/$set{menushow}*$nr);
  61                 SLsmg_write_string($_);
  62                 SLsmg_reverse_video; # reverse
  63                 SLsmg_write_string($s);
  64                 SLsmg_normal_video;
  65                 SLsmg_write_string('>') if $sub;  # indicate submenu
  66         } # display menu txts
  67 }; # showmenu
  68
  69 $action{more} = [-1, sub {
  70         $menu[0][0] += $set{menushow};
  71         $menu[0][0] = 0 if $menu[0][0] > @{$menu[0]};
  72         $_->() for @{$hook{showmenu}};
  73 }]; # tab
  74
  75 unshift @{$hook{precmd}}, sub {
  76         exists $falias{$_} or return;  # handle function key
  77         if ($falias{$_}==0) {
  78                 shift @menu if @menu>1;  # remove current submenu
  79                 redraw(menu=>1);
  80                 return 1;
  81         } # escape (go to parent)
  82         $_ = $menu[0][$falias{$_}] and return;  # execute found menu item instead
  83         error("no such menu entry");
  84         return 1;
  85 }; # precmd
  86
  87 push @{$hook{showall}}, sub {
  88         SLsmg_cls;
  89         SLsmg_gotorc($set{height}+1, 0);
  90         SLsmg_write_string("> ");  # prompt
  91 }; # showall
  92
  93 push @{$hook{showentry}}, sub {
  94         SLsmg_gotorc($set{height}+1, 2);
  95         SLsmg_write_string($_[0]);
  96         SLsmg_erase_eol;
  97         SLsmg_refresh;
  98 }; # showentry
  99
 100 $hook{main} = sub {
 101         while (1) {
 102                 draw();
 103
 104                 my $key = chr SLang_getkey;  # wait for user input
 105                 if ($key eq chr 27) {
 106                         $key .= chr SLang_getkey while SLang_input_pending(0)==1;  # read additional keys
 107                 } # escape sequence
 108 #               error(join " ", map ord, split //, $key); #debug
 109                 onkey($key);
 110         } # input loop
 111 }; # main
 112
 113 return {
 114         author  => "Shiar",
 115         title   => "slang output",
 116         version => "1.13",
 117 };
 118