ext/re/t/re.t

   1 #!./perl
   2
   3 BEGIN {
   4         chdir 't' if -d 't';
   5         @INC = '../lib';
   6         require Config;
   7         if (($Config::Config{'extensions'} !~ /\bre\b/) ){
   8                 print "1..0 # Skip -- Perl configured without re module\n";
   9                 exit 0;
  10         }
  11 }
  12
  13 use strict;
  14
  15 use Test::More tests => 14;
  16 require_ok( 're' );
  17
  18 # setcolor
  19 $INC{ 'Term/Cap.pm' } = 1;
  20 local $ENV{PERL_RE_TC};
  21 re::setcolor();
  22 is( $ENV{PERL_RE_COLORS}, "md\tme\tso\tse\tus\tue",
  23         'setcolor() should provide default colors' );
  24 $ENV{PERL_RE_TC} = 'su,n,ny';
  25 re::setcolor();
  26 is( $ENV{PERL_RE_COLORS}, "su\tn\tny", '... or use $ENV{PERL_RE_COLORS}' );
  27
  28 # bits
  29 # get on
  30 my $warn;
  31 local $SIG{__WARN__} = sub {
  32         $warn = shift;
  33 };
  34 eval { re::bits(1) };
  35 like( $warn, qr/Useless use/, 'bits() should warn with no args' );
  36
  37 delete $ENV{PERL_RE_COLORS};
  38 re::bits(0, 'debug');
  39 is( $ENV{PERL_RE_COLORS}, undef,
  40         "... should not set regex colors given 'debug'" );
  41 re::bits(0, 'debugcolor');
  42 isnt( $ENV{PERL_RE_COLORS}, '',
  43         "... should set regex colors given 'debugcolor'" );
  44 re::bits(0, 'nosuchsubpragma');
  45 like( $warn, qr/Unknown "re" subpragma/,
  46         '... should warn about unknown subpragma' );
  47 ok( re::bits(0, 'taint') & 0x00100000, '... should set taint bits' );
  48 ok( re::bits(0, 'eval')  & 0x00200000, '... should set eval bits' );
  49
  50 local $^H;
  51
  52 # import
  53 re->import('taint', 'eval');
  54 ok( $^H & 0x00100000, 'import should set taint bits in $^H when requested' );
  55 ok( $^H & 0x00200000, 'import should set eval bits in $^H when requested' );
  56
  57 re->unimport('taint');
  58 ok( !( $^H & 0x00100000 ), 'unimport should clear bits in $^H when requested' );
  59 re->unimport('eval');
  60 ok( !( $^H & 0x00200000 ), '... and again' );
  61 my $reg=qr/(foo|bar|baz|blah)/;
  62 close STDERR;
  63 eval"use re Debug=>'ALL'";
  64 my $ok='foo'=~/$reg/;
  65 eval"no re Debug=>'ALL'";
  66 ok( $ok, 'No segv!' );
  67
  68
  69 package Term::Cap;
  70
  71 sub Tgetent {
  72         bless({}, $_[0]);
  73 }
  74
  75 sub Tputs {
  76         return $_[1];
  77 }