File Coverage

blib/lib/Term/ReadLine/Zoid/Base.pm

Criterion	Covered	Total	%
statement	48	218	22.0
branch	25	98	25.5
condition	1	41	2.4
subroutine	11	27	40.7
pod	16	21	76.1
total	101	405	24.9

package Term::ReadLine::Zoid::Base;

use strict;
no warnings;
use Term::ReadKey qw/ReadMode ReadKey GetTerminalSize/;
#use encoding 'utf8';
no warnings; # undef == '' down here

our $VERSION = '0.06';

$| = 1;

our @_key_buffer;

our %chr_map = ( # partial sequences
	"\e"    => '',
	"\e["   => '',
	"\eO"   => '',
	"\e[["  => '',
	( map {("\e[$_" => '')} (1 .. 24) ),

	"\e[2"	 => '',	"\e[5"	 => '',
	"\eO2"	 => '',	"\eO5"	 => '',
	"\e[1;2" => '',	"\e[1;5" => '',
);

our %chr_names = ( # named keys
	"\e"   => 'escape',
	"\cH"  => 'backspace',
	"\cI"  => 'tab',
	"\cJ"  => 'return',    # line feed
	"\cM"  => 'return',    # carriage return
	"\c?"  => 'backspace', # traditionally known as DEL

	"\e[A" => 'up',			"\eOA" => 'up',
	"\e[B" => 'down', 		"\eOB" => 'down',
	"\e[C" => 'right',		"\eOC" => 'right',
	"\e[D" => 'left', 		"\eOD" => 'left',
	"\e[F" => 'end',		"\eOF" => 'end',
	"\e[H" => 'home',		"\eOH" => 'home',

	"\e[1~"  => 'home',
	"\e[2~"  => 'insert',
	"\e[3~"  => 'delete',
	"\e[4~"  => 'end',
	"\e[5~"  => 'page_up',
	"\e[6~"  => 'page_down',
	"\e[11~" => 'f1',		"\eOP" => 'f1',		"\e[[A" => 'f1',
	"\e[12~" => 'f2',		"\eOQ" => 'f2',		"\e[[B" => 'f2',
	"\e[13~" => 'f3',		"\eOR" => 'f3',		"\e[[C" => 'f3',
	"\e[14~" => 'f4',		"\eOS" => 'f4',		"\e[[D" => 'f4',
	"\e[15~" => 'f5',					"\e[[E" => 'f5',
	"\e[17~" => 'f6',
	"\e[18~" => 'f7',
	"\e[19~" => 'f8',
	"\e[20~" => 'f9',
	"\e[21~" => 'f10',
	"\e[23~" => 'f11',
	"\e[24~" => 'f12',

	"\e[2A" => 'shift_up',		"\eO2A" => 'shift_up',		"\e[1;2A" => 'shift_up',
	"\e[2B" => 'shift_down',	"\eO2B" => 'shift_down',	"\e[1;2B" => 'shift_down',
	"\e[2C" => 'shift_right',	"\eO2C" => 'shift_right',	"\e[1;2C" => 'shift_right',
	"\e[2D" => 'shift_left',	"\eO2D" => 'shift_left',	"\e[1;2D" => 'shift_left',
	"\e[2F" => 'shift_end',		"\eO2F" => 'shift_end',		"\e[1;2F" => 'shift_end',
	"\e[2H" => 'shift_home',	"\eO2H" => 'shift_home',	"\e[1;2H" => 'shift_home',

	"\e[5A" => 'ctrl_up',		"\eO5A" => 'ctrl_up',		"\e[1;5A" => 'ctrl_up',
	"\e[5B" => 'ctrl_down',		"\eO5B" => 'ctrl_down',		"\e[1;5B" => 'ctrl_down',
	"\e[5C" => 'ctrl_right',	"\eO5C" => 'ctrl_right',	"\e[1;5C" => 'ctrl_right',
	"\e[5D" => 'ctrl_left',		"\eO5D" => 'ctrl_left',		"\e[1;5D" => 'ctrl_left',
	"\e[5F" => 'ctrl_end',		"\eO5F" => 'ctrl_end',		"\e[1;5F" => 'ctrl_end',
	"\e[5H" => 'ctrl_home',		"\eO5H" => 'ctrl_home',		"\e[1;5H" => 'ctrl_home',
);

#	'[6A' => 'ctrl_shift_up',	'O6A' => 'ctrl_shift_up',	'[1;6A' => 'ctrl_shift_up',
#	'[6B' => 'ctrl_shift_down',	'O6B' => 'ctrl_shift_down',	'[1;6B' => 'ctrl_shift_down',
#	'[6C' => 'ctrl_shift_right',	'O6C' => 'ctrl_shift_right',	'[1;6C' => 'ctrl_shift_right',
#	'[6D' => 'ctrl_shift_left',	'O6D' => 'ctrl_shift_left',	'[1;6D' => 'ctrl_shift_left',
#	'[6F' => 'ctrl_shift_end',	'O6F' => 'ctrl_shift_end',	'[1;6F' => 'ctrl_shift_end',
#	'[6H' => 'ctrl_shift_home',	'O6H' => 'ctrl_shift_home',	'[1;6H' => 'ctrl_shift_home',

#	'[7A' => 'ctrl_alt_up',		'O7A' => 'ctrl_alt_up',		'[1;7A' => 'ctrl_alt_up',
#	'[7B' => 'ctrl_alt_down',	'O7B' => 'ctrl_alt_down',	'[1;7B' => 'ctrl_alt_down',
#	'[7C' => 'ctrl_alt_right',	'O7C' => 'ctrl_alt_right',	'[1;7C' => 'ctrl_alt_right',
#	'[7D' => 'ctrl_alt_left',	'O7D' => 'ctrl_alt_left',	'[1;7D' => 'ctrl_alt_left',
#	'[7F' => 'ctrl_alt_end',	'O7F' => 'ctrl_alt_end',	'[1;7F' => 'ctrl_alt_end',
#	'[7H' => 'ctrl_alt_home',	'O7H' => 'ctrl_alt_home',	'[1;7H' => 'ctrl_alt_home',

# ############## #
# base functions #
# ############## #

sub bell {
	#print STDERR 'bell called by: ',join(', ', caller)."\n";
	exists( $_[0]{config}{bell} )
		? $_[0]{config}{bell}->()
		: print { $_[0]{OUT} } "\cG" ; # ^G == \007 == BELL
	return 0;
}

sub loop {
	my $self = shift;
	$$self{lines} = [''] unless @{$$self{lines}};
	$$self{term_size} = [ (GetTerminalSize($$self{IN}))[0,1] ];
	@ENV{'COLUMNS', 'LINES'} = @{$$self{term_size}} if $$self{config}{autoenv};
	$self->draw();
	$$self{_loop} = 1;
	while ($$self{_loop}) {
		$self->do_key();
		while (@_key_buffer) { $self->do_key() }
		$self->draw();
	}
	$self->cursor_at(@{$$self{_buffer_end}});
}

sub beat { $_[0]{config}{beat}->() if exists $_[0]{config}{beat} }

sub read_key { die "deprecated warning" if $_[1];
	my $self = shift;
	return shift @_key_buffer if scalar @_key_buffer;

	my $chr;
	ReadMode('raw', $$self{IN});
	{
		local $SIG{WINCH} = sub { $$self{_SIGWINCH} = 1 };

		while ( not defined ($chr = ReadKey(1, $$self{IN})) ) { $self->beat() }

		my $n_chr;
		if (
			exists $chr_map{$chr} and
			( $$self{config}{low_latency} or ($n_chr = ReadKey(0.05, $$self{IN})) )
		) {
			$chr .= $n_chr;
			while (exists $chr_map{$chr}) {
				while ( not defined ($n_chr = ReadKey(1, $$self{IN})) ) { $self->beat() }
				$chr .= $n_chr;
			}
			unless (exists $chr_names{$chr}) {
				$chr =~ s/^(.)(.*)/$1/s;
				push @_key_buffer, split '', $2;
			}
		}
	}
	ReadMode('normal', $$self{IN});

	return $chr;
}

sub do_key {
	my ($self, $key) = (shift, shift);
	$key = $self->read_key() unless length $key;

	# $self->key_name()
	if (exists $chr_names{$key}) { $key = $chr_names{$key} }
	elsif (length $key < 2) {
		my $ord = ord $key;
		$key =	  ($ord < 32)   ? 'ctrl_'  . (chr $ord + 64)
			: ($ord == 127) ? 'ctrl_?' : $key ;
	}

	# $self->key_binding
	my $map = $$self{keymaps}{$$self{mode}};
	my $sub;
	DO_KEY:
	if (exists $$map{$key}) { $sub = $$map{$key} }
	elsif (exists $$map{_isa}) {
		$map = $$self{keymaps}{ $$map{_isa} }
			|| return warn "$$map{_isa}: no such keymap\n\n";
		goto DO_KEY;
	}
	elsif (exists $$map{_default}) { $sub = $$map{_default} }
	else { $sub = 'bell' }

	#print STDERR "# key: $key sub: $sub\n";
	my $re = ref($sub) ? $sub->($self, $key, @_) : $self->$sub($key, @_) ;
	$$self{last_key} = $key;
	return $re;
}

sub print {
	# The idea is to let the terminal render the line wrap
	# but calculate what it will do in order to get the cursor position right.
	my ($self, $lines, $pos) = @_;
#	use Data::Dumper;
#	print STDERR Dumper $lines, $pos;
	if ($$self{_SIGWINCH}) { # GetTerminalSize is kind of heavy
		$$self{term_size} = [ (GetTerminalSize($$self{IN}))[0,1] ];
		@ENV{'COLUMNS', 'LINES'} = @{$$self{term_size}} if $$self{config}{autoenv};
		$$self{_SIGWINCH} = 0;
	}

	my ($width, $higth) = @{$$self{term_size}};

	# calculate how line wrap will work out
	my @nlines = map { int(print_length($_) / $width) } @$lines;
	$$pos[1] += $nlines[$_] for 0 .. $$pos[1] - 1;
	$$pos[1] += int($$pos[0] / $width);
	$$pos[0] %= $width;
#	print STDERR Dumper \@nlines, $pos;

	# get the lines at the right position
	my $buffer = -1; # always 1 lines minimum
	$buffer += 1 + $_ for @nlines;
	my $null = 1;
	if ($buffer > $higth) { # big buffer or small screen :$
		# FIXME does not yet reckon with line wrap
		# FIXME some +1 or -1 offsets not right
		my $offset = $$pos[1] - $$self{scroll_pos};
		if ($offset < 0) { $$self{scroll_pos} = $$pos[1] }
		elsif ($offset > $higth) { $$self{scroll_pos} += $offset - $higth }
		@$lines = splice @$lines, $$self{scroll_pos}, $higth;
		$$pos[1] -= $$self{scroll_pos};
		$$self{_buffer_end} = [$width, $higth];
		$$self{_buffer} = $higth;
	}
	else { # normal readline buffer
		if ($buffer > $$self{_buffer}) { # clear screen area
			$self->cursor_at(@{$$self{term_size}});
			print { $$self{OUT} } "\n" x ($buffer - $$self{_buffer});
			$$self{_buffer} = $buffer;
		}
		$null = $$self{term_size}[1] - $$self{_buffer};
		$$self{_buffer_end} = [print_length($$lines[-1]), $null + $buffer]; # save real cursor
	}
	$self->cursor_at(1, $null);
	print { $$self{OUT} } $$lines[$_], "\e[K\n" for 0 .. $#$lines - 1;
	print { $$self{OUT} } $$lines[-1], "\e[J";

	$self->cursor_at($$pos[0]+1, $$pos[1]+$null); # set cursor
}

# ######### #
# utilities #
# ######### #

sub TermSize { (GetTerminalSize($_[0]{IN}))[0,1] }

sub key_name {
	if (exists $chr_names{$_[1]}) { return $chr_names{$_[1]} }
	elsif (length $_[1] < 2) {
		my $ord = ord $_[1];
		return	  ($ord < 32)   ? 'ctrl_'  . (chr $ord + 64)
			: ($ord == 127) ? 'ctrl_?' : $_[1] ;
	}
	else { return $_[1] }
}

sub key_binding {
	my ($self, $key, $mode) = @_;
	$mode ||= $$self{mode};

	my $map = $$self{keymaps}{$mode};
	FIND_KEY:
	if (exists $$map{$key}) { return $$map{$key} }
	elsif (exists $$map{_isa}) {
		$map = $$self{keymaps}{ $$map{_isa} }
			|| return warn "$$map{_isa}: no such keymap\n\n";
		goto FIND_KEY;
	}
	else { return undef }
}

sub press {
	my $self = shift;
	push @_key_buffer, (@_>1) ? (@_) : (split '', $_[0]);
	while (scalar @_key_buffer) { $self->do_key() }
}

sub unread_key {
	my $self = shift;
	unshift @_key_buffer, (@_>1) ? (@_) : (split '', $_[0]);
}

sub pos2off {
	my ($self, $pos) = @_;
	$pos ||= $$self{pos};
	my $off = $$pos[0];
	$off += 1 + length $$self{lines}[$_] for 0 .. $$pos[1] - 1;
	return $off;
}

sub output {
	my ($self, @items) = @_;

	$self->cursor_at(@{$$self{_buffer_end}});
	print { $$self{OUT} } "\n";

	my ($max, $cnt) = ($$self{config}{maxcomplete}, scalar @items);
	$self->_ask($cnt) or return if $max and $max =~ /^\d+$/ and $cnt > $max;

	@items = ($cnt > 1) ? ($self->col_format(@items)) : (split /\n/, $items[0]);

	$$self{_buffer} = (@items < $$self{_buffer}) ? ($$self{_buffer} - @items) : 0;
	if (@items > $$self{term_size}[1]) {
		$self->_ask($cnt) or return if $max and $max eq 'pager';
		my $pager = $ENV{PAGER} || 'more';
		eval {
			local $SIG{PIPE} = 'IGNORE';
			open PAGER, "| $pager" || die;
			print PAGER join("\n", @items), "\n";
			close PAGER;
		} ;
	}
	else { print { $$self{OUT} } join("\n", @items), "\n" }
}

sub _ask {
	my ($self, $cnt) = @_;
	print { $$self{OUT} } "Display all $cnt possibilities? [yN]";
	my $answ = $self->read_key();
	print { $$self{OUT} } "\n";
	return( ($answ =~ /y/i) ? 1 : 0 );
}

sub col_format { # takes minimum number of rows, but fills cols first
	my ($self, @items) = @_;

	my $len = 0;
	$_ > $len and $len = $_ for map {length $_} @items;
	$len += 2; # spacing
	my ($width) = $self->TermSize();
	return @items if $width < (2 * $len); # rows == items
	return join '  ', @items if $width > (@items * $len); # 1 row

	my $cols = int($width / $len ) - 1; # 0 based
	my $rows = int(@items / ($cols+1)); # 0 based ceil
	$rows -= 1 unless @items % ($cols+1); # tune ceil
	my @rows;
	for my $r (0 .. $rows) {
		my @row = map { $items[ ($_ * ($rows+1)) + $r] } 0 .. $cols;
		push @rows, join '', map { $_ .= ' 'x($len - length $_) } @row;
	}
	#print STDERR scalar(@items)." items, $len long, $width width, $cols+1 cols, $rows+1 rows\n";
	return @rows;
}

# ################# #
# Key binding stuff #
# ################# #

sub bindchr {
	my ($self, $chr, $key) = @_;
	if ($chr =~ /^\^(.)$/) { $chr = eval qq/"\\c$1"/ }
	$chr_names{$chr} = $key;
	chop $chr;
	while (length $chr) {
		$chr_map{$chr} = '';
		chop $chr;
	}
}

sub recalc_chr_map {
	my $self = shift;
	%chr_map = ();
	while (my ($k,$v) = each %chr_names) {
		$self->bindchr($k, $v);
	}
}

# ########## #
# ANSI stuff #
# ########## #

sub cursor_at { print { $_[0]{OUT} } "\e[$_[2];$_[1]H" } # ($x, $y) 1-based !

sub new_line {
	my $self = shift;
	return unless -t $$self{OUT} and -t $$self{IN};

	ReadMode 'raw';
	my $r;
	print { $$self{OUT} } "\e[6n";
	$r = ReadKey( -1, $$self{IN}) || return print { $$self{OUT} } "\n";
	while ($r =~ /^(\e|\e\[\d*|\e\[\d+;\d*)$/) { $r .= ReadKey -1, $$self{IN} }
	# in this case timed read doesn't work :(
	ReadMode 'normal';

	if ($r =~ /^\e\[\d+;(\d+)\D$/) {
		print { $$self{OUT} } "\n" if $1 > 1;
	}
	else {
		$self->unread_key($r);
		print { $$self{OUT} } "\n";
	}
}

sub clear_screen { print { $_[0]{OUT} } "\e[2J" }

sub print_length {
	my $string = pop;
	$string =~ s{\e\[[\d;]*\w}{}g; # strip ansi codes
	return length $string;
}

## Sequences from the "How to change the title of an xterm" howto
##
sub title {
	my ($self, $title) = @_;
	return unless $ENV{TERM};
	my $string =
		($ENV{TERM} =~ /^((ai)?xterm.*|dtterm|screen)$/) ? "\e]0;$title\cG" :
		($ENV{TERM} eq 'iris-ansi') ? "\eP1.y$title\e\\" :
		($ENV{TERM} eq 'sun-cmd')   ? "\e]l$title\e\\"   : undef ;
	print { $$self{OUT} } $string if $string;
}

1;

__END__