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