File Coverage

blib/lib/Devel/Trace/Fork.pm

Criterion	Covered	Total	%
statement	58	96	60.4
branch	9	38	23.6
condition	6	23	26.0
subroutine	10	11	90.9
pod	0	2	0.0
total	83	170	48.8

# -* - perl -*-

package Devel::Trace::Fork;
use Devel::Trace;
use Time::HiRes qw(gettimeofday);
use Fcntl ':flock';
use Carp;
use strict qw(vars subs);
use warnings;
our $VERSION = '0.11';
our ($FH, $FILE, $FH_LOCK, @O);
our $_PID2 = $$;
our $_PID = $$;
our $FLUSH = $ENV{DT_FORK_FLUSH} || 16_384;
our $SORT_NEEDED = 0;
our %IGNORE_PACKAGES = ('Devel::Trace::Fork' => 1);
$| = 1;

BEGIN {
  local $! = undef;
  $FILE = $ENV{DTRACE_FILE} || "./DTFork.$$";
  if (open $FH, '>', $FILE) {
    print $FH q{>  },$^X,q{ },$0,q{ },@ARGV,"\n";
    print $FH q{> },$^T,q{ },scalar gettimeofday(),"\n";
    close $FH;
    open ($FH_LOCK, '>>', "$FILE.x");
    print $FH_LOCK "$^T $$ <>\n";
    close $FH_LOCK;
  } else {
    croak "Devel::Trace::Fork: Failed to open trace output file $FILE: $!\n",
      "Use environment variable DTRACE_FILE to set an explicit trace output ",
      "file name.\n";
  }
}

no warnings 'redefine';
sub DB::DB {
  return unless $Devel::Trace::TRACE;
  my ($p, $f, $l) = caller;
  my $t;
  if ($_PID2 != $$) {
    $t = sprintf '%11.6f', gettimeofday()-$^T;
    @O = (">> $t:$$: ----------------- NEW PROCESS -----------------\n");
    $_PID2 = $$;

    # In MSWin32, children do not call the END{} block?
    # Then we need to flush every line :-(
    # Also, we won't get the -- END OF PROCESS -- indicator at the end :-(
    flush();
    $FLUSH = 0 if $^O eq "MSWin32";
  }
  if (!defined $IGNORE_PACKAGES{$p}) {
    $t ||= sprintf '%11.6f', gettimeofday()-$^T;

    my $code = \@{"::_<$f"};
    my $cde = $code->[$l] || "--- code not available ---\n";
    if (!defined $f) {
      print STDERR "$0 \$f not defined, $p, $f, $l\n";
    }
    if (!defined $l) {
      print STDERR "$0 \$l not defined $p, $f, $l\n";
    }
    if (!defined $code) {
      print STDERR "$0 \$code not defined $p, $f, $l\n";
    } elsif (!defined $cde) {
      print STDERR "$0 \$cde, \$code->[\$l] not defined $p, $f, $l\n";
    }


    push @O, ">> $t:$$:$?:$f:$l: $cde";
    if (@O > $FLUSH) {
      flush();
    }
  }
  return;
}

sub flush {
  if ($$ != $_PID && ! -f "$FILE.x") {
    Carp::cluck "Devel::Trace::Fork: ",
	"possibly appending trace data from $$ ",
	"after main process $_PID exited.\n";
    $SORT_NEEDED = 1;
  }
  unless (open $FH_LOCK, '>>', "$FILE.x" and flock $FH_LOCK, LOCK_EX) {
    carp 'Devel::Trace::Fork: ',
      "failed to lock output file $FILE before flush: $! $FH_LOCK\n";
  }
  print $FH_LOCK "$$ ", scalar gettimeofday(), "\n";

  if (open($FH, '>>', $FILE)) {
    print $FH @O;
    close $FH;
    close $FH_LOCK;
  } else {
    carp 'Devel::Trace::Fork: failed to flush ',
      scalar @O, " lines of output from pid=$$!\n";
  }

  @O = ();
  return;
}

END {
  $Devel::Trace::TRACE = 0;
  # *DB::DB = sub { print STDERR "DB::DB end called $$\n"; };

  my $t = sprintf '%11.6f', gettimeofday()-$^T;
  push @O, ">> $t:$$: -------------- END OF PROCESS ------------------\n";
  flush();

  if ($$ == $_PID || $SORT_NEEDED) {
    if ($$ == $_PID && $ENV{DTFORK_ERASE_ON_GOOD_EXIT} && $? == 0) {
      print STDERR "Good exit on $_PID. Erasing $FILE\n";
      unlink "$FILE.x";
      unlink $FILE if $ENV{DTFORK_ERASE_ON_GOOD_EXIT} > 0;
      undef $FILE;
      $? = 0;
      return;
    }
    if (open($FH_LOCK, '>>', "$FILE.x")) {
      print $FH_LOCK "$$ ", scalar gettimeofday(), "\n";
      flock $FH_LOCK, LOCK_EX;
    }

    if (open($FH, '<', $FILE)) {
      my @P = <$FH>;
      close $FH;

      @P = sort @P;

      if (open($FH, '>', $FILE)) {
	print $FH @P;
	close $FH;
      } else {
	carp 'Devel::Trace::Fork: failed to rewrite sorted output';
      }
    } else {
      carp 'Devel::Trace::Fork: failed to read final output';
    }

    close $FH_LOCK;
    unlink "$FILE.x";

    print STDERR "Devel::Trace::Fork output in <$FILE>\n";
  }
}

1;

__END__