lib/Term/Cap.t

   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) };
 106 like( $@, qr/failed termcap lookup/, 'Tgetent() dies with bad termcap file' );
 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