Commit | Line | Data |
---|---|---|
1285de5c | 1 | #!./perl |
2 | ||
6eca1408 | 3 | my $file; |
a7e06307 | 4 | |
1285de5c | 5 | BEGIN { |
a7e06307 JS |
6 | $file = $0; |
7 | chdir 't' if -d 't'; | |
1285de5c | 8 | } |
9 | ||
10 | END { | |
11 | # let VMS whack all versions | |
12 | 1 while unlink('tcout'); | |
13 | } | |
14 | ||
6222ea98 | 15 | use Test::More; |
1285de5c | 16 | |
cdfc6b8a | 17 | # these names are hardcoded in Term::Cap |
6222ea98 MS |
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' ); | |
63dc8a94 CBW |
23 | my $terminfo = `infocmp -C 2>/dev/null`; |
24 | unless( $files || $terminfo || $^O eq 'VMS' ) { | |
6222ea98 MS |
25 | plan skip_all => 'no termcap available to test'; |
26 | } | |
27 | else { | |
085f5cc4 | 28 | plan tests => 45; |
cdfc6b8a | 29 | } |
30 | ||
1285de5c | 31 | use_ok( 'Term::Cap' ); |
32 | ||
33 | local (*TCOUT, *OUT); | |
34 | my $out = tie *OUT, 'TieOut'; | |
35 | my $writable = 1; | |
36 | ||
37 | if (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} = ''; |
46 | my $path = join '', Term::Cap::termcap_path(); | |
c6d685f7 | 47 | is( $path, $files, 'termcap_path() should find default files' ); |
1285de5c | 48 | |
49 | SKIP: { | |
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" |
63 | my $t = { | |
64 | PADDING => 1, | |
65 | _pc => 'pc', | |
66 | }; | |
67 | bless($t, 'Term::Cap' ); | |
68 | ||
69 | # see if Tpad() works | |
c6d685f7 | 70 | is( $t->Tpad(), undef, 'Tpad() should return undef with no arguments' ); |
71 | is( $t->Tpad('x'), 'x', 'Tpad() should return strings verbatim with no match' ); | |
72 | is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() should pad paddable strings' ); | |
1285de5c | 73 | |
74 | $t->{PADDING} = 2; | |
c6d685f7 | 75 | is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() should perform pad math' ); |
76 | is( $out->read(), 'apcpc', 'Tpad() should write to filehandle when passed' ); | |
1285de5c | 77 | |
c6d685f7 | 78 | is( $t->Tputs('PADDING'), 2, 'Tputs() should return existing value' ); |
79 | is( $t->Tputs('pc', 2), 'pc', 'Tputs() should delegate to Tpad()' ); | |
1285de5c | 80 | $t->Tputs('pc', 1, *OUT); |
c6d685f7 | 81 | is( $t->{pc}, 'pc', 'Tputs() should cache pc value when asked' ); |
82 | is( $out->read(), 'pc', 'Tputs() should write to filehandle when passed' ); | |
1285de5c | 83 | |
84 | eval { $t->Trequire( 'pc' ) }; | |
c6d685f7 | 85 | is( $@, '', 'Trequire() should finds existing cap' ); |
1285de5c | 86 | eval { $t->Trequire( 'nonsense' ) }; |
c6d685f7 | 87 | like( $@, qr/support: \(nonsense\)/, |
88 | 'Trequire() should croak with unsupported cap' ); | |
1285de5c | 89 | |
90 | my $warn; | |
91 | local $SIG{__WARN__} = sub { | |
92 | $warn = $_[0]; | |
93 | }; | |
94 | ||
95 | # test the first few features by forcing Tgetent() to croak (line 156) | |
96 | undef $ENV{TERM}; | |
97 | my $vals = {}; | |
d2492938 | 98 | eval { local $^W = 1; $t = Term::Cap->Tgetent($vals) }; |
c6d685f7 | 99 | like( $@, qr/TERM not set/, 'Tgetent() should croaks without TERM' ); |
100 | like( $warn, qr/OSPEED was not set/, 'Tgetent() should set default OSPEED' ); | |
d2492938 | 101 | |
1285de5c | 102 | is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' ); |
103 | ||
d2492938 JS |
104 | $warn = 'xxxx'; |
105 | eval { local $^W = 0; $t = Term::Cap->Tgetent($vals) }; | |
106 | is($warn,'xxxx',"Tgetent() doesn't carp() without warnings on"); | |
107 | ||
1285de5c | 108 | # check values for very slow speeds |
109 | $vals->{OSPEED} = 1; | |
110 | $warn = ''; | |
111 | eval { $t = Term::Cap->Tgetent($vals) }; | |
c6d685f7 | 112 | is( $warn, '', 'Tgetent() should not work if OSPEED is provided' ); |
113 | is( $vals->{PADDING}, 200, 'Tgetent() should set slow PADDING when needed' ); | |
1285de5c | 114 | |
d2492938 JS |
115 | |
116 | SKIP: { | |
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 | 127 | SKIP: { |
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 | 159 | SKIP: |
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 | 175 | is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' ); |
176 | is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' ); | |
1285de5c | 177 | |
178 | $t->{_test} = "a%."; | |
c6d685f7 | 179 | like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' ); |
5b48932f | 180 | if (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 | 189 | like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() should handle %+' ); |
1285de5c | 190 | $t->{_test} = 'a%+a'; |
c6d685f7 | 191 | is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' ); |
1285de5c | 192 | $t->{_test} .= 'a' x 99; |
c6d685f7 | 193 | like( $t->Tgoto('test', '', 1), qr/ba{98}/, |
194 | 'Tgoto() should substr()s %+ if needed' ); | |
1285de5c | 195 | |
196 | $t->{_test} = '%ra%d'; | |
c6d685f7 | 197 | is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' ); |
1285de5c | 198 | |
199 | $t->{_test} = 'a%>11bc'; | |
c6d685f7 | 200 | is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' ); |
1285de5c | 201 | |
202 | $t->{_test} = 'a%21'; | |
c6d685f7 | 203 | is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' ); |
1285de5c | 204 | |
205 | $t->{_test} = 'a%31'; | |
c6d685f7 | 206 | is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' ); |
1285de5c | 207 | |
208 | $t->{_test} = '%ia%21'; | |
c6d685f7 | 209 | is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' ); |
1285de5c | 210 | |
211 | $t->{_test} = '%z'; | |
c6d685f7 | 212 | is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' ); |
1285de5c | 213 | |
214 | # and this is pretty standard | |
215 | package TieOut; | |
216 | ||
217 | sub TIEHANDLE { | |
218 | bless( \(my $self), $_[0] ); | |
219 | } | |
220 | ||
221 | sub PRINT { | |
222 | my $self = shift; | |
223 | $$self .= join('', @_); | |
224 | } | |
225 | ||
226 | sub read { | |
227 | my $self = shift; | |
228 | substr( $$self, 0, length($$self), '' ); | |
229 | } | |
230 | ||
231 | __END__ | |
232 | bar: :tc=bar: \ | |
233 | baz: \ | |
234 | :f1: :f2: \ | |
235 | :no@ \ | |
236 | :k1#v1\ | |
237 | :k2=v2\\n2 |