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