1;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
2#
3# This library is no longer being maintained, and is included for backward
4# compatibility with Perl 4 programs which may require it.
5#
6# In particular, this should not be used as an example of modern Perl
7# programming techniques.
8#
9# Suggested alternative: Term::Cap
10#
11;#
12;# Usage:
13;#	require 'ioctl.pl';
14;#	ioctl(TTY,$TIOCGETP,$foo);
15;#	($ispeed,$ospeed) = unpack('cc',$foo);
16;#	require 'termcap.pl';
17;#	&Tgetent('vt100');	# sets $TC{'cm'}, etc.
18;#	&Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
19;#	&Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
20;#
21sub Tgetent {
22    local($TERM) = @_;
23    local($TERMCAP,$_,$entry,$loop,$field);
24
25    # warn "Tgetent: no ospeed set" unless $ospeed;
26    foreach $key (keys %TC) {
27	delete $TC{$key};
28    }
29    $TERM = $ENV{'TERM'} unless $TERM;
30    $TERM =~ s/(\W)/\\$1/g;
31    $TERMCAP = $ENV{'TERMCAP'};
32    $TERMCAP = '/etc/termcap' unless $TERMCAP;
33    if ($TERMCAP !~ m:^/:) {
34	if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
35	    $TERMCAP = '/etc/termcap';
36	}
37    }
38    if ($TERMCAP =~ m:^/:) {
39	$entry = '';
40	do {
41	    $loop = "
42	    open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
43	    while (<TERMCAP>) {
44		next if /^#/;
45		next if /^\t/;
46		if (/(^|\\|)${TERM}[:\\|]/) {
47		    chop;
48		    while (chop eq '\\\\') {
49			\$_ .= <TERMCAP>;
50			chop;
51		    }
52		    \$_ .= ':';
53		    last;
54		}
55	    }
56	    close TERMCAP;
57	    \$entry .= \$_;
58	    ";
59	    eval $loop;
60	} while s/:tc=([^:]+):/:/ && ($TERM = $1);
61	$TERMCAP = $entry;
62    }
63
64    foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
65	if ($field =~ /^\w\w$/) {
66	    $TC{$field} = 1;
67	}
68	elsif ($field =~ /^(\w\w)#(.*)/) {
69	    $TC{$1} = $2 if $TC{$1} eq '';
70	}
71	elsif ($field =~ /^(\w\w)=(.*)/) {
72	    $entry = $1;
73	    $_ = $2;
74	    s/\\E/\033/g;
75	    s/\\(200)/pack('c',0)/eg;			# NUL character
76	    s/\\(0\d\d)/pack('c',oct($1))/eg;	# octal
77	    s/\\(0x[0-9A-Fa-f][0-9A-Fa-f])/pack('c',hex($1))/eg;	# hex
78	    s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
79	    s/\\n/\n/g;
80	    s/\\r/\r/g;
81	    s/\\t/\t/g;
82	    s/\\b/\b/g;
83	    s/\\f/\f/g;
84	    s/\\\^/\377/g;
85	    s/\^\?/\177/g;
86	    s/\^(.)/pack('c',ord($1) & 31)/eg;
87	    s/\\(.)/$1/g;
88	    s/\377/^/g;
89	    $TC{$entry} = $_ if $TC{$entry} eq '';
90	}
91    }
92    $TC{'pc'} = "\0" if $TC{'pc'} eq '';
93    $TC{'bc'} = "\b" if $TC{'bc'} eq '';
94}
95
96@Tputs = (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);
97
98sub Tputs {
99    local($string,$affcnt,$FH) = @_;
100    local($ms);
101    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
102	$ms = $1;
103	$ms *= $affcnt if $2;
104	$string = $3;
105	$decr = $Tputs[$ospeed];
106	if ($decr > .1) {
107	    $ms += $decr / 2;
108	    $string .= $TC{'pc'} x ($ms / $decr);
109	}
110    }
111    print $FH $string if $FH;
112    $string;
113}
114
115sub Tgoto {
116    local($string) = shift(@_);
117    local($result) = '';
118    local($after) = '';
119    local($code,$tmp) = @_;
120    local(@tmp);
121    @tmp = ($tmp,$code);
122    local($online) = 0;
123    while ($string =~ /^([^%]*)%(.)(.*)/) {
124	$result .= $1;
125	$code = $2;
126	$string = $3;
127	if ($code eq 'd') {
128	    $result .= sprintf("%d",shift(@tmp));
129	}
130	elsif ($code eq '.') {
131	    $tmp = shift(@tmp);
132	    if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
133		if ($online) {
134		    ++$tmp, $after .= $TC{'up'} if $TC{'up'};
135		}
136		else {
137		    ++$tmp, $after .= $TC{'bc'};
138		}
139	    }
140	    $result .= sprintf("%c",$tmp);
141	    $online = !$online;
142	}
143	elsif ($code eq '+') {
144	    $result .= sprintf("%c",shift(@tmp)+ord($string));
145	    $string = substr($string,1,99);
146	    $online = !$online;
147	}
148	elsif ($code eq 'r') {
149	    ($code,$tmp) = @tmp;
150	    @tmp = ($tmp,$code);
151	    $online = !$online;
152	}
153	elsif ($code eq '>') {
154	    ($code,$tmp,$string) = unpack("CCa99",$string);
155	    if ($tmp[0] > $code) {
156		$tmp[0] += $tmp;
157	    }
158	}
159	elsif ($code eq '2') {
160	    $result .= sprintf("%02d",shift(@tmp));
161	    $online = !$online;
162	}
163	elsif ($code eq '3') {
164	    $result .= sprintf("%03d",shift(@tmp));
165	    $online = !$online;
166	}
167	elsif ($code eq 'i') {
168	    ($code,$tmp) = @tmp;
169	    @tmp = ($code+1,$tmp+1);
170	}
171	else {
172	    return "OOPS";
173	}
174    }
175    $result . $string . $after;
176}
177
1781;
179