The Tcpdump Group git mirrors - libpcap/blob - testprogs/TESTmt.pm

   1 require 5.10.1; # Debian 6
   2 use strict;
   3 use warnings FATAL => qw(uninitialized);
   4 use threads;
   5 use Thread::Queue;
   6
   7 # TESTrun helper functions (multithreaded implementation).
   8
   9 my $njobs;
  10 my $tmpid;
  11 my @tests;
  12 my @result_queues;
  13 my @tester_threads;
  14 my $next_to_dequeue;
  15
  16 sub my_tmp_id {
  17         return $tmpid;
  18 }
  19
  20 sub set_njobs {
  21         $njobs = shift;
  22         print "INFO: This Perl supports threads, using $njobs tester thread(s).\n";
  23 }
  24
  25 # Iterate over the list of tests, pick tests that belong to the current job,
  26 # run one test at a time and send the result to the job's results queue.
  27 sub tester_thread_func {
  28         my $jobid = shift;
  29         $tmpid = sprintf 'job%03u', $jobid;
  30         for (my $i = $jobid; $i < scalar @tests; $i += $njobs) {
  31                 my $test = $tests[$i];
  32                 my $result = $test->{func} ($test);
  33                 $result->{label} = $test->{label};
  34                 $result_queues[$jobid]->enqueue ($result);
  35         }
  36         # Instead of detaching let the receiver join, this works around File::Temp
  37         # not cleaning up.
  38         # No Thread::Queue->end() in Perl 5.10.1, so use an undef to mark the end.
  39         $result_queues[$jobid]->enqueue (undef);
  40 }
  41
  42 sub start_tests {
  43         @tests = @_;
  44         for (0 .. $njobs - 1) {
  45                 $result_queues[$_] = Thread::Queue->new;
  46                 $tester_threads[$_] =  threads->create (\&tester_thread_func, $_);
  47         }
  48         $next_to_dequeue = 0;
  49 }
  50
  51 # Here ordering of the results is the same as ordering of the tests because
  52 # this function starts at job 0 and continues round-robin, which reverses the
  53 # interleaving done in the thread function above; also because every attempt
  54 # to dequeue blocks until it returns exactly one result.
  55 sub get_next_result {
  56         for (0 .. $njobs - 1) {
  57                 my $jobid = $next_to_dequeue;
  58                 $next_to_dequeue = ($next_to_dequeue + 1) % $njobs;
  59                 # Skip queues that have already ended.
  60                 next unless defined $result_queues[$jobid];
  61                 my $result = $result_queues[$jobid]->dequeue;
  62                 # A test result?
  63                 return $result if defined $result;
  64                 # No, an end-of-queue marker.
  65                 $result_queues[$jobid] = undef;
  66                 $tester_threads[$jobid]->join;
  67         }
  68         # No results after one complete round, therefore done.
  69         return undef;
  70 }
  71
  72 1;