From: chromatic Date: Mon, 1 Oct 2001 12:27:12 +0000 (-0600) Subject: Robustify %ENV Handling in Test (was Re: Failed Term/Cap.t test) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c6d685f7b14e90f390c3ccb1456a51bd0b02d527;p=p5sagit%2Fp5-mst-13.2.git Robustify %ENV Handling in Test (was Re: Failed Term/Cap.t test) Message-ID: <20011001183251.89148.qmail@onion.perl.org> p4raw-id: //depot/perl@12298 --- diff --git a/lib/Term/Cap.t b/lib/Term/Cap.t index ea34927..f3da8c9 100644 --- a/lib/Term/Cap.t +++ b/lib/Term/Cap.t @@ -30,21 +30,21 @@ $ENV{TERMCAP} = ''; my $path = join '', Term::Cap::termcap_path(); my $files = join '', grep { -f $_ } ( $ENV{HOME} . '/.termcap', '/etc/termcap', '/usr/share/misc/termcap' ); -is( $path, $files, 'termcap_path() found default files okay' ); +is( $path, $files, 'termcap_path() should find default files' ); SKIP: { # this is ugly, but -f $0 really *ought* to work skip("-f $0 fails, some tests difficult now", 2) unless -f $0; - $ENV{TERMCAP} = $0; - ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMCAP}' ); + $ENV{TERMCAP} = $ENV{TERMPATH} = $0; + ok( grep($0, Term::Cap::termcap_path()), + 'termcap_path() should find file from $ENV{TERMCAP}' ); $ENV{TERMCAP} = (grep { $^O eq $_ } qw( os2 MSWin32 dos )) ? 'a:/' : '/'; - $ENV{TERMPATH} = $0; - ok( grep($0, Term::Cap::termcap_path()), 'found file from $ENV{TERMPATH}' ); + ok( grep($0, Term::Cap::termcap_path()), + 'termcap_path() should find file from $ENV{TERMPATH}' ); } - # make a Term::Cap "object" my $t = { PADDING => 1, @@ -53,24 +53,25 @@ my $t = { bless($t, 'Term::Cap' ); # see if Tpad() works -is( $t->Tpad(), undef, 'Tpad() is undef with no string' ); -is( $t->Tpad('x'), 'x', 'Tpad() returns strings with no match' ); -is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() pads string fine' ); +is( $t->Tpad(), undef, 'Tpad() should return undef with no arguments' ); +is( $t->Tpad('x'), 'x', 'Tpad() should return strings verbatim with no match' ); +is( $t->Tpad( '1*a', 2 ), 'apcpc', 'Tpad() should pad paddable strings' ); $t->{PADDING} = 2; -is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() pad math is okay' ); -is( $out->read(), 'apcpc', 'Tpad() writes to filehandle fine' ); +is( $t->Tpad( '1*a', 3, *OUT ), 'apcpc', 'Tpad() should perform pad math' ); +is( $out->read(), 'apcpc', 'Tpad() should write to filehandle when passed' ); -is( $t->Tputs('PADDING'), 2, 'Tputs() returns existing value file' ); -is( $t->Tputs('pc', 2), 'pc', 'Tputs() delegates to Tpad() fine' ); +is( $t->Tputs('PADDING'), 2, 'Tputs() should return existing value' ); +is( $t->Tputs('pc', 2), 'pc', 'Tputs() should delegate to Tpad()' ); $t->Tputs('pc', 1, *OUT); -is( $t->{pc}, 'pc', 'Tputs() caches fine when asked' ); -is( $out->read(), 'pc', 'Tputs() writes to filehandle fine' ); +is( $t->{pc}, 'pc', 'Tputs() should cache pc value when asked' ); +is( $out->read(), 'pc', 'Tputs() should write to filehandle when passed' ); eval { $t->Trequire( 'pc' ) }; -is( $@, '', 'Trequire() finds existing cap fine' ); +is( $@, '', 'Trequire() should finds existing cap' ); eval { $t->Trequire( 'nonsense' ) }; -like( $@, qr/support: \(nonsense\)/, 'Trequire() croaks with unsupported cap' ); +like( $@, qr/support: \(nonsense\)/, + 'Trequire() should croak with unsupported cap' ); my $warn; local $SIG{__WARN__} = sub { @@ -81,29 +82,29 @@ local $SIG{__WARN__} = sub { undef $ENV{TERM}; my $vals = {}; eval { $t = Term::Cap->Tgetent($vals) }; -like( $@, qr/TERM not set/, 'Tgetent() croaks without TERM' ); -like( $warn, qr/OSPEED was not set/, 'Tgetent() set default OSPEED value' ); +like( $@, qr/TERM not set/, 'Tgetent() should croaks without TERM' ); +like( $warn, qr/OSPEED was not set/, 'Tgetent() should set default OSPEED' ); is( $vals->{PADDING}, 10000/9600, 'Default OSPEED implies default PADDING' ); # check values for very slow speeds $vals->{OSPEED} = 1; $warn = ''; eval { $t = Term::Cap->Tgetent($vals) }; -is( $warn, '', 'no warning when passing OSPEED to Tgetent()' ); -is( $vals->{PADDING}, 200, 'Tgetent() set slow PADDING when needed' ); +is( $warn, '', 'Tgetent() should not work if OSPEED is provided' ); +is( $vals->{PADDING}, 200, 'Tgetent() should set slow PADDING when needed' ); # now see if lines 177 or 180 will fail $ENV{TERM} = 'foo'; $ENV{TERMPATH} = '!'; $ENV{TERMCAP} = ''; eval { $t = Term::Cap->Tgetent($vals) }; -isn't( $@, '', 'Tgetent() caught bad termcap file' ); +isn't( $@, '', 'Tgetent() should catch bad termcap file' ); # if there's no valid termcap file found, it should croak $vals->{TERM} = ''; $ENV{TERMPATH} = $0; eval { $t = Term::Cap->Tgetent($vals) }; -like( $@, qr/failed termcap lookup/, 'Tgetent() dies with bad termcap file' ); +like( $@, qr/failed termcap lookup/, 'Tgetent() should dies with bad termcap' ); SKIP: { skip( "Can't write 'tcout' file for tests", 8 ) unless $writable; @@ -114,56 +115,58 @@ SKIP: { $ENV{TERMPATH} = join(' ', ('tcout') x 33); $vals->{TERM} = 'bar'; eval { $t = Term::Cap->Tgetent($vals) }; - like( $@, qr/failed termcap loop/, 'Tgetent() dies with much recursion' ); + like( $@, qr/failed termcap loop/, 'Tgetent() should catch deep recursion'); # now let it read a fake termcap file, and see if it sets properties $ENV{TERMPATH} = 'tcout'; $vals->{TERM} = 'baz'; $t = Term::Cap->Tgetent($vals); - is( $t->{_f1}, 1, 'Tgetent() set a single field correctly' ); - is( $t->{_f2}, 1, 'Tgetent() set another field on the same line' ); - is( $t->{_no}, '', 'Tgetent() set a blank field correctly' ); - is( $t->{_k1}, 'v1', 'Tgetent() set a key value pair correctly' ); - like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() set and translated a pair right' ); + is( $t->{_f1}, 1, 'Tgetent() should set a single field correctly' ); + is( $t->{_f2}, 1, 'Tgetent() should set another field on the same line' ); + is( $t->{_no}, '', 'Tgetent() should set a blank field correctly' ); + is( $t->{_k1}, 'v1', 'Tgetent() should set a key value pair correctly' ); + like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() should set and translate pairs' ); # and it should have set these two fields - is( $t->{_pc}, "\0", 'set _pc field correctly' ); - is( $t->{_bc}, "\b", 'set _bc field correctly' ); + is( $t->{_pc}, "\0", 'should set _pc field correctly' ); + is( $t->{_bc}, "\b", 'should set _bc field correctly' ); } # Tgoto has comments on the expected formats $t->{_test} = "a%d"; -is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() works with %d code' ); -is( $out->read(), 'a1', 'Tgoto() printed to filehandle fine' ); +is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' ); +is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' ); $t->{_test} = "a%."; -like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() works with %.' ); -like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, 'Tgoto() %. and magic work' ); +like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' ); +like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/, + 'Tgoto() should handle %. and magic' ); $t->{_test} = 'a%+'; -like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() works with %+' ); +like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() shoudl handle %+' ); $t->{_test} = 'a%+a'; -is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() works with %+ and a character' ); +is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' ); $t->{_test} .= 'a' x 99; -like( $t->Tgoto('test', '', 1), qr/ba{98}/, 'Tgoto() substr()s %+ if needed' ); +like( $t->Tgoto('test', '', 1), qr/ba{98}/, + 'Tgoto() should substr()s %+ if needed' ); $t->{_test} = '%ra%d'; -is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() swaps params with %r set' ); +is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' ); $t->{_test} = 'a%>11bc'; -is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() unpacks with %> set' ); +is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' ); $t->{_test} = 'a%21'; -is( $t->Tgoto('test'), 'a001', 'Tgoto() formats with %2 set' ); +is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' ); $t->{_test} = 'a%31'; -is( $t->Tgoto('test'), 'a0001', 'Tgoto() also formats with %3 set' ); +is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' ); $t->{_test} = '%ia%21'; -is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() incremented args with %i set '); +is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' ); $t->{_test} = '%z'; -is( $t->Tgoto('test'), 'OOPS', 'Tgoto() handled invalid arg fine' ); +is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' ); # and this is pretty standard package TieOut;