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