File Coverage

blib/lib/PeekPoke/FFI.pm
Criterion Covered Total %
statement 30 30 100.0
branch 2 2 100.0
condition 6 7 85.7
subroutine 9 9 100.0
pod 3 3 100.0
total 50 51 98.0


line stmt bran cond sub pod time code
1             package PeekPoke::FFI;
2              
3 1     1   228839 use strict;
  1         7  
  1         29  
4 1     1   5 use warnings;
  1         2  
  1         22  
5 1     1   23 use 5.008001;
  1         3  
6 1     1   690 use FFI::Platypus 1.00;
  1         6788  
  1         33  
7 1     1   7 use base qw( Exporter );
  1         2  
  1         452  
8              
9             our @EXPORT_OK = qw( peek poke );
10              
11             # ABSTRACT: Perl extension for reading and writing to arbitrary memory locations
12             our $VERSION = '0.01'; # VERSION
13              
14              
15             my $ffi = FFI::Platypus->new( api => 1, lib => [undef], lang => 'C' );
16              
17              
18             sub new
19             {
20 2     2 1 4402 my($class, %opts) = @_;
21              
22 2   100     11 my $base = $opts{base} || 0;
23 2   100     7 my $type = $opts{type} || 'uint8';
24 2         8 my $size = $ffi->sizeof($type);
25 2         86 my $memcpy = $ffi->function( memcpy => [ 'opaque', "${type}[1]", 'size_t' ] => 'opaque' );
26              
27 2         489 bless {
28             base => $base,
29             type => $type,
30             size => $size,
31             memcpy => $memcpy,
32             }, $class;
33              
34             }
35              
36             my $default;
37              
38             sub _self
39             {
40 4     4   9 my $args = shift;
41 4 100       11 if(ref $args->[0])
42             {
43 2         19 return shift @$args;
44             }
45             else
46             {
47 2   66     15 return $default ||= __PACKAGE__->new;
48             }
49             }
50              
51              
52             sub peek
53             {
54 2     2 1 16623 my $self = _self(\@_);
55 2         6 my($offset) = @_;
56 2         11 $ffi->cast('opaque' => $self->{type} . '[1]', $self->{base} + $offset * $self->{size})->[0];
57             }
58              
59              
60             sub poke
61             {
62 2     2 1 1266 my $self = _self(\@_);
63 2         5 my($offset, $value) = @_;
64 2         24 $self->{memcpy}->call($self->{base} + $offset * $self->{size}, [$value], 1);
65             }
66              
67             1;
68              
69             __END__