This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.0 alpha 5
[perl5.git] / lib / termcap.pl
CommitLineData
79072805 1;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
a687059c
LW
2;#
3;# Usage:
e929a76b 4;# require 'ioctl.pl';
a687059c
LW
5;# ioctl(TTY,$TIOCGETP,$foo);
6;# ($ispeed,$ospeed) = unpack('cc',$foo);
e929a76b 7;# require 'termcap.pl';
9f68db38
LW
8;# &Tgetent('vt100'); # sets $TC{'cm'}, etc.
9;# &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
10;# &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
a687059c
LW
11;#
12sub Tgetent {
13 local($TERM) = @_;
14 local($TERMCAP,$_,$entry,$loop,$field);
15
16 warn "Tgetent: no ospeed set" unless $ospeed;
17 foreach $key (keys(TC)) {
18 delete $TC{$key};
19 }
20 $TERM = $ENV{'TERM'} unless $TERM;
21 $TERMCAP = $ENV{'TERMCAP'};
22 $TERMCAP = '/etc/termcap' unless $TERMCAP;
23 if ($TERMCAP !~ m:^/:) {
7c0587c8 24 if ($TERMCAP !~ /(^|\|)$TERM[:\|]/) {
a687059c
LW
25 $TERMCAP = '/etc/termcap';
26 }
27 }
28 if ($TERMCAP =~ m:^/:) {
29 $entry = '';
30 do {
31 $loop = "
32 open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
33 while (<TERMCAP>) {
34 next if /^#/;
35 next if /^\t/;
ed6116ce 36 if (/(^|\\|)$TERM\[:\\|]/) {
a687059c
LW
37 chop;
38 while (chop eq '\\\\') {
39 \$_ .= <TERMCAP>;
40 chop;
41 }
42 \$_ .= ':';
43 last;
44 }
45 }
46 close TERMCAP;
47 \$entry .= \$_;
48 ";
49 eval $loop;
9f68db38 50 } while s/:tc=([^:]+):/:/ && ($TERM = $1);
a687059c
LW
51 $TERMCAP = $entry;
52 }
53
54 foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
55 if ($field =~ /^\w\w$/) {
56 $TC{$field} = 1;
57 }
58 elsif ($field =~ /^(\w\w)#(.*)/) {
59 $TC{$1} = $2 if $TC{$1} eq '';
60 }
61 elsif ($field =~ /^(\w\w)=(.*)/) {
62 $entry = $1;
63 $_ = $2;
64 s/\\E/\033/g;
65 s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
66 s/\\n/\n/g;
67 s/\\r/\r/g;
68 s/\\t/\t/g;
69 s/\\b/\b/g;
70 s/\\f/\f/g;
71 s/\\\^/\377/g;
72 s/\^\?/\177/g;
63f2c1e1 73 s/\^(.)/pack('c',ord($1) & 31)/eg;
a687059c
LW
74 s/\\(.)/$1/g;
75 s/\377/^/g;
76 $TC{$entry} = $_ if $TC{$entry} eq '';
77 }
78 }
79 $TC{'pc'} = "\0" if $TC{'pc'} eq '';
80 $TC{'bc'} = "\b" if $TC{'bc'} eq '';
81}
82
83@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);
84
85sub Tputs {
86 local($string,$affcnt,$FH) = @_;
87 local($ms);
88 if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
89 $ms = $1;
90 $ms *= $affcnt if $2;
91 $string = $3;
92 $decr = $Tputs[$ospeed];
93 if ($decr > .1) {
94 $ms += $decr / 2;
95 $string .= $TC{'pc'} x ($ms / $decr);
96 }
97 }
98 print $FH $string if $FH;
99 $string;
100}
101
102sub Tgoto {
103 local($string) = shift(@_);
104 local($result) = '';
105 local($after) = '';
106 local($code,$tmp) = @_;
9f68db38
LW
107 local(@tmp);
108 @tmp = ($tmp,$code);
a687059c
LW
109 local($online) = 0;
110 while ($string =~ /^([^%]*)%(.)(.*)/) {
111 $result .= $1;
112 $code = $2;
113 $string = $3;
114 if ($code eq 'd') {
9f68db38 115 $result .= sprintf("%d",shift(@tmp));
a687059c
LW
116 }
117 elsif ($code eq '.') {
9f68db38 118 $tmp = shift(@tmp);
a687059c
LW
119 if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
120 if ($online) {
121 ++$tmp, $after .= $TC{'up'} if $TC{'up'};
122 }
123 else {
124 ++$tmp, $after .= $TC{'bc'};
125 }
126 }
127 $result .= sprintf("%c",$tmp);
128 $online = !$online;
129 }
130 elsif ($code eq '+') {
9f68db38 131 $result .= sprintf("%c",shift(@tmp)+ord($string));
a687059c
LW
132 $string = substr($string,1,99);
133 $online = !$online;
134 }
135 elsif ($code eq 'r') {
9f68db38
LW
136 ($code,$tmp) = @tmp;
137 @tmp = ($tmp,$code);
a687059c
LW
138 $online = !$online;
139 }
140 elsif ($code eq '>') {
141 ($code,$tmp,$string) = unpack("CCa99",$string);
9f68db38
LW
142 if ($tmp[$[] > $code) {
143 $tmp[$[] += $tmp;
a687059c
LW
144 }
145 }
146 elsif ($code eq '2') {
9f68db38 147 $result .= sprintf("%02d",shift(@tmp));
a687059c
LW
148 $online = !$online;
149 }
150 elsif ($code eq '3') {
9f68db38 151 $result .= sprintf("%03d",shift(@tmp));
a687059c
LW
152 $online = !$online;
153 }
154 elsif ($code eq 'i') {
9f68db38
LW
155 ($code,$tmp) = @tmp;
156 @tmp = ($code+1,$tmp+1);
a687059c
LW
157 }
158 else {
159 return "OOPS";
160 }
161 }
162 $result . $string . $after;
163}
164
1651;