xref: /openbsd/gnu/usr.bin/perl/t/re/stclass_threads.t (revision 9e6efb0a) 
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
7use strict;
8use warnings;
9
10sub run_tests;
11
12$| = 1;
13
14BEGIN {
15    chdir 't' if -d 't';
16    require './test.pl';
17    set_up_inc('../lib', '.', '../ext/re');
18    require Config; import Config;
19}
20
21skip_all_without_config('useithreads');
22skip_all_if_miniperl("no dynamic loading on miniperl, no threads");
23
24plan tests => 6;  # Update this when adding/deleting tests.
25
26run_tests() unless caller;
27
28#
29# Tests start here.
30#
31sub 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;
47EOF_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();
62EOF_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#
82