home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Base.pm < prev    next >
Encoding:
Perl POD Document  |  2005-04-27  |  14.5 KB  |  536 lines
  1. package Term::ReadLine::Zoid::Base;
  2.  
  3. use strict;
  4. no warnings;
  5. use Term::ReadKey qw/ReadMode ReadKey GetTerminalSize/;
  6. #use encoding 'utf8';
  7. no warnings; # undef == '' down here
  8.  
  9. our $VERSION = '0.06';
  10.  
  11. $| = 1;
  12.  
  13. our @_key_buffer;
  14.  
  15. our %chr_map = ( # partial sequences
  16.     "\e"    => '',
  17.     "\e["   => '',
  18.     "\eO"   => '',
  19.     "\e[["  => '',
  20.     ( map {("\e[$_" => '')} (1 .. 24) ),
  21.  
  22.     "\e[2"     => '',    "\e[5"     => '',
  23.     "\eO2"     => '',    "\eO5"     => '',
  24.     "\e[1;2" => '',    "\e[1;5" => '',
  25. );
  26.  
  27. our %chr_names = ( # named keys
  28.     "\e"   => 'escape',
  29.     "\cH"  => 'backspace',
  30.     "\cI"  => 'tab',
  31.     "\cJ"  => 'return',    # line feed
  32.     "\cM"  => 'return',    # carriage return
  33.     "\c?"  => 'backspace', # traditionally known as DEL
  34.  
  35.     "\e[A" => 'up',            "\eOA" => 'up',
  36.     "\e[B" => 'down',         "\eOB" => 'down',
  37.     "\e[C" => 'right',        "\eOC" => 'right',
  38.     "\e[D" => 'left',         "\eOD" => 'left',
  39.     "\e[F" => 'end',        "\eOF" => 'end',
  40.     "\e[H" => 'home',        "\eOH" => 'home',
  41.  
  42.     "\e[1~"  => 'home',
  43.     "\e[2~"  => 'insert',
  44.     "\e[3~"  => 'delete',
  45.     "\e[4~"  => 'end',
  46.     "\e[5~"  => 'page_up',
  47.     "\e[6~"  => 'page_down',
  48.     "\e[11~" => 'f1',        "\eOP" => 'f1',        "\e[[A" => 'f1',
  49.     "\e[12~" => 'f2',        "\eOQ" => 'f2',        "\e[[B" => 'f2',
  50.     "\e[13~" => 'f3',        "\eOR" => 'f3',        "\e[[C" => 'f3',
  51.     "\e[14~" => 'f4',        "\eOS" => 'f4',        "\e[[D" => 'f4',
  52.     "\e[15~" => 'f5',                    "\e[[E" => 'f5',
  53.     "\e[17~" => 'f6',
  54.     "\e[18~" => 'f7',
  55.     "\e[19~" => 'f8',
  56.     "\e[20~" => 'f9',
  57.     "\e[21~" => 'f10',
  58.     "\e[23~" => 'f11',
  59.     "\e[24~" => 'f12',
  60.  
  61.     "\e[2A" => 'shift_up',        "\eO2A" => 'shift_up',        "\e[1;2A" => 'shift_up',
  62.     "\e[2B" => 'shift_down',    "\eO2B" => 'shift_down',    "\e[1;2B" => 'shift_down',
  63.     "\e[2C" => 'shift_right',    "\eO2C" => 'shift_right',    "\e[1;2C" => 'shift_right',
  64.     "\e[2D" => 'shift_left',    "\eO2D" => 'shift_left',    "\e[1;2D" => 'shift_left',
  65.     "\e[2F" => 'shift_end',        "\eO2F" => 'shift_end',        "\e[1;2F" => 'shift_end',
  66.     "\e[2H" => 'shift_home',    "\eO2H" => 'shift_home',    "\e[1;2H" => 'shift_home',
  67.  
  68.     "\e[5A" => 'ctrl_up',        "\eO5A" => 'ctrl_up',        "\e[1;5A" => 'ctrl_up',
  69.     "\e[5B" => 'ctrl_down',        "\eO5B" => 'ctrl_down',        "\e[1;5B" => 'ctrl_down',
  70.     "\e[5C" => 'ctrl_right',    "\eO5C" => 'ctrl_right',    "\e[1;5C" => 'ctrl_right',
  71.     "\e[5D" => 'ctrl_left',        "\eO5D" => 'ctrl_left',        "\e[1;5D" => 'ctrl_left',
  72.     "\e[5F" => 'ctrl_end',        "\eO5F" => 'ctrl_end',        "\e[1;5F" => 'ctrl_end',
  73.     "\e[5H" => 'ctrl_home',        "\eO5H" => 'ctrl_home',        "\e[1;5H" => 'ctrl_home',
  74. );
  75.  
  76. #    '[6A' => 'ctrl_shift_up',    'O6A' => 'ctrl_shift_up',    '[1;6A' => 'ctrl_shift_up',
  77. #    '[6B' => 'ctrl_shift_down',    'O6B' => 'ctrl_shift_down',    '[1;6B' => 'ctrl_shift_down',
  78. #    '[6C' => 'ctrl_shift_right',    'O6C' => 'ctrl_shift_right',    '[1;6C' => 'ctrl_shift_right',
  79. #    '[6D' => 'ctrl_shift_left',    'O6D' => 'ctrl_shift_left',    '[1;6D' => 'ctrl_shift_left',
  80. #    '[6F' => 'ctrl_shift_end',    'O6F' => 'ctrl_shift_end',    '[1;6F' => 'ctrl_shift_end',
  81. #    '[6H' => 'ctrl_shift_home',    'O6H' => 'ctrl_shift_home',    '[1;6H' => 'ctrl_shift_home',
  82.  
  83. #    '[7A' => 'ctrl_alt_up',        'O7A' => 'ctrl_alt_up',        '[1;7A' => 'ctrl_alt_up',
  84. #    '[7B' => 'ctrl_alt_down',    'O7B' => 'ctrl_alt_down',    '[1;7B' => 'ctrl_alt_down',
  85. #    '[7C' => 'ctrl_alt_right',    'O7C' => 'ctrl_alt_right',    '[1;7C' => 'ctrl_alt_right',
  86. #    '[7D' => 'ctrl_alt_left',    'O7D' => 'ctrl_alt_left',    '[1;7D' => 'ctrl_alt_left',
  87. #    '[7F' => 'ctrl_alt_end',    'O7F' => 'ctrl_alt_end',    '[1;7F' => 'ctrl_alt_end',
  88. #    '[7H' => 'ctrl_alt_home',    'O7H' => 'ctrl_alt_home',    '[1;7H' => 'ctrl_alt_home',
  89.  
  90. # ############## #
  91. # base functions #
  92. # ############## #
  93.  
  94. sub bell {
  95.     #print STDERR 'bell called by: ',join(', ', caller)."\n";
  96.     exists( $_[0]{config}{bell} )
  97.         ? $_[0]{config}{bell}->()
  98.         : print { $_[0]{OUT} } "\cG" ; # ^G == \007 == BELL
  99.     return 0;
  100. }
  101.  
  102. sub loop {
  103.     my $self = shift;
  104.     $$self{lines} = [''] unless @{$$self{lines}};
  105.     $$self{term_size} = [ (GetTerminalSize($$self{IN}))[0,1] ];
  106.     @ENV{'COLUMNS', 'LINES'} = @{$$self{term_size}} if $$self{config}{autoenv};
  107.     $self->draw();
  108.     $$self{_loop} = 1;
  109.     while ($$self{_loop}) {
  110.         $self->do_key();
  111.         while (@_key_buffer) { $self->do_key() }
  112.         $self->draw();
  113.     }
  114.     $self->cursor_at(@{$$self{_buffer_end}});
  115. }
  116.  
  117. sub beat { $_[0]{config}{beat}->() if exists $_[0]{config}{beat} }
  118.  
  119. sub read_key { die "deprecated warning" if $_[1];
  120.     my $self = shift;
  121.     return shift @_key_buffer if scalar @_key_buffer;
  122.  
  123.     my $chr;
  124.     ReadMode('raw', $$self{IN});
  125.     {
  126.         local $SIG{WINCH} = sub { $$self{_SIGWINCH} = 1 };
  127.  
  128.         while ( not defined ($chr = ReadKey(1, $$self{IN})) ) { $self->beat() }
  129.  
  130.         my $n_chr;
  131.         if (
  132.             exists $chr_map{$chr} and
  133.             ( $$self{config}{low_latency} or ($n_chr = ReadKey(0.05, $$self{IN})) )
  134.         ) {
  135.             $chr .= $n_chr;
  136.             while (exists $chr_map{$chr}) {
  137.                 while ( not defined ($n_chr = ReadKey(1, $$self{IN})) ) { $self->beat() }
  138.                 $chr .= $n_chr;
  139.             }
  140.             unless (exists $chr_names{$chr}) {
  141.                 $chr =~ s/^(.)(.*)/$1/s;
  142.                 push @_key_buffer, split '', $2;
  143.             }
  144.         }
  145.     }
  146.     ReadMode('normal', $$self{IN});
  147.  
  148.     return $chr;
  149. }
  150.  
  151. sub do_key {
  152.     my ($self, $key) = (shift, shift);
  153.     $key = $self->read_key() unless length $key;
  154.  
  155.     # $self->key_name()
  156.     if (exists $chr_names{$key}) { $key = $chr_names{$key} }
  157.     elsif (length $key < 2) {
  158.         my $ord = ord $key;
  159.         $key =      ($ord < 32)   ? 'ctrl_'  . (chr $ord + 64)
  160.             : ($ord == 127) ? 'ctrl_?' : $key ;
  161.     }
  162.  
  163.     # $self->key_binding
  164.     my $map = $$self{keymaps}{$$self{mode}};
  165.     my $sub;
  166.     DO_KEY:
  167.     if (exists $$map{$key}) { $sub = $$map{$key} }
  168.     elsif (exists $$map{_isa}) {
  169.         $map = $$self{keymaps}{ $$map{_isa} }
  170.             || return warn "$$map{_isa}: no such keymap\n\n";
  171.         goto DO_KEY;
  172.     }
  173.     elsif (exists $$map{_default}) { $sub = $$map{_default} }
  174.     else { $sub = 'bell' }
  175.  
  176.     #print STDERR "# key: $key sub: $sub\n";
  177.     my $re = ref($sub) ? $sub->($self, $key, @_) : $self->$sub($key, @_) ;
  178.     $$self{last_key} = $key;
  179.     return $re;
  180. }
  181.  
  182. sub print {
  183.     # The idea is to let the terminal render the line wrap
  184.     # but calculate what it will do in order to get the cursor position right.
  185.     my ($self, $lines, $pos) = @_;
  186. #    use Data::Dumper;
  187. #    print STDERR Dumper $lines, $pos;
  188.     if ($$self{_SIGWINCH}) { # GetTerminalSize is kind of heavy
  189.         $$self{term_size} = [ (GetTerminalSize($$self{IN}))[0,1] ];
  190.         @ENV{'COLUMNS', 'LINES'} = @{$$self{term_size}} if $$self{config}{autoenv};
  191.         $$self{_SIGWINCH} = 0;
  192.     }
  193.  
  194.     my ($width, $higth) = @{$$self{term_size}};
  195.  
  196.     # calculate how line wrap will work out
  197.     my @nlines = map { int(print_length($_) / $width) } @$lines;
  198.     $$pos[1] += $nlines[$_] for 0 .. $$pos[1] - 1;
  199.     $$pos[1] += int($$pos[0] / $width);
  200.     $$pos[0] %= $width;
  201. #    print STDERR Dumper \@nlines, $pos;
  202.  
  203.     # get the lines at the right position
  204.     my $buffer = -1; # always 1 lines minimum
  205.     $buffer += 1 + $_ for @nlines;
  206.     my $null = 1;
  207.     if ($buffer > $higth) { # big buffer or small screen :$
  208.         # FIXME does not yet reckon with line wrap
  209.         # FIXME some +1 or -1 offsets not right
  210.         my $offset = $$pos[1] - $$self{scroll_pos};
  211.         if ($offset < 0) { $$self{scroll_pos} = $$pos[1] }
  212.         elsif ($offset > $higth) { $$self{scroll_pos} += $offset - $higth }
  213.         @$lines = splice @$lines, $$self{scroll_pos}, $higth;
  214.         $$pos[1] -= $$self{scroll_pos};
  215.         $$self{_buffer_end} = [$width, $higth];
  216.         $$self{_buffer} = $higth;
  217.     }
  218.     else { # normal readline buffer
  219.         if ($buffer > $$self{_buffer}) { # clear screen area
  220.             $self->cursor_at(@{$$self{term_size}});
  221.             print { $$self{OUT} } "\n" x ($buffer - $$self{_buffer});
  222.             $$self{_buffer} = $buffer;
  223.         }
  224.         $null = $$self{term_size}[1] - $$self{_buffer};
  225.         $$self{_buffer_end} = [print_length($$lines[-1]), $null + $buffer]; # save real cursor
  226.     }
  227.     $self->cursor_at(1, $null);
  228.     print { $$self{OUT} } $$lines[$_], "\e[K\n" for 0 .. $#$lines - 1;
  229.     print { $$self{OUT} } $$lines[-1], "\e[J";
  230.  
  231.     $self->cursor_at($$pos[0]+1, $$pos[1]+$null); # set cursor
  232. }
  233.  
  234. # ######### #
  235. # utilities #
  236. # ######### #
  237.  
  238. sub TermSize { (GetTerminalSize($_[0]{IN}))[0,1] }
  239.  
  240. sub key_name {
  241.     if (exists $chr_names{$_[1]}) { return $chr_names{$_[1]} }
  242.     elsif (length $_[1] < 2) {
  243.         my $ord = ord $_[1];
  244.         return      ($ord < 32)   ? 'ctrl_'  . (chr $ord + 64)
  245.             : ($ord == 127) ? 'ctrl_?' : $_[1] ;
  246.     }
  247.     else { return $_[1] }
  248. }
  249.  
  250. sub key_binding {
  251.     my ($self, $key, $mode) = @_;
  252.     $mode ||= $$self{mode};
  253.  
  254.     my $map = $$self{keymaps}{$mode};
  255.     FIND_KEY:
  256.     if (exists $$map{$key}) { return $$map{$key} }
  257.     elsif (exists $$map{_isa}) {
  258.         $map = $$self{keymaps}{ $$map{_isa} }
  259.             || return warn "$$map{_isa}: no such keymap\n\n";
  260.         goto FIND_KEY;
  261.     }
  262.     else { return undef }
  263. }
  264.  
  265. sub press {
  266.     my $self = shift;
  267.     push @_key_buffer, (@_>1) ? (@_) : (split '', $_[0]);
  268.     while (scalar @_key_buffer) { $self->do_key() }
  269. }
  270.  
  271. sub unread_key {
  272.     my $self = shift;
  273.     unshift @_key_buffer, (@_>1) ? (@_) : (split '', $_[0]);
  274. }
  275.  
  276. sub pos2off {
  277.     my ($self, $pos) = @_;
  278.     $pos ||= $$self{pos};
  279.     my $off = $$pos[0];
  280.     $off += 1 + length $$self{lines}[$_] for 0 .. $$pos[1] - 1;
  281.     return $off;
  282. }
  283.  
  284. sub output {
  285.     my ($self, @items) = @_;
  286.  
  287.     $self->cursor_at(@{$$self{_buffer_end}});
  288.     print { $$self{OUT} } "\n";
  289.  
  290.     my ($max, $cnt) = ($$self{config}{maxcomplete}, scalar @items);
  291.     $self->_ask($cnt) or return if $max and $max =~ /^\d+$/ and $cnt > $max;
  292.  
  293.     @items = ($cnt > 1) ? ($self->col_format(@items)) : (split /\n/, $items[0]);
  294.  
  295.     $$self{_buffer} = (@items < $$self{_buffer}) ? ($$self{_buffer} - @items) : 0;
  296.     if (@items > $$self{term_size}[1]) {
  297.         $self->_ask($cnt) or return if $max and $max eq 'pager';
  298.         my $pager = $ENV{PAGER} || 'more';
  299.         eval {
  300.             local $SIG{PIPE} = 'IGNORE';
  301.             open PAGER, "| $pager" || die;
  302.             print PAGER join("\n", @items), "\n";
  303.             close PAGER;
  304.         } ;
  305.     }
  306.     else { print { $$self{OUT} } join("\n", @items), "\n" }
  307. }
  308.  
  309. sub _ask {
  310.     my ($self, $cnt) = @_;
  311.     print { $$self{OUT} } "Display all $cnt possibilities? [yN]";
  312.     my $answ = $self->read_key();
  313.     print { $$self{OUT} } "\n";
  314.     return( ($answ =~ /y/i) ? 1 : 0 );
  315. }
  316.  
  317. sub col_format { # takes minimum number of rows, but fills cols first
  318.     my ($self, @items) = @_;
  319.  
  320.     my $len = 0;
  321.     $_ > $len and $len = $_ for map {length $_} @items;
  322.     $len += 2; # spacing
  323.     my ($width) = $self->TermSize();
  324.     return @items if $width < (2 * $len); # rows == items
  325.     return join '  ', @items if $width > (@items * $len); # 1 row
  326.  
  327.     my $cols = int($width / $len ) - 1; # 0 based
  328.     my $rows = int(@items / ($cols+1)); # 0 based ceil
  329.     $rows -= 1 unless @items % ($cols+1); # tune ceil
  330.     my @rows;
  331.     for my $r (0 .. $rows) {
  332.         my @row = map { $items[ ($_ * ($rows+1)) + $r] } 0 .. $cols;
  333.         push @rows, join '', map { $_ .= ' 'x($len - length $_) } @row;
  334.     }
  335.     #print STDERR scalar(@items)." items, $len long, $width width, $cols+1 cols, $rows+1 rows\n";
  336.     return @rows;
  337. }
  338.  
  339. # ################# #
  340. # Key binding stuff #
  341. # ################# #
  342.  
  343. sub bindchr {
  344.     my ($self, $chr, $key) = @_;
  345.     if ($chr =~ /^\^(.)$/) { $chr = eval qq/"\\c$1"/ }
  346.     $chr_names{$chr} = $key;
  347.     chop $chr;
  348.     while (length $chr) {
  349.         $chr_map{$chr} = '';
  350.         chop $chr;
  351.     }
  352. }
  353.  
  354. sub recalc_chr_map {
  355.     my $self = shift;
  356.     %chr_map = ();
  357.     while (my ($k,$v) = each %chr_names) {
  358.         $self->bindchr($k, $v);
  359.     }
  360. }
  361.  
  362. # ########## #
  363. # ANSI stuff #
  364. # ########## #
  365.  
  366. sub cursor_at { print { $_[0]{OUT} } "\e[$_[2];$_[1]H" } # ($x, $y) 1-based !
  367.  
  368. sub new_line {
  369.     my $self = shift;
  370.     return unless -t $$self{OUT} and -t $$self{IN};
  371.  
  372.     ReadMode 'raw';
  373.     my $r;
  374.     print { $$self{OUT} } "\e[6n";
  375.     $r = ReadKey( -1, $$self{IN}) || return print { $$self{OUT} } "\n";
  376.     while ($r =~ /^(\e|\e\[\d*|\e\[\d+;\d*)$/) { $r .= ReadKey -1, $$self{IN} }
  377.     # in this case timed read doesn't work :(
  378.     ReadMode 'normal';
  379.  
  380.     if ($r =~ /^\e\[\d+;(\d+)\D$/) {
  381.         print { $$self{OUT} } "\n" if $1 > 1;
  382.     }
  383.     else {
  384.         $self->unread_key($r);
  385.         print { $$self{OUT} } "\n";
  386.     }
  387. }
  388.  
  389. sub clear_screen { print { $_[0]{OUT} } "\e[2J" }
  390.  
  391. sub print_length {
  392.     my $string = pop;
  393.     $string =~ s{\e\[[\d;]*\w}{}g; # strip ansi codes
  394.     return length $string;
  395. }
  396.  
  397. ## Sequences from the "How to change the title of an xterm" howto
  398. ##  <http://www.tldp.org/HOWTO/Xterm-Title.html>
  399. sub title {
  400.     my ($self, $title) = @_;
  401.     return unless $ENV{TERM};
  402.     my $string =
  403.         ($ENV{TERM} =~ /^((ai)?xterm.*|dtterm|screen)$/) ? "\e]0;$title\cG" :
  404.         ($ENV{TERM} eq 'iris-ansi') ? "\eP1.y$title\e\\" :
  405.         ($ENV{TERM} eq 'sun-cmd')   ? "\e]l$title\e\\"   : undef ;
  406.     print { $$self{OUT} } $string if $string;
  407. }
  408.  
  409. 1;
  410.  
  411. __END__
  412.  
  413. =head1 NAME
  414.  
  415. Term::ReadLine::Zoid::Base - atomic routines
  416.  
  417. =head1 DESCRIPTION
  418.  
  419. This module contains some atomic operations used by all
  420. Term::ReadLine::Zoid objects. It is intended as a base class.
  421.  
  422. At the very least, to child class needs to define a C<default()> function
  423. to handle key bindings and a C<draw()> function
  424. which in turn calls C<print()>. Also the attributes C<IN> and C<OUT>
  425. should contain valid filehandles.
  426.  
  427. =head1 METHODS
  428.  
  429. =head2 ANSI stuff
  430.  
  431. =over 4
  432.  
  433. =item C<cursor_at($x, $y)>
  434.  
  435. Positions the cursor on screen, dimensions are 1-based.
  436.  
  437. =item C<clear_screen()>
  438.  
  439. Clear screen.
  440.  
  441. =item C<title($string)>
  442.  
  443. Set terminal title to C<$string>. When using for example xterm(1)
  444. this is the window name.
  445.  
  446. =item C<print_length($string)>
  447.  
  448. Returns the printable length of $string, not counting (some) ansi sequences.
  449.  
  450. =back
  451.  
  452. =head2 Private api
  453.  
  454. Methods for use in overload classes.
  455. I<Avoid using these methods from the application.>
  456.  
  457. =over 4
  458.  
  459. =item C<bell()>
  460.  
  461. Notify the user of an error or limit.
  462.  
  463. =item C<loop()>
  464.  
  465. Low level function used by L<readline>. 
  466. Calls C<draw()> and C<do_key()>.
  467.  
  468. =item C<beat()>
  469.  
  470. Method called by intervals while waiting for input, to be overloaded.
  471.  
  472. =item C<read_key()>
  473.  
  474. Returns one key read from input (this is the named key, not the char when mapped).
  475.  
  476. =item C<do_key($key)>
  477.  
  478. Execute a key, calls subroutine for a key binding or the default binding.
  479. If C<$key> is undefined C<read_key()> is called first.
  480.  
  481. =item C<press($string)>
  482.  
  483. Do chars in C<$string> like they were typed on the keyboard. Used for testing puposes
  484. and to make macros possible.
  485.  
  486. If you give more then one argument, these are considered individual characters, use this to
  487. press named keys.
  488.  
  489. =item C<unread_key($string)>
  490.  
  491. Unshifts characters on the read buffer, arguments the same as C<press()>.
  492.  
  493. =item C<key_name($chr)>
  494.  
  495. Returns a name for a character or character sequence.
  496.  
  497. =item C<key_binding($key, $mode)>
  498.  
  499. Returns the keybinding for C<$key> in C<$mode>, mode defaults to the current one.
  500.  
  501. =item C<bindchr($chr, $key)>
  502.  
  503. Bind a key name to a character, or a character sequence. All bindings of this kind
  504. are global (you're using only one keyboard, right ?).
  505.  
  506. =item C<recalc_chr_map()>
  507.  
  508. Recalculates the chr map, you need to call this after deleting from C<%chr_names>.
  509.  
  510. =item C<print($lines, $pos)>
  511.  
  512. Low level function used by L<draw>. Both arguments need to be array references.
  513.  
  514. =back
  515.  
  516. =head1 BUGS
  517.  
  518. Undefined behaviour when the buffer has more lines then the terminal.
  519.  
  520. Please mail the author if you find any other bugs.
  521.  
  522. =head1 AUTHOR
  523.  
  524. Jaap Karssenberg || Pardus [Larus] E<lt>pardus@cpan.orgE<gt>
  525.  
  526. Copyright (c) 2004 Jaap G Karssenberg. All rights reserved.
  527. This program is free software; you can redistribute it and/or
  528. modify it under the same terms as Perl itself.
  529.  
  530. =head1 SEE ALSO
  531.  
  532. L<Term::ReadLine::Zoid>
  533.  
  534. =cut
  535.  
  536.