ext/re/t/re.t

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