Commit | Line | Data |
1285de5c |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | END { |
9 | # let VMS whack all versions |
10 | 1 while unlink('tcout'); |
11 | } |
12 | |
13 | use Test::More tests => 43; |
14 | |
15 | use_ok( 'Term::Cap' ); |
16 | |
17 | local (*TCOUT, *OUT); |
18 | my $out = tie *OUT, 'TieOut'; |
19 | my $writable = 1; |
20 | |
21 | if (open(TCOUT, ">tcout")) { |
22 | print TCOUT <DATA>; |
23 | close TCOUT; |
24 | } else { |
25 | $writable = 0; |
26 | } |
27 | |
28 | # termcap_path -- the names are hardcoded in Term::Cap |
29 | $ENV{TERMCAP} = ''; |
30 | my $path = join '', Term::Cap::termcap_path(); |
31 | my $files = join '', grep { -f $_ } ( $ENV{HOME} . '/.termcap', '/etc/termcap', |
32 | '/usr/share/misc/termcap' ); |
33 | is( $path, $files, 'termcap_path() found default files okay' ); |
34 | |
35 | SKIP: { |
36 | # this is ugly, but -f $0 really *ought* to work |
37 | skip("-f $0 fails, some tests difficult now", 2) unless -f $0; |
38 | |
39 | $ENV{TERMCAP} = $0; |
40 | ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMCAP}' ); |
41 | |
42 | $ENV{TERMCAP} = (grep { $^O eq $_ } qw( os2 MSWin32 dos )) ? 'a:/' : '/'; |
43 | $ENV{TERMPATH} = $0; |
44 | ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMPATH}' ); |
45 | } |
46 | |
47 | |
48 | # make a Term::Cap "object" |
49 | my $t = { |
50 | PADDING => 1, |
51 | _pc => 'pc', |
52 | }; |
53 | bless($t, 'Term::Cap' ); |
54 | |
55 | # see if Tpad() works |
56 | is( $t->Tpad(), undef, 'Tpad() is undef with no string' ); |
57 | is( $t->Tpad('x'), 'x', 'Tpad() returns strings with no match' ); |
58 | is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() pads string fine' ); |
59 | |
60 | $t->{PADDING} = 2; |
61 | is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() pad math is okay' ); |
62 | is( $out->read(), 'apcpc', 'Tpad() writes to filehandle fine' ); |
63 | |
64 | is( $t->Tputs('PADDING'), 2, 'Tputs() returns existing value file' ); |
65 | is( $t->Tputs('pc', 2), 'pc', 'Tputs() delegates to Tpad() fine' ); |
66 | $t->Tputs('pc', 1, *OUT); |
67 | is( $t->{pc}, 'pc', 'Tputs() caches fine when asked' ); |
68 | is( $out->read(), 'pc', 'Tputs() writes to filehandle fine' ); |
69 | |
70 | eval { $t->Trequire( 'pc' ) }; |
71 | is( $@, '', 'Trequire() finds existing cap fine' ); |
72 | eval { $t->Trequire( 'nonsense' ) }; |
73 | like( $@, qr/support: \(nonsense\)/, 'Trequire() croaks with unsupported cap' ); |
74 | |
75 | my $warn; |
76 | local $SIG{__WARN__} = sub { |
77 | $warn = $_[0]; |
78 | }; |
79 | |
80 | # test the first few features by forcing Tgetent() to croak (line 156) |
81 | undef $ENV{TERM}; |
82 | my $vals = {}; |
83 | eval { $t = Term::Cap->Tgetent($vals) }; |
84 | like( $@, qr/TERM not set/, 'Tgetent() croaks without TERM' ); |
85 | like( $warn, qr/OSPEED was not set/, 'Tgetent() set default OSPEED value' ); |
86 | is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' ); |
87 | |
88 | # check values for very slow speeds |
89 | $vals->{OSPEED} = 1; |
90 | $warn = ''; |
91 | eval { $t = Term::Cap->Tgetent($vals) }; |
92 | is( $warn, '', 'no warning when passing OSPEED to Tgetent()' ); |
93 | is( $vals->{PADDING}, 200, 'Tgetent() set slow PADDING when needed' ); |
94 | |
95 | # now see if lines 177 or 180 will fail |
96 | $ENV{TERM} = 'foo'; |
97 | $ENV{TERMPATH} = '!'; |
98 | $ENV{TERMCAP} = ''; |
99 | eval { $t = Term::Cap->Tgetent($vals) }; |
100 | isn't( $@, '', 'Tgetent() caught bad termcap file' ); |
101 | |
102 | # if there's no valid termcap file found, it should croak |
103 | $vals->{TERM} = ''; |
104 | $ENV{TERMPATH} = $0; |
105 | eval { $t = Term::Cap->Tgetent($vals) }; |
93e59c9b |
106 | like( $@, qr/failed termcap lookup/, 'Tgetent() dies with bad termcap file' ); |
1285de5c |
107 | |
108 | SKIP: { |
109 | skip( "Can't write 'tcout' file for tests", 8 ) unless $writable; |
110 | |
111 | # it shouldn't try to read one file more than 32(!) times |
112 | # see __END__ for a really awful termcap example |
113 | |
114 | $ENV{TERMPATH} = join(' ', ('tcout') x 33); |
115 | $vals->{TERM} = 'bar'; |
116 | eval { $t = Term::Cap->Tgetent($vals) }; |
117 | like( $@, qr/failed termcap loop/, 'Tgetent() dies with much recursion' ); |
118 | |
119 | # now let it read a fake termcap file, and see if it sets properties |
120 | $ENV{TERMPATH} = 'tcout'; |
121 | $vals->{TERM} = 'baz'; |
122 | $t = Term::Cap->Tgetent($vals); |
123 | is( $t->{_f1}, 1, 'Tgetent() set a single field correctly' ); |
124 | is( $t->{_f2}, 1, 'Tgetent() set another field on the same line' ); |
125 | is( $t->{_no}, '', 'Tgetent() set a blank field correctly' ); |
126 | is( $t->{_k1}, 'v1', 'Tgetent() set a key value pair correctly' ); |
127 | like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() set and translated a pair right' ); |
128 | |
129 | # and it should have set these two fields |
130 | is( $t->{_pc}, "\0", 'set _pc field correctly' ); |
131 | is( $t->{_bc}, "\b", 'set _bc field correctly' ); |
132 | } |
133 | |
134 | # Tgoto has comments on the expected formats |
135 | $t->{_test} = "a%d"; |
136 | is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() works with %d code' ); |
137 | is( $out->read(), 'a1', 'Tgoto() printed to filehandle fine' ); |
138 | |
139 | $t->{_test} = "a%."; |
140 | like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() works with %.' ); |
141 | like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, 'Tgoto() %. and magic work' ); |
142 | |
143 | $t->{_test} = 'a%+'; |
144 | like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() works with %+' ); |
145 | $t->{_test} = 'a%+a'; |
146 | is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() works with %+ and a character' ); |
147 | $t->{_test} .= 'a' x 99; |
148 | like( $t->Tgoto('test', '', 1), qr/ba{98}/, 'Tgoto() substr()s %+ if needed' ); |
149 | |
150 | $t->{_test} = '%ra%d'; |
151 | is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() swaps params with %r set' ); |
152 | |
153 | $t->{_test} = 'a%>11bc'; |
154 | is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() unpacks with %> set' ); |
155 | |
156 | $t->{_test} = 'a%21'; |
157 | is( $t->Tgoto('test'), 'a001', 'Tgoto() formats with %2 set' ); |
158 | |
159 | $t->{_test} = 'a%31'; |
160 | is( $t->Tgoto('test'), 'a0001', 'Tgoto() also formats with %3 set' ); |
161 | |
162 | $t->{_test} = '%ia%21'; |
163 | is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() incremented args with %i set '); |
164 | |
165 | $t->{_test} = '%z'; |
166 | is( $t->Tgoto('test'), 'OOPS', 'Tgoto() handled invalid arg fine' ); |
167 | |
168 | # and this is pretty standard |
169 | package TieOut; |
170 | |
171 | sub TIEHANDLE { |
172 | bless( \(my $self), $_[0] ); |
173 | } |
174 | |
175 | sub PRINT { |
176 | my $self = shift; |
177 | $$self .= join('', @_); |
178 | } |
179 | |
180 | sub read { |
181 | my $self = shift; |
182 | substr( $$self, 0, length($$self), '' ); |
183 | } |
184 | |
185 | __END__ |
186 | bar: :tc=bar: \ |
187 | baz: \ |
188 | :f1: :f2: \ |
189 | :no@ \ |
190 | :k1#v1\ |
191 | :k2=v2\\n2 |