File Coverage

blib/lib/Proc/Memory.pm
Criterion Covered Total %
statement 57 68 83.8
branch 12 22 54.5
condition 1 5 20.0
subroutine 14 16 87.5
pod 5 7 71.4
total 89 118 75.4


line stmt bran cond sub pod time code
1 3     3   169145 use strict;
  3         6  
  3         75  
2 3     3   14 use warnings;
  3         3  
  3         136  
3             package Proc::Memory;
4              
5             # ABSTRACT: Peek/Poke other processes' address spaces
6             our $VERSION = '0.009'; # VERSION
7              
8 3     3   16 use Carp;
  3         7  
  3         162  
9 3     3   1036 use Sentinel;
  3         2167  
  3         128  
10 3     3   19 use Scalar::Util 'looks_like_number';
  3         5  
  3         135  
11 3     3   599 use Alien::libvas;
  3         97809  
  3         24  
12 3         18 use Inline 'C' => 'DATA' =>
13 3     3   20532 enable => 'autowrap';
  3         40212  
14 3     3   358 use Inline 0.56 with => 'Alien::libvas';
  3         65  
  3         15  
15              
16             =pod
17              
18             =encoding utf8
19              
20             =head1 NAME
21              
22             Proc::Memory - Peek/Poke into processes' address spaces
23              
24             =head1 SYNOPSIS
25              
26             use Proc::Memory;
27              
28             my $mem = Proc::Memory->new(pid => $$);
29              
30             my $byte = $mem->peek(0x1000);
31             my $u32 = $mem->read(0x1000, 4);
32             $mem->poke(0x1000, 'L') = 12;
33              
34              
35             =head1 DESCRIPTION
36              
37             PEEK/POKE are a BASIC programming language extension for reading and writing memory at a specified address across process boundaries. This module brings similiar capability to Perl.
38              
39             Eventually, Memory searching capability will also be added.
40              
41             =head1 IMPLEMENTATION
42              
43             The module is a Perlish wrapper for L and doesn't expose any extra functionality. L claims support for following backends:
44              
45             • win32 - Windows API's {Read,Write}ProcessMemory
46             • mach - Mach Virtual Memory API (vm_copy) - macOS and GNU Hurd
47             • process_vm - process_vm_{readv, writev} on Linux 3.2+
48             • procfs - /proc/$pid/mem on Linux and some BSDs, /proc/$pid/as on SunOS
49             • ptrace - ptrace(2), available on many Unices
50             • memcpy - Trivial implementation that doesn't supports foreign address spaces
51              
52             Bug reports and contributions are welcome. :-)
53              
54             =head1 METHODS AND ARGUMENTS
55              
56             =over 4
57              
58             =item new(pid)
59              
60             Constructs a new Proc::Memory instance.
61              
62             =cut
63              
64             sub new {
65 3     3 1 2154558 my $class = shift;
66 3         24 my @opts = @_;
67 3 100       22 unshift @opts, 'pid' if @_ % 2 == 1;
68              
69 3         16 my $self = {
70             @opts
71             };
72              
73             looks_like_number $self->{pid}
74 3 50       24 or croak q/Pid isn't numeric/;
75              
76             $self->{vas} = xs_vas_open($self->{pid}, 0)
77 3 50       32 or do {
78 0 0       0 if (kill 0, $self->{pid}) {
79 0         0 croak "PID doesn't exist"
80             } else {
81 0         0 croak "Process access permission denied"
82             }
83             };
84              
85 3         8 bless $self, $class;
86 3         14 return $self;
87             }
88              
89             =item peek(addr [, 'pack-string'])
90              
91             Peeks at the given memory address. C defaults to C<'C'> (A single byte)
92              
93             =cut
94              
95             sub peek {
96 0     0 1 0 my $self = shift;
97 0         0 my $addr = shift;
98 0   0     0 my $fmt = shift // 'C';
99 0 0       0 $fmt eq 'C'
100             or croak 'Pack strings not supported yet';
101              
102 0         0 my $buf = xs_vas_read($self->{vas}, $addr, 1);
103 0         0 return $buf;
104             }
105              
106              
107              
108             =item poke(addr [, 'pack-string']) = $value # or = ($a, $b)
109              
110             Pokes a given memory address. If no pack-string is given, the rvalue is written as is
111              
112             =cut
113              
114             sub get_poke {
115 0     0 0 0 carp 'Useless use of poke';
116 0         0 undef;
117             }
118             sub set_poke {
119 3     3 0 9 my @args = @{+shift};
  3         10  
120 3         10 my $self = shift @args;
121 3         7 my $buf = shift;
122 3 50       17 my $addr = shift @args or croak 'Address must be specified';
123 3 100       13 if (my $fmt = shift @args) {
124 2 100       19 $buf = pack($fmt, ref($buf) eq 'ARRAY' ? @{$buf} : $buf);
  1         7  
125             }
126              
127 3         44 my $nbytes = xs_vas_write($self->{vas}, $addr, $buf, length $buf);
128 3 50       20 return $nbytes >= 0 ? $nbytes : undef;
129             }
130              
131             sub poke :lvalue {
132 3 50   3 1 5984 defined wantarray or croak 'Useless use of poke';
133 3         36 sentinel obj => [@_], get => \&get_poke, set => \&set_poke
134             }
135              
136             =item read(addr, size)
137              
138             Reads size bytes from given memory address.
139              
140             =cut
141              
142             #SV *xs_vas_read(void* vas, unsigned long src, size_t size) {
143             sub read {
144 3     3 1 8602 my $self = shift;
145 3         5 my $addr = shift;
146 3         5 my $size = shift;
147              
148 3         26 my $buf = xs_vas_read($self->{vas}, $addr, $size);
149 3         7 return $buf;
150             }
151              
152             =item write(addr, buf [, count])
153              
154             Writes C to C
155              
156             =cut
157              
158             #int xs_vas_write(void* vas, unsigned long dst, SV *sv) {
159             sub write {
160 1     1 1 3328 my $self = shift;
161 1         1 my $addr = shift;
162 1         2 my $buf = shift;
163 1   33     10 my $bytes = shift || length $buf;
164              
165 1         9 my $nbytes = xs_vas_write($self->{vas}, $addr, $buf, $bytes);
166 1 50       5 return $nbytes >= 0 ? $nbytes : undef;
167             }
168              
169             =item tie(addr, 'pack-string')
170              
171             Returns a tied variable which can be used like any other variable.
172             To be implemented
173              
174             =cut
175              
176             =item search('pack-string')
177              
178             To be implemented when libvas provides it
179              
180             =cut
181              
182              
183              
184             sub DESTROY {
185 3     3   8693 my $self = shift;
186 3         194 xs_vas_close($self->{vas});
187             }
188              
189             Inline->init();
190             1;
191              
192             =back
193              
194             =head1 GIT REPOSITORY
195              
196             L
197              
198             =head1 SEE ALSO
199              
200             L
201             L
202              
203             =head1 AUTHOR
204              
205             Ahmad Fatoum C<< >>, L
206              
207             =head1 COPYRIGHT AND LICENSE
208              
209             Copyright (C) 2016 Ahmad Fatoum
210              
211             This library is free software; you can redistribute it and/or modify
212             it under the same terms as Perl itself.
213              
214             =cut
215              
216             __DATA__