t/re/stclass_threads.t

   1 #!./perl
   2 #
   3 # This is a home for regular expression tests that don't fit into
   4 # the format supported by re/regexp.t.  If you want to add a test
   5 # that does fit that format, add it to re/re_tests, not here.
   6
   7 use strict;
   8 use warnings;
   9
  10 sub run_tests;
  11
  12 $| = 1;
  13
  14 BEGIN {
  15     chdir 't' if -d 't';
  16     require './test.pl';
  17     set_up_inc('../lib', '.', '../ext/re');
  18     require Config; Config->import;
  19 }
  20
  21 skip_all_without_config('useithreads');
  22 skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
  23
  24 plan tests => 6;  # Update this when adding/deleting tests.
  25
  26 run_tests() unless caller;
  27
  28 #
  29 # Tests start here.
  30 #
  31 sub run_tests {
  32     my @res;
  33     for my $len (10,100,1000) {
  34         my $result1= fresh_perl(sprintf(<<'EOF_CODE', $len),
  35         use threads;
  36         use re 'debug';
  37
  38         sub start_thread {
  39             warn "===\n";
  40             split /[.;]+[\'\"]+/, $_[0];
  41             warn "===\n";
  42         }
  43
  44         my $buffer = '.' x %d;
  45
  46         start_thread $buffer;
  47 EOF_CODE
  48         {});
  49         my $result2= fresh_perl(sprintf(<<'EOF_CODE', $len),
  50         use threads;
  51         use re 'debug';
  52
  53         sub start_thread {
  54             warn "\n===\n";
  55             split /[.;]+[\'\"]+/, $_[0];
  56             warn "\n===\n";
  57         }
  58
  59         my $buffer = '.' x %d;
  60         my $thr = threads->create('start_thread', $buffer);
  61         $thr->join();
  62 EOF_CODE
  63         {});
  64         for ($result1, $result2) {
  65             (undef,$_,undef)= split /\n===\n/, $_;
  66         }
  67         my @l1= split /\n/, $result1;
  68         my @l2= split /\n/, $result2;
  69         push @res, 0+@l2;
  70         is(0+@l2,0+@l1, sprintf
  71             "Threaded and unthreaded stclass behavior matches (n=%d)",
  72             $len);
  73     }
  74     my $n10= $res[0]/10;
  75     my $n100= $res[1]/100;
  76     my $n1000= $res[2]/1000;
  77     ok(abs($n10-$n100)<1,"Behavior appears to be sub quadratic ($n10, $n100)");
  78     ok(abs($n100-$n1000)<0.1,"Behavior is linear and not quadratic ($n100, $n1000)");
  79     ok(abs(3-$n1000)<0.1,"Behavior is linear as expected");
  80 }
  81 #