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