File Coverage

blib/lib/Sys/Trace/Impl/Truss.pm

Criterion	Covered	Total	%
statement	61	84	72.6
branch	22	36	61.1
condition	1	6	16.6
subroutine	10	14	71.4
pod	0	6	0.0
total	94	146	64.3

package Sys::Trace::Impl::Truss;
use strict;

use Cwd ();
use File::Spec ();
use File::Temp ();
use POSIX ();
use Text::Balanced qw(extract_quotelike extract_bracketed);
use Time::HiRes qw(time);

=head1 NAME

Sys::Trace::Impl::Truss - Sys::Trace implementation for truss(1)

=head1 DESCRIPTION

This should not normally be used directly, instead use L which will
pick a suitable interface for your platform.

Truss is found on SVR4 systems. On Solaris in the C package. On AIX in
C (apparently, I don't have access to AIX, hopefully the
output is close enough).

=cut

sub usable {
  system q{truss 2>/dev/null};
  return POSIX::WIFEXITED($?) && POSIX::WEXITSTATUS($?) == 1;
}

sub new {
  my($class, %args) = @_;
  my $self = bless {}, $class;

  my @run = qw(strace -d);

  if($args{follow_forks}) {
    push @run, "-f";
  }

  # TODO: Support saving this elsewhere for offline processing?
  $self->{temp} = File::Temp->new;
  push @run, "-o", $self->{temp};

  if($args{exec}) {
    push @run, ref $args{exec}
      ? @{$args{exec}}
      : (qw(sh -c), $args{exec});
  } elsif($args{pid}) {
    push @run, "-p", $args{pid};
  }

  $self->{run} = \@run;

  return $self;
}

sub call {
  my($self, @calls) = @_;
  # We need chdir to track the working directory, so add iff filtering.
  push @calls, "chdir";

  splice @{$self->{run}}, 1, 0, map { ("-t", $_) } @calls;
}

sub run {
  my($self) = @_;
  $self->{cwd} = Cwd::getcwd;
  $self->{basetime} = time;
  exec @{$self->{run}} or die "Unable to exec: $!";
}

sub pid {
  my($self, $pid) = @_;
  $self->{pid} = $pid if defined $pid;
  $self->{pid};
}

{

# System calls that take a name argument and the position
# XXX: need to handle multiple args
my %name_syscalls = (
  open => 0,
  stat => 0,
  lstat => 0,
  stat64 => 0,
  lstat64 => 0,
  chdir => 0,
  link => 0,
  unlink => 0,
  rmdir => 0,
  mkdir => 0,
  rename => 0,
  access => 0,
  execve => 0,
);

my $line_re = qr{^
  (?:([0-9]+):\s+)? # PID
  ([0-9.]+)\s+    # Clock time
  (\w+)\((.*)\)   # syscall(...args...)
  (?:
    # Return value
    \s+=\s+
    (-?[0-9]+|0x[0-9A-Fa-f]+)
    # Extra value (e.g. getpid())
    (?:\s+\[\d+\])?

  | # argc = ?
    \s+(\w+)\s+=\s+(\d+)

  | # Error
    \s+Err\#(\d+) (\w+)
  | # No return (e.g. exit)
  )
$}x;
my @line_names = qw(pid time call args return extra_name extra_value errno);

sub parse {
  my($self, $fh) = @_;

  if(!$fh) {
    open $fh, "<", $self->{temp} or die $!;
  }

  my @calls;
  while(<$fh>) {
    my %call;

    if(/Base time stamp:\s+([0-9.]+)/) {
      $self->{basetime} = $1;
      next;
    }

    @call{@line_names} = ($_ =~ $line_re);
    $call{args} = _parse_args($call{args});

    next unless defined $call{call};

    $call{walltime} = $self->{basetime} + $call{time};

    if(exists $name_syscalls{$call{call}}) {
      $call{name} = $call{args}->[$name_syscalls{$call{call}}];

      if($call{name} !~ m{^/}) {
        # Resolve realtive paths
        $call{name} = File::Spec->rel2abs($call{name}, $self->{cwd});
      }

      # Need to keep track of cwd for the relative path resolving
      if($call{call} eq 'chdir' && $call{return} == 0) {
        $self->{cwd} = $call{name};
      }
    }

    push @calls, \%call;
  }

  return \@calls;
}

}

sub _parse_args {
  my($args) = @_;

  my @args;
  while($args) {
    if($args =~ /^"/) { # String
      (my $string, $args) = extract_quotelike($args);
      ($string) = $string =~ /"(.*)"/;

      $string .= "..." if $args =~ s/\.\.//;
      push @args, $string;

    } elsif($args =~ /^([[{])/) { # Start of structure
      (my $string, $args) = extract_bracketed($args, $1);
      push @args, $string;

    } elsif($args =~ s{(0x[a-fA-F0-9]+|-?[0-9]+)(?:\s+(/\* .*? \*/))?}{}) {
      # Number (plus optional comment)
      push @args, $1;
    } elsif($args =~ s/^([^,]+)//) {
      # Constant or similar
      push @args, $1;
    }

    $args =~ s/^,\s*//;
  }

  return \@args;
}

1;