ACE/bin/PerlACE/Process.pm

   1 #!/usr/bin/env perl
   2
   3 package PerlACE::Process;
   4
   5 use strict;
   6 use English;
   7 use POSIX qw(:time_h);
   8
   9 $PerlACE::Process::ExeSubDir = './';
  10
  11 sub delay_factor {
  12     my($lps)    = 128;
  13     my($factor) = 1;
  14
  15     ## Keep increasing the loops per second until the amount of time
  16     ## exceeds the number of clocks per second.  The original code
  17     ## did not multiply $ticks by 8 but, for faster machines, it doesn't
  18     ## seem to return false values.  The multiplication is done to minimize
  19     ## the amount of time it takes to determine the correct factor.
  20     while(($lps <<= 1)) {
  21         my($ticks) = clock();
  22         for(my $i = $lps; $i >= 0; $i--) {
  23         }
  24         $ticks = clock() - $ticks;
  25         if ($ticks * 8 >= CLOCKS_PER_SEC) {
  26             $factor = 500000 / (($lps / $ticks) * CLOCKS_PER_SEC);
  27             last;
  28         }
  29     }
  30     return $factor;
  31 }
  32
  33 ### Check for -ExeSubDir commands, store the last one
  34 my @new_argv = ();
  35
  36 for(my $i = 0; $i <= $#ARGV; ++$i) {
  37     if ($ARGV[$i] eq '-ExeSubDir') {
  38         if (defined $ARGV[$i + 1]) {
  39             $PerlACE::Process::ExeSubDir = $ARGV[++$i].'/';
  40         }
  41         else {
  42             print STDERR "You must pass a directory with ExeSubDir\n";
  43             exit(1);
  44         }
  45     }
  46     else {
  47         push @new_argv, $ARGV[$i];
  48     }
  49 }
  50 @ARGV = @new_argv;
  51
  52 $PerlACE::Process::WAIT_DELAY_FACTOR = (defined $ENV{'ACE_RUNTEST_DELAY'}) ? $ENV{'ACE_RUNTEST_DELAY'} : 1;
  53
  54 # Set the process's target. If there's none, behavior falls back to pre-target
  55 # behavior.
  56 sub Target($)
  57 {
  58     my $self = shift;
  59     $self->{TARGET} = shift;
  60 }
  61
  62 if ($OSNAME eq "MSWin32") {
  63     require PerlACE::Process_Win32;
  64 }
  65 elsif ($OSNAME eq "VMS") {
  66     require PerlACE::Process_VMS;
  67 }
  68 else {
  69     require PerlACE::Process_Unix;
  70 }
  71
  72 1;