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} = '/';
  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 SKIP: {
 106         skip( "Can't write 'tcout' file for tests", 9 ) unless $writable;
 107
 108         # it won't find the termtype in this fake file, so it should croak
 109         $vals->{TERM} = 'quux';
 110         $ENV{TERMPATH} = 'tcout';
 111         eval { $t = Term::Cap->Tgetent($vals) };
 112         like( $@, qr/failed termcap/, 'Tgetent() should die with bad termcap' );
 113
 114         # it shouldn't try to read one file more than 32(!) times
 115         # see __END__ for a really awful termcap example
 116         $ENV{TERMPATH} = join(' ', ('tcout') x 33);
 117         $vals->{TERM} = 'bar';
 118         eval { $t = Term::Cap->Tgetent($vals) };
 119         like( $@, qr/failed termcap loop/, 'Tgetent() should catch deep recursion');
 120
 121         # now let it read a fake termcap file, and see if it sets properties
 122         $ENV{TERMPATH} = 'tcout';
 123         $vals->{TERM} = 'baz';
 124         $t = Term::Cap->Tgetent($vals);
 125         is( $t->{_f1}, 1, 'Tgetent() should set a single field correctly' );
 126         is( $t->{_f2}, 1, 'Tgetent() should set another field on the same line' );
 127         is( $t->{_no}, '', 'Tgetent() should set a blank field correctly' );
 128         is( $t->{_k1}, 'v1', 'Tgetent() should set a key value pair correctly' );
 129         like( $t->{_k2}, qr/v2\\\n2/, 'Tgetent() should set and translate pairs' );
 130
 131         # and it should have set these two fields
 132         is( $t->{_pc}, "\0", 'should set _pc field correctly' );
 133         is( $t->{_bc}, "\b", 'should set _bc field correctly' );
 134 }
 135
 136 # Tgoto has comments on the expected formats
 137 $t->{_test} = "a%d";
 138 is( $t->Tgoto('test', '', 1, *OUT), 'a1', 'Tgoto() should handle %d code' );
 139 is( $out->read(), 'a1', 'Tgoto() should print to filehandle if passed' );
 140
 141 $t->{_test} = "a%.";
 142 like( $t->Tgoto('test', '', 1), qr/^a\x01/, 'Tgoto() should handle %.' );
 143 like( $t->Tgoto('test', '', 0), qr/\x61\x01\x08/,
 144         'Tgoto() should handle %. and magic' );
 145
 146 $t->{_test} = 'a%+';
 147 like( $t->Tgoto('test', '', 1), qr/a\x01/, 'Tgoto() shoudl handle %+' );
 148 $t->{_test} = 'a%+a';
 149 is( $t->Tgoto('test', '', 1), 'ab', 'Tgoto() should handle %+char' );
 150 $t->{_test} .= 'a' x 99;
 151 like( $t->Tgoto('test', '', 1), qr/ba{98}/,
 152         'Tgoto() should substr()s %+ if needed' );
 153
 154 $t->{_test} = '%ra%d';
 155 is( $t->Tgoto('test', 1, ''), 'a1', 'Tgoto() should swaps params with %r' );
 156
 157 $t->{_test} = 'a%>11bc';
 158 is( $t->Tgoto('test', '', 1), 'abc', 'Tgoto() should unpack args with %>' );
 159
 160 $t->{_test} = 'a%21';
 161 is( $t->Tgoto('test'), 'a001', 'Tgoto() should format with %2' );
 162
 163 $t->{_test} = 'a%31';
 164 is( $t->Tgoto('test'), 'a0001', 'Tgoto() should also formats with %3' );
 165
 166 $t->{_test} = '%ia%21';
 167 is( $t->Tgoto('test', '', 1), 'a021', 'Tgoto() should increment args with %i' );
 168
 169 $t->{_test} = '%z';
 170 is( $t->Tgoto('test'), 'OOPS', 'Tgoto() should catch invalid args' );
 171
 172 # and this is pretty standard
 173 package TieOut;
 174
 175 sub TIEHANDLE {
 176         bless( \(my $self), $_[0] );
 177 }
 178
 179 sub PRINT {
 180         my $self = shift;
 181         $$self .= join('', @_);
 182 }
 183
 184 sub read {
 185         my $self = shift;
 186         substr( $$self, 0, length($$self), '' );
 187 }
 188
 189 __END__
 190 bar: :tc=bar: \
 191 baz: \
 192 :f1: :f2: \
 193 :no@ \
 194 :k1#v1\
 195 :k2=v2\\n2