view release on metacpan or  search on metacpan

lib/IO/Trace.pm  view on Meta::CPAN

package IO::Trace;

use 5.006000;
use strict;
use warnings;
use base qw(Exporter);
use Getopt::Long qw(GetOptions Configure);
use IPC::Open3 qw(open3);
use IO::Select;
use IO::Handle;
use IO::File qw(O_WRONLY O_TRUNC O_CREAT SEEK_CUR);

our @EXPORT = qw(iotrace);
our $VERSION = '0.025';

# Magic Timer Settings
our $has_hires = eval { require Time::HiRes; 1 };
our $patience_idle = 8000; # Seconds to wait for I/O while process is still running
our $patience_kill_mute = $has_hires ? 5.2 : 6; # Seconds to wait for "mute" process to terminate. If all its handles are closed, then force SIGTERM and SIGKILL if still running after waiting this long.
our $heartbeat_grind_mute = 0.2; # Interval Seconds between SIGCHLD check to test if "mute" child died yet.
our $implicit_close_before_chld = 0.08; # Maximum Seconds to wait for SIGCHLD after all handles have been closed in order to consider it an implicit close instead of explicit close.
our $implicit_chld_before_close = $has_hires ? 0.25 : 1; # Maximum Seconds after receiving SIGCHLD to consider a close to be implicit. Any longer is considered an explicit close.
our $patience_zombie_breather = $has_hires ? 5.6 : 7; # Maximum Seconds of uninterrupted silence after receiving SIGCHLD to wait for the process to close all handles. Any longer, then all open pipes are implicitly slapped closed to sufficate the zomb...

sub now { $has_hires ? Time::HiRes::time() : time }

sub usage {
    $0 =~ /([^\/]+)$/ and return "Usage> $1 -o <output_log> CMD [ARGS]\n";
}

sub iotrace {
    my $self = __PACKAGE__->new;
    my @args = @_ ? @_ : @ARGV or die usage; # No args is Error
    $self->parse_commandline(@args) or die usage; # Broken args parsing is Error
    $self->{help} and print usage and exit; # Showing --help usage is not Error
    $self->{version} and print "iotrace -- version $VERSION\n" and exit; # Show version
    @{$self->{run}} or exit print usage; # No CMD is Error
    $self->{child_died} = 0;
    local $SIG{CHLD} = sub { $self->{child_died} = now; };
    $self->run_trace;
    my $exit_status = $self->finish_child;
    if (defined wantarray) {
        return $exit_status;
    }
    exit $exit_status;
}

sub new {
    my $self = shift;
    my $args = shift || {};
    return bless $args, $self;
}

sub parse_commandline {
    my $self = shift;
    Configure(qw[require_order bundling]);
    local @ARGV = @_;
    my $ret = GetOptions
        "V"     => \($self->{version} = 0),
        "o=s"   => \($self->{output_log_file}),
        "v+"    => \($self->{verbose} = 0),
        "x+"    => \($self->{heX_ify} = 0),
        "t+"    => \($self->{timing} = 0),
        "f+"    => \($self->{follow_fork} = 0),
        "q+"    => \($self->{quiet} = 0), # Ignored
        "s=i"   => \($self->{size_of_strings}), # Ignored
        "e=s"   => \($self->{events}),  # Ignored
        "help|h"=> \($self->{help}),
        ;
    $self->{run} = [@ARGV];
    return $ret;
}

sub t {
    my $self = shift;
    my $h = "";
    if ($self->{follow_fork} == 1) { $h .= "$self->{pid} "; }
    if ($self->{timing}) {
        my $now = $self->{timing} > 1 ? now : time;
        my @t = localtime $now;
        $h .= sprintf "%02d:%02d:%02d", $t[2], $t[1], $t[0];
        $h .= sprintf ".%06d", 1000000*($now - int($now)) if $self->{timing} > 1;
        $h .= " ";
    }
    return $h;
}

sub log {
    my $self = shift;
    my $line = join "", @_;
    $line =~ s/\s*$/\n/;
    $self->{log}->print($self->t().$line);
}

# Escape strings like strace does
sub e {
    my $self = shift;
    my $chars = shift;
    if ($self->{heX_ify} > 1) {
        # -xx: Super Hex Encode everything
        $chars =~ s/([\s\S])/sprintf "\\x%02x", ord($1)/eg;
    }
    else {
        # Both \\ and \" really need to be escaped
        # But add other helpful chars to make it easier for Perl to read too.
        $chars =~ s/([\\\"\'\$\@])/\\$1/g;
        # Special backslash escape chars for easy legibility
        $chars =~ s/\t/\\t/g;
        $chars =~ s/\r/\\r/g;
        $chars =~ s/\n/\\n/g;
        if ($self->{heX_ify}) {
            # -x: Hex Encode only non-ascii chars
            $chars =~ s/([^\ -\~])/sprintf "\\x%02x", ord $1/eg;
        }
        else {
            # Default is octal encoding non-ascii only
            $chars =~ s/([^\ -\~])/sprintf "\\%03o", ord $1/eg;