This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Term-Cap to CPAN version 1.15
[perl5.git] / cpan / Term-Cap / test.pl
CommitLineData
1285de5c 1#!./perl
2
6eca1408 3my $file;
a7e06307 4
1285de5c 5BEGIN {
a7e06307
JS
6 $file = $0;
7 chdir 't' if -d 't';
1285de5c 8}
9
10END {
11 # let VMS whack all versions
12 1 while unlink('tcout');
13}
14
6222ea98 15use Test::More;
1285de5c 16
cdfc6b8a 17# these names are hardcoded in Term::Cap
6222ea98
MS
18my $files = join '',
19 grep { -f $_ }
20 ( $ENV{HOME} . '/.termcap', # we assume pretty UNIXy system anyway
21 '/etc/termcap',
22 '/usr/share/misc/termcap' );
63dc8a94
CBW
23my $terminfo = `infocmp -C 2>/dev/null`;
24unless( $files || $terminfo || $^O eq 'VMS' ) {
6222ea98
MS
25 plan skip_all => 'no termcap available to test';
26}
27else {
085f5cc4 28 plan tests => 45;
cdfc6b8a 29}
30
1285de5c 31use_ok( 'Term::Cap' );
32
33local (*TCOUT, *OUT);
34my $out = tie *OUT, 'TieOut';
35my $writable = 1;
36
37if (open(TCOUT, ">tcout")) {
38 print TCOUT <DATA>;
39 close TCOUT;
40} else {
41 $writable = 0;
42}
43
a7e06307 44# termcap_path -- the names are hardcoded in Term::Cap
1285de5c 45$ENV{TERMCAP} = '';
46my $path = join '', Term::Cap::termcap_path();
c6d685f7 47is( $path, $files, 'termcap_path() should find default files' );
1285de5c 48
49SKIP: {
50 # this is ugly, but -f $0 really *ought* to work
6eca1408 51 skip("-f $file fails, some tests difficult now", 2) unless -f $file;
1285de5c 52
6eca1408 53 $ENV{TERMCAP} = $ENV{TERMPATH} = $file;
54 ok( grep($file, Term::Cap::termcap_path()),
c6d685f7 55 'termcap_path() should find file from $ENV{TERMCAP}' );
1285de5c 56
26ca33de 57 $ENV{TERMCAP} = '/';
6eca1408 58 ok( grep($file, Term::Cap::termcap_path()),
c6d685f7 59 'termcap_path() should find file from $ENV{TERMPATH}' );
1285de5c 60}
61
1285de5c 62# make a Term::Cap "object"
63my $t = {
64 PADDING => 1,
65 _pc => 'pc',
66};
67bless($t, 'Term::Cap' );
68
69# see if Tpad() works
c6d685f7 70is( $t->Tpad(), undef, 'Tpad() should return undef with no arguments' );
71is( $t->Tpad('x'), 'x', 'Tpad() should return strings verbatim with no match' );
72is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() should pad paddable strings' );
1285de5c 73
74$t->{PADDING} = 2;
c6d685f7 75is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() should perform pad math' );
76is( $out->read(), 'apcpc', 'Tpad() should write to filehandle when passed' );
1285de5c 77
c6d685f7 78is( $t->Tputs('PADDING'), 2, 'Tputs() should return existing value' );
79is( $t->Tputs('pc', 2), 'pc', 'Tputs() should delegate to Tpad()' );
1285de5c 80$t->Tputs('pc', 1, *OUT);
c6d685f7 81is( $t->{pc}, 'pc', 'Tputs() should cache pc value when asked' );
82is( $out->read(), 'pc', 'Tputs() should write to filehandle when passed' );
1285de5c 83
84eval { $t->Trequire( 'pc' ) };
c6d685f7 85is( $@, '', 'Trequire() should finds existing cap' );
1285de5c 86eval { $t->Trequire( 'nonsense' ) };
c6d685f7 87like( $@, qr/support: \(nonsense\)/,
88 'Trequire() should croak with unsupported cap' );
1285de5c 89
90my $warn;
91local $SIG{__WARN__} = sub {
92 $warn = $_[0];
93};
94
95# test the first few features by forcing Tgetent() to croak (line 156)
96undef $ENV{TERM};
97my $vals = {};
d2492938 98eval { local $^W = 1; $t = Term::Cap->Tgetent($vals) };
c6d685f7 99like( $@, qr/TERM not set/, 'Tgetent() should croaks without TERM' );
100like( $warn, qr/OSPEED was not set/, 'Tgetent() should set default OSPEED' );
d2492938 101
1285de5c 102is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' );
103
d2492938
JS
104$warn = 'xxxx';
105eval { local $^W = 0; $t = Term::Cap->Tgetent($vals) };
106is($warn,'xxxx',"Tgetent() doesn't carp() without warnings on");
107
1285de5c 108# check values for very slow speeds
109$vals->{OSPEED} = 1;
110$warn = '';
111eval { $t = Term::Cap->Tgetent($vals) };
c6d685f7 112is( $warn, '', 'Tgetent() should not work if OSPEED is provided' );
113is( $vals->{PADDING}, 200, 'Tgetent() should set slow PADDING when needed' );
1285de5c 114
d2492938
JS
115
116SKIP: {
117 skip('Tgetent() bad termcap test, since using a fixed termcap',1)
118 if $^O eq 'VMS';
119 # now see if lines 177 or 180 will fail
120 $ENV{TERM} = 'foo';
121 $ENV{TERMPATH} = '!';
122 $ENV{TERMCAP} = '';
123 eval { $t = Term::Cap->Tgetent($vals) };
124 isn't( $@, '', 'Tgetent() should catch bad termcap file' );
125}
1285de5c 126
1285de5c 127SKIP: {
6eca1408 128 skip( "Can't write 'tcout' file for tests", 9 ) unless $writable;
129
130 # it won't find the termtype in this fake file, so it should croak
131 $vals->{TERM} = 'quux';
132 $ENV{TERMPATH} = 'tcout';
133 eval { $t = Term::Cap->Tgetent($vals) };
134 like( $@, qr/failed termcap/, 'Tgetent() should die with bad termcap' );
1285de5c 135
136 # it shouldn't try to read one file more than 32(!) times
137 # see __END__ for a really awful termcap example
1285de5c 138 $ENV{TERMPATH} = join(' ', ('tcout') x 33);
139 $vals->{TERM} = 'bar';
140 eval { $t = Term::Cap->Tgetent($vals) };
c6d685f7 141 like( $@, qr/failed termcap loop/, 'Tgetent() should catch deep recursion');
1285de5c 142
143 # now let it read a fake termcap file, and see if it sets properties
144 $ENV{TERMPATH} = 'tcout';
145 $vals->{TERM} = 'baz';
146 $t = Term::Cap->Tgetent($vals);
c6d685f7 147 is( $t->{_f1}, 1, 'Tgetent() should set a single field correctly' );
148 is( $t->{_f2}, 1, 'Tgetent() should set another field on the same line' );
149 is( $t->{_no}, '', 'Tgetent() should set a blank field correctly' );
150 is( $t->{_k1}, 'v1', 'Tgetent() should set a key value pair correctly' );
151 like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() should set and translate pairs' );
1285de5c 152
153 # and it should have set these two fields
c6d685f7 154 is( $t->{_pc}, "\0", 'should set _pc field correctly' );
155 is( $t->{_bc}, "\b", 'should set _bc field correctly' );
1285de5c 156}
157
085f5cc4 158# Windows hack
76ea3a66 159SKIP:
085f5cc4 160{
76ea3a66
JS
161 skip("QNX's termcap database does not contain an entry for dumb terminals",
162 1) if $^O eq 'nto';
163
085f5cc4
RGS
164 local *^O;
165 local *ENV;
166 delete $ENV{TERM};
63dc8a94 167 $^O = 'MSWin32';
085f5cc4
RGS
168
169 my $foo = Term::Cap->Tgetent();
170 is($foo->{TERM} ,'dumb','Windows gets "dumb" by default');
171}
172
1285de5c 173# Tgoto has comments on the expected formats
174$t->{_test} = "a%d";
c6d685f7 175is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' );
176is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' );
1285de5c 177
178$t->{_test} = "a%.";
c6d685f7 179like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' );
5b48932f 180if (ord('A') == 193) { # EBCDIC platform
085f5cc4
RGS
181 like( $t->Tgoto('test', '', 0), qr/\x81\x01\x16/,
182 'Tgoto() should handle %. and magic' );
183 } else { # ASCII platform
184 like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/,
185 'Tgoto() should handle %. and magic' );
186 }
1285de5c 187
188$t->{_test} = 'a%+';
d2492938 189like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() should handle %+' );
1285de5c 190$t->{_test} = 'a%+a';
c6d685f7 191is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' );
1285de5c 192$t->{_test} .= 'a' x 99;
c6d685f7 193like( $t->Tgoto('test', '', 1), qr/ba{98}/,
194 'Tgoto() should substr()s %+ if needed' );
1285de5c 195
196$t->{_test} = '%ra%d';
c6d685f7 197is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' );
1285de5c 198
199$t->{_test} = 'a%>11bc';
c6d685f7 200is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' );
1285de5c 201
202$t->{_test} = 'a%21';
c6d685f7 203is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' );
1285de5c 204
205$t->{_test} = 'a%31';
c6d685f7 206is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' );
1285de5c 207
208$t->{_test} = '%ia%21';
c6d685f7 209is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' );
1285de5c 210
211$t->{_test} = '%z';
c6d685f7 212is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' );
1285de5c 213
214# and this is pretty standard
215package TieOut;
216
217sub TIEHANDLE {
218 bless( \(my $self), $_[0] );
219}
220
221sub PRINT {
222 my $self = shift;
223 $$self .= join('', @_);
224}
225
226sub read {
227 my $self = shift;
228 substr( $$self, 0, length($$self), '' );
229}
230
231__END__
232bar: :tc=bar: \
233baz: \
234:f1: :f2: \
235:no@ \
236:k1#v1\
237:k2=v2\\n2