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