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