[p5sagit/p5-mst-13.2.git] / lib / Term / Cap.pm

# Term::Cap.pm -- Termcap interface routines
package Term::Cap;

# Converted to package on 25 Feb 1994 <sanders@bsdi.com>
#
# Usage:
#	require 'ioctl.pl';
#	ioctl(TTY,$TIOCGETP,$sgtty);
#	($ispeed,$ospeed) = unpack('cc',$sgtty);
#
#	require Term::Cap;
#
#	$term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
#		sets $term->{'_cm'}, etc.
#	$this->Trequire(qw/ce ku kd/);
#		die unless entries are defined for the terminal
#	$term->Tgoto('cm', $col, $row, $FH);
#	$term->Tputs('dl', $cnt = 1, $FH);
#	$this->Tpad($string, $cnt = 1, $FH);
#		processes a termcap string and adds padding if needed
#		if $FH is undefined these just return the string
#
# CHANGES:
#	Converted to package
#	Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
#	Now die's properly if it can't open $TERMCAP or if the eval $loop fails
#	Tputs() results are cached (use Tgoto or Tpad to avoid)
#	Tgoto() will do output if $FH is passed (like Tputs without caching)
#	Supports POSIX termios speeds and old style speeds
#	Searches termcaps properly (TERMPATH, etc)
#	The output routines are optimized for cached Tputs().
#	$this->{_xx} is the raw termcap data and $this->{xx} is a
#	    cached and padded string for count == 1.
#

# internal routines
sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
sub termcap_path {
    local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
    local $v;
    if ($v = getenv(TERMPATH)) {
	# user specified path
	@termcap_path = split(':', $v);
    } else {
	# default path
	@termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
	$v = getenv(HOME);
	unshift(@termcap_path, $v . '/.termcap') if $v;
    }
    # we always search TERMCAP first
    $v = getenv(TERMCAP);
    unshift(@termcap_path, $v) if $v =~ /^\//;
    grep(-f, @termcap_path);
}

sub Tgetent {
    local($type) = shift;
    local($this) = @_;
    local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);

    warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
    $this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
    $term = $TERM = $this->{TERM} =
	$this->{TERM} || getenv(TERM) || die "Tgetent: TERM not set\n";

    $TERMCAP = getenv(TERMCAP);
    $TERMCAP = '' if $TERMCAP =~ m:^/: || $TERMCAP !~ /(^|\|)$TERM[:\|]/;
    local @termcap_path = &termcap_path;
    die "Tgetent: Can't find a valid termcap file\n"
	unless @termcap_path || $TERMCAP;

    # handle environment TERMCAP, setup for continuation if needed
    $entry = $TERMCAP;
    $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
    if ($TERMCAP eq '' || $1) {				# the search goes on
	local $first = $TERMCAP eq '' ? 1 : 0;		# make it pretty
	local $max = 32;				# max :tc=...:'s
	local $state = 1;				# 0 == finished
							# 1 == next file
							# 2 == search again
	do {
	    if ($state == 1) {
		$TERMCAP = shift @termcap_path
		    || die "Tgetent: failed lookup on $TERM\n";
	    } else {
		$max-- || die "Tgetent: termcap loop at $TERM\n";
		$state = 1;				# back to default state
	    }

	    open(TERMCAP,"< $TERMCAP\0") || die "Tgetent: $TERMCAP: $!\n";
	    # print STDERR "Trying... $TERMCAP\n";
	    $loop = "
		while (<TERMCAP>) {
		    next if /^\t/;
		    next if /^#/;
		    if (/(^|\\|)${TERM}[:\\|]/) {
			chop;
			s/^[^:]*:// unless \$first++;
			\$state = 0;
			while (chop eq '\\\\') {
			    \$_ .= <TERMCAP>;
			    chop;
			}
			\$_ .= ':';
			last;
		    }
		}
		\$entry .= \$_;
	    ";
	    eval $loop;
	    die $@ if $@;
	    #print STDERR "$TERM: $_\n--------\n";	# DEBUG
	    close TERMCAP;
	    # If :tc=...: found then search this file again
	    $entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
	} while $state != 0;
    }
    die "Tgetent: Can't find $term\n" unless $entry ne '';
    $entry =~ s/:\s+:/:/g;
    $this->{TERMCAP} = $entry;
    #print STDERR $entry, "\n";				# DEBUG

    # Precompile $entry into the object
    foreach $field (split(/:[\s:\\]*/,$entry)) {
	if ($field =~ /^\w\w$/) {
	    $this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
	}
	elsif ($field =~ /^(\w\w)\@/) {
	    $this->{'_' . $1} = "";
	}
	elsif ($field =~ /^(\w\w)#(.*)/) {
	    $this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
	}
	elsif ($field =~ /^(\w\w)=(.*)/) {
	    next if defined $this->{'_' . ($cap = $1)};
	    $_ = $2;
	    s/\\E/\033/g;
	    s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
	    s/\\n/\n/g;
	    s/\\r/\r/g;
	    s/\\t/\t/g;
	    s/\\b/\b/g;
	    s/\\f/\f/g;
	    s/\\\^/\377/g;
	    s/\^\?/\177/g;
	    s/\^(.)/pack('c',ord($1) & 31)/eg;
	    s/\\(.)/$1/g;
	    s/\377/^/g;
	    $this->{'_' . $cap} = $_;
	}
	# else { warn "Tgetent: junk in $term: $field\n"; }
    }
    $this->{'_pc'} = "\0" unless defined $this->{'_pc'};
    $this->{'_bc'} = "\b" unless defined $this->{'_bc'};
    $this;
}

# delays for old style speeds
@Tpad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);

# $term->Tpad($string, $cnt, $FH);
sub Tpad {
    local($this, $string, $cnt, $FH) = @_;
    local($decr, $ms);

    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
	$ms = $1;
	$ms *= $cnt if $2;
	$string = $3;
	$decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
	if ($decr > .1) {
	    $ms += $decr / 2;
	    $string .= $this->{'_pc'} x ($ms / $decr);
	}
    }
    print $FH $string if $FH;
    $string;
}

# $term->Tputs($cap, $cnt, $FH);
sub Tputs {
    local($this, $cap, $cnt, $FH) = @_;
    local $string;

    if ($cnt > 1) {
	$string = Tpad($this, $this->{'_' . $cap}, $cnt);
    } else {
	$string = defined $this->{$cap} ? $this->{$cap} :
	    ($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
    }
    print $FH $string if $FH;
    $string;
}

# %%   output `%'
# %d   output value as in printf %d
# %2   output value as in printf %2d
# %3   output value as in printf %3d
# %.   output value as in printf %c
# %+x  add x to value, then do %.
#
# %>xy if value > x then add y, no output
# %r   reverse order of two parameters, no output
# %i   increment by one, no output
# %B   BCD (16*(value/10)) + (value%10), no output
#
# %n   exclusive-or all parameters with 0140 (Datamedia 2500)
# %D   Reverse coding (value - 2*(value%16)), no output (Delta Data)
#
# $term->Tgoto($cap, $col, $row, $FH);
sub Tgoto {
    local($this, $cap, $code, $tmp, $FH) = @_;
    local $string = $this->{'_' . $cap};
    local $result = '';
    local $after = '';
    local $online = 0;
    local @tmp = ($tmp,$code);
    local $cnt = $code;

    while ($string =~ /^([^%]*)%(.)(.*)/) {
	$result .= $1;
	$code = $2;
	$string = $3;
	if ($code eq 'd') {
	    $result .= sprintf("%d",shift(@tmp));
	}
	elsif ($code eq '.') {
	    $tmp = shift(@tmp);
	    if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
		if ($online) {
		    ++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
		}
		else {
		    ++$tmp, $after .= $this->{'_bc'};
		}
	    }
	    $result .= sprintf("%c",$tmp);
	    $online = !$online;
	}
	elsif ($code eq '+') {
	    $result .= sprintf("%c",shift(@tmp)+ord($string));
	    $string = substr($string,1,99);
	    $online = !$online;
	}
	elsif ($code eq 'r') {
	    ($code,$tmp) = @tmp;
	    @tmp = ($tmp,$code);
	    $online = !$online;
	}
	elsif ($code eq '>') {
	    ($code,$tmp,$string) = unpack("CCa99",$string);
	    if ($tmp[$[] > $code) {
		$tmp[$[] += $tmp;
	    }
	}
	elsif ($code eq '2') {
	    $result .= sprintf("%02d",shift(@tmp));
	    $online = !$online;
	}
	elsif ($code eq '3') {
	    $result .= sprintf("%03d",shift(@tmp));
	    $online = !$online;
	}
	elsif ($code eq 'i') {
	    ($code,$tmp) = @tmp;
	    @tmp = ($code+1,$tmp+1);
	}
	else {
	    return "OOPS";
	}
    }
    $string = Tpad($this, $result . $string . $after, $cnt);
    print $FH $string if $FH;
    $string;
}

# $this->Trequire($cap1, $cap2, ...);
sub Trequire {
    local $this = shift;
    local $_;
    foreach (@_) {
	die "Trequire: Terminal does not support: $_\n"
	    unless defined $this->{'_' . $_} && $this->{'_' . $_};
    }
}

1;
Commit	Line	Data
748a9306	1	# Term::Cap.pm -- Termcap interface routines
a0d0e21e	2	package Term::Cap;
85e6fe83	3
748a9306	4	# Converted to package on 25 Feb 1994 <sanders@bsdi.com>
a0d0e21e	5	#
	6	# Usage:
	7	# require 'ioctl.pl';
748a9306	8	# ioctl(TTY,$TIOCGETP,$sgtty);
	9	# ($ispeed,$ospeed) = unpack('cc',$sgtty);
	10	#
	11	# require Term::Cap;
	12	#
	13	# $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
	14	# sets $term->{'_cm'}, etc.
	15	# $this->Trequire(qw/ce ku kd/);
	16	# die unless entries are defined for the terminal
	17	# $term->Tgoto('cm', $col, $row, $FH);
	18	# $term->Tputs('dl', $cnt = 1, $FH);
	19	# $this->Tpad($string, $cnt = 1, $FH);
	20	# processes a termcap string and adds padding if needed
	21	# if $FH is undefined these just return the string
	22	#
	23	# CHANGES:
	24	# Converted to package
	25	# Allows :tc=...: in $ENV{'TERMCAP'} (flows to default termcap file)
	26	# Now die's properly if it can't open $TERMCAP or if the eval $loop fails
	27	# Tputs() results are cached (use Tgoto or Tpad to avoid)
	28	# Tgoto() will do output if $FH is passed (like Tputs without caching)
	29	# Supports POSIX termios speeds and old style speeds
	30	# Searches termcaps properly (TERMPATH, etc)
	31	# The output routines are optimized for cached Tputs().
	32	# $this->{_xx} is the raw termcap data and $this->{xx} is a
	33	# cached and padded string for count == 1.
a0d0e21e	34	#
a687059c	35
748a9306	36	# internal routines
	37	sub getenv { defined $ENV{$_[0]} ? $ENV{$_[0]} : ''; }
	38	sub termcap_path {
	39	local @termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
	40	local $v;
	41	if ($v = getenv(TERMPATH)) {
	42	# user specified path
	43	@termcap_path = split(':', $v);
	44	} else {
	45	# default path
	46	@termcap_path = ('/etc/termcap', '/usr/share/misc/termcap');
	47	$v = getenv(HOME);
	48	unshift(@termcap_path, $v . '/.termcap') if $v;
a687059c	49	}
748a9306	50	# we always search TERMCAP first
	51	$v = getenv(TERMCAP);
	52	unshift(@termcap_path, $v) if $v =~ /^\//;
	53	grep(-f, @termcap_path);
	54	}
	55
	56	sub Tgetent {
	57	local($type) = shift;
	58	local($this) = @_;
	59	local($TERM,$TERMCAP,$term,$entry,$cap,$loop,$field,$entry,$_);
	60
	61	warn "Tgetent: no ospeed set\n" unless $this->{OSPEED} > 0;
	62	$this->{DECR} = 10000 / $this->{OSPEED} if $this->{OSPEED} > 50;
	63	$term = $TERM = $this->{TERM} =
	64	$this->{TERM} \|\| getenv(TERM) \|\| die "Tgetent: TERM not set\n";
	65
	66	$TERMCAP = getenv(TERMCAP);
	67	$TERMCAP = '' if $TERMCAP =~ m:^/: \|\| $TERMCAP !~ /(^\|\\|)$TERM[:\\|]/;
	68	local @termcap_path = &termcap_path;
	69	die "Tgetent: Can't find a valid termcap file\n"
	70	unless @termcap_path \|\| $TERMCAP;
	71
	72	# handle environment TERMCAP, setup for continuation if needed
	73	$entry = $TERMCAP;
	74	$entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1);
	75	if ($TERMCAP eq '' \|\| $1) { # the search goes on
	76	local $first = $TERMCAP eq '' ? 1 : 0; # make it pretty
	77	local $max = 32; # max :tc=...:'s
	78	local $state = 1; # 0 == finished
	79	# 1 == next file
	80	# 2 == search again
a687059c	81	do {
748a9306	82	if ($state == 1) {
	83	$TERMCAP = shift @termcap_path
	84	\|\| die "Tgetent: failed lookup on $TERM\n";
	85	} else {
	86	$max-- \|\| die "Tgetent: termcap loop at $TERM\n";
	87	$state = 1; # back to default state
	88	}
	89
	90	open(TERMCAP,"< $TERMCAP\0") \|\| die "Tgetent: $TERMCAP: $!\n";
	91	# print STDERR "Trying... $TERMCAP\n";
a687059c	92	$loop = "
748a9306	93	while (<TERMCAP>) {
	94	next if /^\t/;
	95	next if /^#/;
	96	if (/(^\|\\\|)${TERM}[:\\\|]/) {
a687059c	97	chop;
748a9306	98	s/^[^:]*:// unless \$first++;
	99	\$state = 0;
	100	while (chop eq '\\\\') {
	101	\$_ .= <TERMCAP>;
	102	chop;
	103	}
	104	\$_ .= ':';
	105	last;
a687059c	106	}
a687059c	107	}
748a9306	108	\$entry .= \$_;
a687059c	109	";
a687059c	110	eval $loop;
748a9306	111	die $@ if $@;
	112	#print STDERR "$TERM: $_\n--------\n"; # DEBUG
	113	close TERMCAP;
	114	# If :tc=...: found then search this file again
	115	$entry =~ s/:tc=([^:]+):/:/ && ($TERM = $1, $state = 2);
	116	} while $state != 0;
a687059c	117	}
748a9306	118	die "Tgetent: Can't find $term\n" unless $entry ne '';
	119	$entry =~ s/:\s+:/:/g;
	120	$this->{TERMCAP} = $entry;
	121	#print STDERR $entry, "\n"; # DEBUG
a687059c	122
748a9306	123	# Precompile $entry into the object
748a9306	124	foreach $field (split(/:[\s:\\]*/,$entry)) {
a687059c	125	if ($field =~ /^\w\w$/) {
748a9306	126	$this->{'_' . $field} = 1 unless defined $this->{'_' . $1};
	127	}
	128	elsif ($field =~ /^(\w\w)\@/) {
	129	$this->{'_' . $1} = "";
a687059c	130	}
a687059c	131	elsif ($field =~ /^(\w\w)#(.*)/) {
748a9306	132	$this->{'_' . $1} = $2 unless defined $this->{'_' . $1};
a687059c	133	}
a687059c	134	elsif ($field =~ /^(\w\w)=(.*)/) {
748a9306	135	next if defined $this->{'_' . ($cap = $1)};
a687059c	136	$_ = $2;
a687059c	137	s/\\E/\033/g;
ecfc5424	138	s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg;
a687059c	139	s/\\n/\n/g;
	140	s/\\r/\r/g;
	141	s/\\t/\t/g;
	142	s/\\b/\b/g;
	143	s/\\f/\f/g;
	144	s/\\\^/\377/g;
	145	s/\^\?/\177/g;
63f2c1e1	146	s/\^(.)/pack('c',ord($1) & 31)/eg;
a687059c	147	s/\\(.)/$1/g;
a687059c	148	s/\377/^/g;
748a9306	149	$this->{'_' . $cap} = $_;
a687059c	150	}
748a9306	151	# else { warn "Tgetent: junk in $term: $field\n"; }
a687059c	152	}
748a9306	153	$this->{'_pc'} = "\0" unless defined $this->{'_pc'};
	154	$this->{'_bc'} = "\b" unless defined $this->{'_bc'};
	155	$this;
a687059c	156	}
a687059c	157
748a9306	158	# delays for old style speeds
	159	@Tpad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
	160
	161	# $term->Tpad($string, $cnt, $FH);
	162	sub Tpad {
	163	local($this, $string, $cnt, $FH) = @_;
	164	local($decr, $ms);
a687059c	165
a687059c	166	if ($string =~ /(^[\d.]+)(\?)(.)$/) {
a687059c	167	$ms = $1;
748a9306	168	$ms *= $cnt if $2;
a687059c	169	$string = $3;
748a9306	170	$decr = $this->{OSPEED} < 50 ? $Tpad[$this->{OSPEED}] : $this->{DECR};
a687059c	171	if ($decr > .1) {
a687059c	172	$ms += $decr / 2;
748a9306	173	$string .= $this->{'_pc'} x ($ms / $decr);
a687059c	174	}
	175	}
	176	print $FH $string if $FH;
	177	$string;
	178	}
	179
748a9306	180	# $term->Tputs($cap, $cnt, $FH);
	181	sub Tputs {
	182	local($this, $cap, $cnt, $FH) = @_;
	183	local $string;
	184
	185	if ($cnt > 1) {
	186	$string = Tpad($this, $this->{'_' . $cap}, $cnt);
	187	} else {
	188	$string = defined $this->{$cap} ? $this->{$cap} :
	189	($this->{$cap} = Tpad($this, $this->{'_' . $cap}, 1));
	190	}
	191	print $FH $string if $FH;
	192	$string;
	193	}
	194
	195	# %% output `%'
	196	# %d output value as in printf %d
	197	# %2 output value as in printf %2d
	198	# %3 output value as in printf %3d
	199	# %. output value as in printf %c
	200	# %+x add x to value, then do %.
	201	#
	202	# %>xy if value > x then add y, no output
	203	# %r reverse order of two parameters, no output
	204	# %i increment by one, no output
	205	# %B BCD (16*(value/10)) + (value%10), no output
	206	#
	207	# %n exclusive-or all parameters with 0140 (Datamedia 2500)
	208	# %D Reverse coding (value - 2*(value%16)), no output (Delta Data)
	209	#
	210	# $term->Tgoto($cap, $col, $row, $FH);
a687059c	211	sub Tgoto {
748a9306	212	local($this, $cap, $code, $tmp, $FH) = @_;
	213	local $string = $this->{'_' . $cap};
	214	local $result = '';
	215	local $after = '';
	216	local $online = 0;
	217	local @tmp = ($tmp,$code);
	218	local $cnt = $code;
	219
a687059c	220	while ($string =~ /^([^%])%(.)(.)/) {
	221	$result .= $1;
	222	$code = $2;
	223	$string = $3;
	224	if ($code eq 'd') {
9f68db38	225	$result .= sprintf("%d",shift(@tmp));
a687059c	226	}
a687059c	227	elsif ($code eq '.') {
9f68db38	228	$tmp = shift(@tmp);
a687059c	229	if ($tmp == 0 \|\| $tmp == 4 \|\| $tmp == 10) {
a687059c	230	if ($online) {
748a9306	231	++$tmp, $after .= $this->{'_up'} if $this->{'_up'};
a687059c	232	}
a687059c	233	else {
748a9306	234	++$tmp, $after .= $this->{'_bc'};
a687059c	235	}
	236	}
	237	$result .= sprintf("%c",$tmp);
	238	$online = !$online;
	239	}
	240	elsif ($code eq '+') {
9f68db38	241	$result .= sprintf("%c",shift(@tmp)+ord($string));
a687059c	242	$string = substr($string,1,99);
	243	$online = !$online;
	244	}
	245	elsif ($code eq 'r') {
9f68db38	246	($code,$tmp) = @tmp;
9f68db38	247	@tmp = ($tmp,$code);
a687059c	248	$online = !$online;
	249	}
	250	elsif ($code eq '>') {
	251	($code,$tmp,$string) = unpack("CCa99",$string);
9f68db38	252	if ($tmp[$[] > $code) {
9f68db38	253	$tmp[$[] += $tmp;
a687059c	254	}
	255	}
	256	elsif ($code eq '2') {
9f68db38	257	$result .= sprintf("%02d",shift(@tmp));
a687059c	258	$online = !$online;
	259	}
	260	elsif ($code eq '3') {
9f68db38	261	$result .= sprintf("%03d",shift(@tmp));
a687059c	262	$online = !$online;
	263	}
	264	elsif ($code eq 'i') {
9f68db38	265	($code,$tmp) = @tmp;
9f68db38	266	@tmp = ($code+1,$tmp+1);
a687059c	267	}
	268	else {
	269	return "OOPS";
	270	}
	271	}
748a9306	272	$string = Tpad($this, $result . $string . $after, $cnt);
	273	print $FH $string if $FH;
	274	$string;
	275	}
	276
	277	# $this->Trequire($cap1, $cap2, ...);
	278	sub Trequire {
	279	local $this = shift;
	280	local $_;
	281	foreach (@_) {
	282	die "Trequire: Terminal does not support: $_\n"
	283	unless defined $this->{'_' . $_} && $this->{'_' . $_};
	284	}
a687059c	285	}
	286
	287	1;