cpan/Term-Cap/test.pl

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