File Coverage

blib/lib/CPU/Z80/Disassembler/Memory.pm
Criterion Covered Total %
statement 127 127 100.0
branch 44 44 100.0
condition 24 25 96.0
subroutine 34 34 100.0
pod 19 19 100.0
total 248 249 99.6


line stmt bran cond sub pod time code
1             package CPU::Z80::Disassembler::Memory;
2              
3             #------------------------------------------------------------------------------
4              
5             =head1 NAME
6              
7             CPU::Z80::Disassembler::Memory - Memory representation for Z80 disassembler
8              
9             =cut
10              
11             #------------------------------------------------------------------------------
12              
13 8     8   923 use strict;
  8         15  
  8         208  
14 8     8   36 use warnings;
  8         14  
  8         184  
15              
16 8     8   36 use Carp; our @CARP_NOT; # do not report errors in this package
  8         13  
  8         472  
17 8     8   2639 use File::Slurp;
  8         134269  
  8         487  
18 8     8   2844 use Bit::Vector;
  8         6666  
  8         350  
19              
20 8     8   3294 use CPU::Z80::Disassembler::Format;
  8         19  
  8         581  
21              
22             our $VERSION = '1.02';
23              
24             #------------------------------------------------------------------------------
25              
26             =head1 SYNOPSIS
27              
28             use CPU::Z80::Disassembler::Memory;
29             $mem = CPU::Z80::Disassembler::Memory->new;
30            
31             $mem->load_file($file_name, $addr, $opt_skip_bytes, $opt_length);
32             $it = $mem->loaded_iter(); while (($min,$max) = $it->()) {}
33            
34             $byte = $mem->peek8u($addr); $byte = $mem->peek($addr);
35             $byte = $mem->peek8s($addr);
36            
37             $word = $mem->peek16u($addr);
38             $word = $mem->peek16s($addr);
39            
40             $str = $mem->peek_str( $addr, $length);
41             $str = $mem->peek_strz($addr);
42             $str = $mem->peek_str7($addr);
43            
44             $mem->poke8u($addr, $byte); $mem->poke($addr, $byte);
45             $mem->poke8s($addr, $byte);
46            
47             $mem->poke16u($addr, $word);
48             $mem->poke16s($addr, $word);
49            
50             $mem->poke_str( $addr, $str);
51             $mem->poke_strz($addr, $str);
52             $mem->poke_str7($addr, $str);
53              
54             =head1 DESCRIPTION
55              
56             This module represents a memory segment being diassembled.
57              
58             =head1 FUNCTIONS
59              
60             =head2 new
61              
62             Creates a new empty object.
63              
64             =cut
65              
66             #------------------------------------------------------------------------------
67 8     8   46 use base 'Class::Accessor';
  8         13  
  8         6482  
68             __PACKAGE__->mk_accessors(
69             '_mem', # string of 64 Kbytes
70             '_loaded', # Bit::Vector, one bit per address, 1 if byte loaded
71             );
72              
73             sub new {
74 53     53 1 5558 my($class) = @_;
75 53         2601 my $loaded = Bit::Vector->new(0x10000);
76 53         2420 my $mem = "\0" x $loaded->Size;
77 53         448 return bless { _mem => $mem, _loaded => $loaded }, $class;
78             }
79              
80             #------------------------------------------------------------------------------
81             # check ranges
82              
83             sub _check_addr {
84 690877     690877   957318 my($self, $addr) = @_;
85 690877 100 100     1612059 croak("address ".format_hex($addr)." out of range")
86             if ($addr < 0 || $addr >= $self->_loaded->Size);
87             }
88              
89             sub _check_value8u {
90 30621     30621   50316 my($self, $byte) = @_;
91 30621 100 100     90668 croak("unsigned byte ".format_hex($byte)." out of range")
92             if ($byte < 0 || $byte > 0xFF);
93             }
94              
95             sub _check_value8s {
96 9     9   14 my($self, $byte) = @_;
97 9 100 100     35 croak("signed byte ".format_hex($byte)." out of range")
98             if ($byte < -0x80 || $byte > 0x7F);
99             }
100              
101             sub _check_value16u {
102 12     12   17 my($self, $word) = @_;
103 12 100 100     36 croak("unsigned word ".format_hex($word)." out of range")
104             if ($word < 0 || $word > 0xFFFF);
105             }
106              
107             sub _check_value16s {
108 9     9   13 my($self, $word) = @_;
109 9 100 100     46 croak("signed word ".format_hex($word)." out of range")
110             if ($word < -0x8000 || $word > 0x7FFF);
111             }
112              
113             sub _check_strz {
114 7     7   11 my($self, $str) = @_;
115 7 100       94 croak("invalid zero character in string")
116             if $str =~ /\0/;
117             }
118              
119             sub _check_str7 {
120 8     8   15 my($self, $str) = @_;
121 8 100       87 croak("invalid empty string") if length($str) < 1;
122 7 100       104 croak("invalid bit-7 set character in string")
123             if $str =~ /[\x80-\xFF]/;
124             }
125              
126             #------------------------------------------------------------------------------
127              
128             =head2 load_file
129              
130             Loads a binary file to the memory.
131             The argument C<$addr> indicates where in the memory to load the file, and defaults to 0.
132             The argument C<$opt_skip_bytes> indicates how many bytes to skip from the start
133             of the binary file and defaults to 0.
134             This is useful to read C<.SNA> ZX Spectrum Snapshot Files which have a header of 27 bytes.
135             The argument C<$opt_length> limits the number of bytes to read to memory and
136             defaults to all the file after the header.
137              
138             =cut
139              
140             #------------------------------------------------------------------------------
141             sub load_file {
142 27     27 1 293 my($self, $file_name, $addr, $opt_skip_bytes, $opt_length) = @_;
143            
144 27         123 my $bytes = read_file($file_name, binmode => ':raw');
145 26   100     3725 $addr ||= 0;
146 26   100     145 $opt_skip_bytes ||= 0;
147 26   66     129 $opt_length ||= length($bytes) - $opt_skip_bytes;
148            
149 26         131 $self->poke_str($addr, substr($bytes, $opt_skip_bytes, $opt_length));
150             }
151             #------------------------------------------------------------------------------
152              
153             =head2 loaded_iter
154              
155             Returns an iterator to return each block of consecutive loaded addresses.
156             C<$min> is the first address of the consecutive block, C<$max> is last address
157             of the block.
158              
159             =cut
160              
161             #------------------------------------------------------------------------------
162             sub loaded_iter {
163 44     44 1 434 my($self) = @_;
164 44         120 my $loaded = $self->_loaded;
165 44         386 my $start = 0;
166            
167             return sub {
168 81   100 81   958 while ( $start < $loaded->Size &&
169             (my($min,$max) = $loaded->Interval_Scan_inc($start)) ) {
170 37         76 $start = $max + 2; # start after the 0 after $max
171 37         188 return ($min, $max);
172             }
173 44         572 return (); # no more blocks
174 44         355 };
175             }
176             #------------------------------------------------------------------------------
177              
178             =head2 peek, peek8u
179              
180             Retrieves the byte (0 .. 255) from the given address.
181             Returns C if the memory at that address was not loaded.
182              
183             =cut
184              
185             #------------------------------------------------------------------------------
186             sub peek8u {
187 660144     660144 1 1036465 my($self, $addr) = @_;
188 660144         1306095 $self->_check_addr($addr);
189             return $self->_loaded->bit_test($addr) ?
190 660128 100       6465478 ord(substr($self->{_mem}, $addr, 1)) :
191             undef;
192             }
193 604973     604973 1 4618937 sub peek { goto &peek8u }
194             #------------------------------------------------------------------------------
195              
196             =head2 peek8s
197              
198             Same as C, but treats byte as signed (-128 .. 127).
199              
200             =cut
201              
202             #------------------------------------------------------------------------------
203             sub peek8s {
204 8380     8380 1 15381 my($self, $addr) = @_;
205 8380         13073 my $byte = $self->peek8u($addr);
206 8378 100       76603 return undef unless defined $byte;
207 8375 100       16087 $byte -= 0x100 if $byte & 0x80;
208 8375         21090 return $byte;
209             }
210             #------------------------------------------------------------------------------
211              
212             =head2 peek16u
213              
214             Retrieves the two-byte word (0 .. 65535) from the given address, least
215             significant first (little-endian).
216             Returns C if the memory at any of the two addresses was not loaded.
217              
218             =cut
219              
220             #------------------------------------------------------------------------------
221             sub peek16u {
222 10841     10841 1 20500 my($self, $addr) = @_;
223 10841 100       18048 my $lo = $self->peek($addr++); return undef unless defined $lo;
  10837         100462  
224 10832 100       19265 my $hi = $self->peek($addr++); return undef unless defined $hi;
  10832         99873  
225 10830         30130 return ($hi << 8) | $lo;
226             }
227             #------------------------------------------------------------------------------
228              
229             =head2 peek16s
230              
231             Same as C, but treats word as signed (-32768 .. 32767).
232              
233             =cut
234              
235             #------------------------------------------------------------------------------
236             sub peek16s {
237 6     6 1 1861 my($self, $addr) = @_;
238 6         14 my $word = $self->peek16u($addr);
239 4 100       14 return undef unless defined $word;
240 2 100       8 $word -= 0x10000 if $word & 0x8000;
241 2         9 return $word;
242             }
243             #------------------------------------------------------------------------------
244              
245             =head2 peek_str
246              
247             Retrieves a string from the given address with the given length.
248             Returns C if the memory at any of the addresses was not loaded.
249              
250             =cut
251              
252             #------------------------------------------------------------------------------
253             sub peek_str {
254 99     99 1 1628 my($self, $addr, $length) = @_;
255 99 100       300 croak("invalid length $length") if $length < 1;
256 98         153 my $str = "";
257 98         226 while ($length-- > 0) {
258 167         346 my $byte = $self->peek8u($addr++);
259 165 100       1754 return undef unless defined $byte;
260 160         390 $str .= chr($byte);
261             }
262 91         262 return $str;
263             }
264             #------------------------------------------------------------------------------
265              
266             =head2 peek_strz
267              
268             Retrieves a zero-terminated string from the given address. The returned string
269             does not include the final zero byte.
270             Returns C if the memory at any of the addresses was not loaded.
271              
272             =cut
273              
274             #------------------------------------------------------------------------------
275             sub peek_strz {
276 9     9 1 1814 my($self, $addr) = @_;
277 9         17 my $str = "";
278 9         15 while (1) {
279 55         153 my $byte = $self->peek8u($addr++);
280 53 100       537 return undef unless defined $byte;
281 48 100       101 return $str if $byte == 0;
282 46         72 $str .= chr($byte);
283             }
284             }
285             #------------------------------------------------------------------------------
286              
287             =head2 peek_str7
288              
289             Retrieves a bit-7-set-terminated string from the given address.
290             This string has all characters with bit 7 reset, execept the last character,
291             where bit 7 is set. The returned string has bit 7 reset in all characters.
292             Returns C if the memory at any of the addresses was not loaded.
293              
294             =cut
295              
296             #------------------------------------------------------------------------------
297             sub peek_str7 {
298 137     137 1 2038 my($self, $addr) = @_;
299 137         205 my $str = "";
300 137         204 while (1) {
301 964         1781 my $byte = $self->peek8u($addr++);
302 962 100       9268 return undef unless defined $byte;
303 957         1514 $str .= chr($byte & 0x7F); # clear bit 7
304 957 100       1768 return $str if $byte & 0x80; # bit 7 set
305             }
306             }
307             #------------------------------------------------------------------------------
308              
309             =head2 poke, poke8u
310              
311             Stores the unsigned byte (0 .. 255) at the given address,
312             and signals that the address was loaded.
313              
314             =cut
315              
316             #------------------------------------------------------------------------------
317             sub poke8u {
318 30627     30627 1 56835 my($self, $addr, $byte) = @_;
319 30627         64350 $self->_check_addr($addr);
320 30621         319832 $self->_check_value8u($byte);
321 30617         68494 substr($self->{_mem}, $addr, 1) = chr($byte);
322 30617         57197 $self->_loaded->Bit_On($addr);
323             }
324 30591     30591 1 291459 sub poke { goto &poke8u }
325             #------------------------------------------------------------------------------
326              
327             =head2 poke8s
328              
329             Same as C, but treats byte as signed (-128 .. 127).
330              
331             =cut
332              
333             #------------------------------------------------------------------------------
334             sub poke8s {
335 9     9 1 1793 my($self, $addr, $byte) = @_;
336 9         21 $self->_check_value8s($byte);
337 7         17 $self->poke8u($addr, $byte & 0xFF);
338             }
339             #------------------------------------------------------------------------------
340              
341             =head2 poke16u
342              
343             Stores the two-byte word (0 .. 65535) at the given address, least
344             significant first (little-endian),
345             and signals that the address was loaded.
346              
347             =cut
348              
349             #------------------------------------------------------------------------------
350             sub poke16u {
351 16     16 1 2786 my($self, $addr, $word) = @_;
352 16         34 $self->_check_addr($addr);
353 12         148 $self->_check_value16u($word);
354 10         24 $self->poke8u($addr++, $word & 0xFF);
355 10         87 $self->poke8u($addr++, ($word >> 8) & 0xFF);
356             }
357             #------------------------------------------------------------------------------
358              
359             =head2 poke16s
360              
361             Same as C, but treats word as signed (-32768 .. 32767).
362              
363             =cut
364              
365             #------------------------------------------------------------------------------
366             sub poke16s {
367 9     9 1 2748 my($self, $addr, $word) = @_;
368 9         21 $self->_check_value16s($word);
369 7         14 $self->poke16u($addr, $word & 0xFFFF);
370             }
371             #------------------------------------------------------------------------------
372              
373             =head2 poke_str
374              
375             Stores the string at the given start address,
376             and signals that the addresser were loaded.
377              
378             =cut
379              
380             #------------------------------------------------------------------------------
381             sub poke_str {
382 50     50 1 3816 my($self, $addr, $str) = @_;
383 50         152 $self->_check_addr($addr);
384              
385 41 100       695 if (length($str) > 0) {
386 40         87 my $end_addr = $addr + length($str) - 1;
387 40         100 $self->_check_addr($end_addr);
388            
389 38         464 substr($self->{_mem}, $addr, length($str)) = $str;
390 38         88 $self->_loaded->Interval_Fill($addr, $end_addr);
391             }
392             }
393             #------------------------------------------------------------------------------
394              
395             =head2 poke_strz
396              
397             Stores the string at the given start address, and adds a zero byte,
398             and signals that the addresses were loaded.
399              
400             =cut
401              
402             #------------------------------------------------------------------------------
403             sub poke_strz {
404 7     7 1 1177 my($self, $addr, $str) = @_;
405 7         17 $self->_check_strz($str);
406 6         50 $self->poke_str($addr, $str.chr(0));
407             }
408             #------------------------------------------------------------------------------
409              
410             =head2 poke_str7
411              
412             Stores the string at the given start address and sets the bit 7 of the
413             last character,
414             and signals that the addresses were loaded.
415              
416             =cut
417              
418             #------------------------------------------------------------------------------
419             sub poke_str7 {
420 8     8 1 1779 my($self, $addr, $str) = @_;
421 8         17 $self->_check_str7($str);
422 6         16 substr($str, -1, 1) = chr(ord(substr($str, -1, 1)) | 0x80); # set bit 7
423 6         11 $self->poke_str($addr, $str);
424             }
425             #------------------------------------------------------------------------------
426              
427             =head1 AUTHOR, BUGS, FEEDBACK, LICENSE AND COPYRIGHT
428              
429             See L.
430              
431             =cut
432              
433             #------------------------------------------------------------------------------
434              
435             1;