File Coverage

blib/lib/Sys/Ptrace.pm

Criterion	Covered	Total	%
statement	30	36	83.3
branch	4	12	33.3
condition	9	15	60.0
subroutine	7	7	100.0
pod	0	1	0.0
total	50	71	70.4

package Sys::Ptrace;

use strict;
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION $AUTOLOAD );
use Exporter;
use DynaLoader;
use Carp qw( croak );

$VERSION = '0.06';
@ISA     = qw(Exporter DynaLoader);

@EXPORT_OK = qw(
  ptrace
  PT_ATTACH
  PT_CONTINUE
  PT_DETACH
  PT_GETFPREGS
  PT_GETFPXREGS
  PT_GETREGS
  PT_KILL
  PT_READ_D
  PT_READ_I
  PT_READ_U
  PT_SETFPREGS
  PT_SETFPXREGS
  PT_SETREGS
  PT_STEP
  PT_SYSCALL
  PT_TRACE_ME
  PT_WRITE_D
  PT_WRITE_I
  PT_WRITE_U
);

@EXPORT = qw( ptrace );

# THE FOLLOWING HASHREF WAS GENERATED BY:
# perl -n -e 'print "$2 => '"'"'$1'"'"',\n" if /define\s+(PT_\w+)\s+(PTRACE_\w+)/;' /usr/include/sys/ptrace.h
my $PTRACE_CONSTANT = {
    PTRACE_TRACEME    => 'PT_TRACE_ME',
    PTRACE_PEEKTEXT   => 'PT_READ_I',
    PTRACE_PEEKDATA   => 'PT_READ_D',
    PTRACE_PEEKUSER   => 'PT_READ_U',
    PTRACE_POKETEXT   => 'PT_WRITE_I',
    PTRACE_POKEDATA   => 'PT_WRITE_D',
    PTRACE_POKEUSER   => 'PT_WRITE_U',
    PTRACE_CONT       => 'PT_CONTINUE',
    PTRACE_KILL       => 'PT_KILL',
    PTRACE_SINGLESTEP => 'PT_STEP',
    PTRACE_GETREGS    => 'PT_GETREGS',
    PTRACE_SETREGS    => 'PT_SETREGS',
    PTRACE_GETFPREGS  => 'PT_GETFPREGS',
    PTRACE_SETFPREGS  => 'PT_SETFPREGS',
    PTRACE_ATTACH     => 'PT_ATTACH',
    PTRACE_DETACH     => 'PT_DETACH',
    PTRACE_GETFPXREGS => 'PT_GETFPXREGS',
    PTRACE_SETFPXREGS => 'PT_SETFPXREGS',
    PTRACE_SYSCALL    => 'PT_SYSCALL',
};

# Allow export for all of them
foreach ( keys %{$PTRACE_CONSTANT} ) {
    push @EXPORT_OK, $_;
}

foreach (@EXPORT_OK) {

    # Prototype constants to prepare
    # for correct entry into the AUTOLOAD
    eval "sub $_ ();" if /^PT(RACE)?_/;
}

sub AUTOLOAD {

    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.  If a constant is not found then control is passed
    # to the AUTOLOAD in AutoLoader.

    my $constname;
    ( $constname = $AUTOLOAD ) =~ s/.*:://;
    croak "& not defined" if $constname eq 'constant';
    my $function_name = $PTRACE_CONSTANT->{$constname} || $constname;
    my $val = constant( $function_name, @_ ? $_[0] : 0 );
    if ( $! != 0 ) {
        croak "Your vendor has not defined Sys::Ptrace macro $constname";
    }
    eval "sub $constname () { $val; }";
    goto &$AUTOLOAD;
}

bootstrap Sys::Ptrace $VERSION;

# Preloaded methods go here.

# Dumb wrapper function to call the internal ptrace C function.
# Returns true on success and sets $! on failure.
sub ptrace {
    my ( $request, $pid, $addr, $data ) = @_;
    $pid  ||= 0;
    $addr ||= 0;
    $data ||= 0;
    my $result = _ptrace( $request, $pid, $addr, $data );
    if (   $request == PT_READ_I()
        || $request == PT_READ_D()
        || $request == PT_READ_U() ) {
        if ( ref $data eq "SCALAR" ) {
            $$data = $result;
        }
        elsif ( @_ > 3 ) {
            $_[3] = $result;
        }
        else {
            croak 'PTRACE_PEEK* requires $data to store into';
        }
        $result = 0;
    }
    return !$result;
}

1;
__END__