view release on metacpan or  search on metacpan

lib/Forks/Super/Debug.pm  view on Meta::CPAN

    # what would we want to know?
    #
    #   parent: current stack trace
    #
    #   all jobs
    #   --------
    #     job id
    #     current state
    #     creation time
    #     cmd/exec: command
    #     sub/not code ref: name of subroutine
    #     sub/code ref:     caller
    #
    #   queued jobs
    #   -----------
    #     last queue check, reason for last deferral (*)
    #
    #   active/suspended jobs
    #   ---------------------
    #     start time
    #     current pid
    #   X child_fh summary
    #   X sub/natural: stack trace from child (*)
    #
    #   completed jobs
    #   --------------
    #     completion time (total run time)
    #     exit status
    #     reaped? reap time
    #   X output produced, input consumed (*)
    #
    # other stuff we want to know:
    # ----------------------------
    #     total jobs on queue
    #     total active jobs
    #     total completed jobs
    #     completed job distribution of run times
    my ($dump_completed_jobs) = @_;
    no warnings 'once';

    if ($$ != $Forks::Super::MAIN_PID) {
	# this is not the main fork, so we should do the
	# default SIGQUIT behavior. i.e., QUIT.
	exit 21 if &IS_WIN32;
	exec $^X, '-e', 'kill "QUIT",$$; sleep 1; die';
    }

    $parent_dumps++;

    open my $TTY, '>>', &IS_WIN32 ? 'CON' : '/dev/tty';

    print $TTY scalar localtime(time), "\n";
    print $TTY "Full Forks::Super v$Forks::Super::VERSION ",
    	"job dump process $$\n";
    # if $MAX_PROC is a coderef, this output will be like "CODE(0x0123ABCD)"
    print $TTY "Default maximum background procs:  $Forks::Super::MAX_PROC\n";
    print $TTY "Default maximum CPU load:          $Forks::Super::MAX_LOAD\n";
    print $TTY "Child fork ok:                     ",
    	"$Forks::Super::CHILD_FORK_OK\n";
    print $TTY "Default busy system busy behavior: $Forks::Super::ON_BUSY\n";
    if (defined($Forks::Super::IPC_DIR) && $Forks::Super::IPC_DIR ne '') {
	print $TTY "Default IPC directory:  $Forks::Super::IPC_DIR\n";
    }
    
    print $TTY "\n";

    # parent process
    print $TTY "PARENT PROCESS\n--------------\n";
    print $TTY &Carp::longmess, "\n\n";

    # signal active jobs to give us their stack traces, if applicable
    my $children_signalled = 0;
    foreach my $job (@Forks::Super::ALL_JOBS) {
	if ($job->is_active && $job->{_enable_dump}
	    && ($job->{style} eq 'natural' || $job->{style} eq 'sub')) {

	    $children_signalled += $job->kill($DUMPSIG);
	}
    }

    # active jobs
    my $header = 0;
    my ($num_active, $num_deferred, $num_complete, $num_other) = (0,0,0,0);
    my $num_reaped = 0;
    foreach my $job (@Forks::Super::ALL_JOBS) {
	if ($job->is_active || $job->{state} eq 'SUSPENDED') {
            if (!$header++) {
                print $TTY "ACTIVE JOBS\n-----------\n\n";
            }
	    _dump_job($TTY, $job);
	    $num_active++;
	}
    }

    # queued jobs
    $header = 0;
    foreach my $job (@Forks::Super::ALL_JOBS) {
	if ($job->is_deferred) {
            if (!$header++) {
                print $TTY "QUEUED JOBS\n-----------\n\n";
            }
	    _dump_job($TTY, $job, 'queue');
	    $num_deferred++;
	}
    }

    # complete jobs
    my @run_times = ();
    if ($dump_completed_jobs) {
	$header = 0;
	foreach my $job (@Forks::Super::ALL_JOBS, 
			 @Forks::Super::Job::ARCHIVED_JOBS) {
	    if ($job->is_complete) {
                if (!$header++) {
                    print $TTY "COMPLETE JOBS\n-------------\n\n";
                }
		_dump_job($TTY, $job);
		push @run_times, $job->{end} - $job->{start};
		$num_complete++;
		$num_reaped++ if $job->is_reaped;