File Coverage

blib/lib/AppleII/Disk.pm
Criterion Covered Total %
statement 138 143 96.5
branch 46 68 67.6
condition 14 17 82.3
subroutine 30 31 96.7
pod 6 6 100.0
total 234 265 88.3


line stmt bran cond sub pod time code
1             #---------------------------------------------------------------------
2             package AppleII::Disk;
3             #
4             # Copyright 1996-2006 Christopher J. Madsen
5             #
6             # Author: Christopher J. Madsen
7             # Created: 25 Jul 1996
8             #
9             # This program is free software; you can redistribute it and/or modify
10             # it under the same terms as Perl itself.
11             #
12             # This program is distributed in the hope that it will be useful,
13             # but WITHOUT ANY WARRANTY; without even the implied warranty of
14             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
15             # GNU General Public License or the Artistic License for more details.
16             #
17             # ABSTRACT: Block-level access to Apple II disk image files
18             #---------------------------------------------------------------------
19              
20 4     4   40949 use 5.006;
  4         13  
21 4     4   18 use Carp;
  4         7  
  4         311  
22 4     4   2800 use IO::File;
  4         36739  
  4         474  
23 4     4   22 use strict;
  4         7  
  4         75  
24 4     4   18 use warnings;
  4         8  
  4         84  
25              
26 4     4   3407 use bytes;
  4         41  
  4         20  
27              
28             #=====================================================================
29             # Package Global Variables:
30              
31             our $VERSION = '0.201';
32             # This file is part of AppleII-LibA2 0.201 (September 12, 2015)
33              
34             #=====================================================================
35             # Class AppleII::Disk:
36             #
37             # Member Variables:
38             # filename: The pathname of the disk image file
39             # writable: True if the image is opened in read/write mode
40             # file: The IO::File attached to the image file
41             # actlen: The size of the image file in bytes
42             # maxlen: The maximum allowable size of the image file in bytes
43             #---------------------------------------------------------------------
44             # Constructor:
45             #
46             # Input:
47             # filename:
48             # The pathname of the image file you want to open
49             # mode:
50             # A string indicating how the image should be opened
51             # May contain any of the following characters (case sensitive):
52             # r Allow reads (this is actually ignored; you can always read)
53             # w Allow writes
54             # d Disk image is in DOS 3.3 order (default)
55             # p Disk image is in ProDOS order
56              
57             sub new
58             {
59 4     4 1 271 my ($type, $filename, $mode) = @_;
60 4         9 my $self = {};
61 4         11 $self->{filename} = $filename;
62              
63 4         60 my $file = IO::File->new;
64              
65 4 50       162 $mode = 'r' unless $mode;
66 4         7 my $openMode = '<';
67 4 50       24 if ($mode =~ /w/) {
68 4         12 $self->{writable} = 1;
69 4         7 $openMode = '+<';
70 4 100       48 $openMode = '+>' if not -e $filename; # Create empty file
71             } # end if writable
72              
73 4 50       26 $file->open($filename, $openMode) or croak("Couldn't open `$filename': $!");
74 4         306 binmode $file; # binmode didn't become a method until IO::File 1.11
75              
76 4         10 $self->{file} = $file;
77 4         26 $self->{actlen} = ($file->stat)[7]; # Get real size of file
78 4         47 $self->{maxlen} = $self->{actlen};
79              
80 4 100       17 $type = 'AppleII::Disk::ProDOS' if $mode =~ /p/;
81 4 100       12 $type = 'AppleII::Disk::DOS33' if $mode =~ /d/;
82 4 50       21 $type = (($filename =~ /\.(?:hdv|po)$/i)
    100          
83             ? 'AppleII::Disk::ProDOS'
84             : 'AppleII::Disk::DOS33')
85             if ($type eq 'AppleII::Disk');
86 4         65 bless $self, $type;
87             } # end AppleII::Disk::new
88              
89             #---------------------------------------------------------------------
90             # Pad a block of data:
91             #
92             # This is a normal subroutine, NOT a method!
93             #
94             # Input:
95             # data: The block to be padded
96             # pad: The character to pad with (default "\0") or '' for no padding
97             # length: The length to pad to (default 0x200)
98             #
99             # Returns:
100             # The BLOCK padded to LENGTH with PAD
101             # Dies if the block is too long.
102             # If PAD is the null string, dies if BLOCK is not already LENGTH.
103              
104             sub pad_block
105             {
106 32     32 1 52 my ($data, $pad, $length) = @_;
107              
108 32 50       54 $pad = "\0" unless defined $pad;
109 32   100     88 $length = $length || 0x200;
110              
111 32 100 100     129 $data .= $pad x ($length - length($data))
112             if (length($pad) and length($data) < $length);
113              
114 32 100       61 unless (length($data) == $length) {
115 1         1 local $Carp::CarpLevel = $Carp::CarpLevel;
116 1 50       7 ++$Carp::CarpLevel if (caller)[0] =~ /^AppleII::Disk::/;
117 1         232 croak(sprintf("Data block is %d bytes",length($data)));
118             }
119              
120 31         63 $data;
121             } # end AppleII::Disk::pad_block
122              
123             #---------------------------------------------------------------------
124             # Get or set the disk size:
125             #
126             # Input:
127             # size: The number of blocks in the disk image
128             # If SIZE is omitted, the disk size is not changed
129             #
130             # Returns:
131             # The number of blocks in the disk image
132              
133             sub blocks
134             {
135 6     6 1 2882 my $self = shift;
136              
137 6 100       15 if (@_) {
138 3         12 $self->{maxlen} = $_[0] * 0x200;
139             carp "Disk image contains more than $_[0] blocks"
140 3 50       11 if $self->{maxlen} < $self->{actlen};
141             }
142              
143 6         35 int($self->{maxlen} / 0x200);
144             } # end AppleII::Disk::blocks
145              
146             #---------------------------------------------------------------------
147             # Extend the image file to its full size:
148              
149             sub fully_allocate
150             {
151 0     0 1 0 my $self = shift;
152              
153 0 0       0 if ($self->{maxlen} > $self->{actlen}) {
154 0 0       0 croak("Disk image is read/only") unless $self->{writable};
155              
156 0 0       0 $self->{file}->truncate($self->{maxlen}) or croak "Can't extend file: $!";
157              
158 0         0 $self->{actlen} = $self->{maxlen};
159             } # end if file is not already at maximum size
160              
161             } # end AppleII::Disk::fully_allocate
162              
163             #---------------------------------------------------------------------
164             # Read a ProDOS block:
165             #
166             # Input:
167             # block: The block number to read
168             #
169             # Returns:
170             # A 512 byte block
171             #
172             # Implemented in AppleII::Disk::ProDOS & AppleII::Disk::DOS33
173             #
174             # sub read_block
175              
176             #---------------------------------------------------------------------
177             # Read a series of ProDOS blocks:
178             #
179             # As a special case, block 0 cannot be read by this method. Instead,
180             # it returns a block full of 0 bytes. This is how sparse files are
181             # implemented. If you want to read the actual contents of block 0,
182             # you must call $disk->read_block(0) directly.
183             #
184             # Input:
185             # blocks: An array of block numbers to read
186             #
187             # Returns:
188             # The data from the disk (512 bytes times the number of blocks)
189              
190             sub read_blocks
191             {
192 10     10 1 17 my ($self, $blocks) = @_;
193 10         16 my $data = '';
194 10         23 foreach (@$blocks) {
195 1044 100       1445 if ($_) { $data .= $self->read_block($_) }
  24         51  
196 1020         1678 else { $data .= "\0" x 0x200 } # Sparse block
197             }
198 10         432 $data;
199             } # end AppleII::Disk::read_blocks
200              
201             #---------------------------------------------------------------------
202             # Read a DOS 3.3 sector:
203             #
204             # Input:
205             # track: The track number to read
206             # sector: The sector number to read
207             #
208             # Returns:
209             # A 256 byte sector
210             #
211             # Implemented in AppleII::Disk::ProDOS & AppleII::Disk::DOS33
212             #
213             # sub read_sector
214              
215             #---------------------------------------------------------------------
216             # Write a ProDOS block:
217             #
218             # Input:
219             # block: The block number to read
220             # data: The contents of the block
221             # pad: A character to pad the block with (optional)
222             # If PAD is omitted, an error is generated if data is not 512 bytes
223             #
224             # Implemented in AppleII::Disk::ProDOS & AppleII::Disk::DOS33
225             #
226             # sub write_block
227              
228             #---------------------------------------------------------------------
229             # Write a series of ProDOS blocks:
230             #
231             # As a special case, block 0 cannot be written by this method.
232             # Instead, that block is just skipped. This is how sparse files are
233             # implemented. If you want to write the contents of block 0, you must
234             # call $disk->write_block directly.
235             #
236             # Input:
237             # blocks: An array of the block numbers to write to
238             # data: The data to write (must be exactly the right size)
239             # pad: A character to pad the last block with (optional)
240              
241             sub write_blocks
242             {
243 5     5 1 11 my ($self, $blocks, $data, $pad) = @_;
244 5         7 my $index = 0;
245 5         12 foreach (@$blocks) {
246 271 100       413 $self->write_block($_, substr($data, $index, 0x200), $pad) if $_;
247 271         385 $index += 0x200;
248             }
249             } # end AppleII::Disk::write_blocks
250              
251             #---------------------------------------------------------------------
252             # Write a DOS 3.3 sector:
253             #
254             # Input:
255             # track: The track number to read
256             # sector: The sector number to read
257             # data: The contents of the sector
258             # pad: The value to pad the sector with (optional)
259             # If PAD is omitted, an error is generated if data is not 256 bytes
260             #
261             # Implemented in AppleII::Disk::ProDOS & AppleII::Disk::DOS33
262             #
263             # sub write_sector
264              
265             #=====================================================================
266             package AppleII::Disk::ProDOS;
267             #
268             # Handle ProDOS-order disk images
269             #---------------------------------------------------------------------
270              
271 4     4   2893 use Carp;
  4         5  
  4         197  
272 4     4   19 use bytes;
  4         6  
  4         105  
273 4     4   2879 use integer;
  4         36  
  4         24  
274 4     4   110 use strict;
  4         7  
  4         76  
275 4     4   16 use warnings;
  4         7  
  4         1226  
276              
277             our @ISA = qw(AppleII::Disk);
278              
279             #---------------------------------------------------------------------
280             # Read a block from a ProDOS order disk:
281             #
282             # See AppleII::Disk::read_block
283              
284             sub read_block
285             {
286 56     56   2393 my $self = shift;
287              
288             return "\0" x 0x200
289 56 100       123 if $self->seek_block($_[0]) >= $self->{actlen}; # Past EOF
290 54         73 my $buffer = '';
291 54 50       483 read($self->{file},$buffer,0x200) or die;
292              
293 54         653 $buffer;
294             } # end AppleII::Disk::ProDOS::read_block
295              
296             #---------------------------------------------------------------------
297             # FIXME AppleII::Disk::ProDOS::read_sector not implemented yet
298              
299             #---------------------------------------------------------------------
300             # Seek to the beginning of a block:
301             #
302             # Input:
303             # block: The block number to seek to
304             #
305             # Returns:
306             # The new position of the file pointer
307              
308             sub seek_block
309             {
310 76     76   105 my ($self, $block) = @_;
311              
312 76         95 my $pos = $block * 0x200;
313             croak("Invalid block number $block")
314 76 100 66     455 if $pos < 0 or $pos >= $self->{maxlen};
315              
316 75 50       228 $self->{file}->seek($pos,0) or die;
317              
318 75         817 $pos;
319             } # end AppleII::Disk::ProDOS::seek_block
320              
321             #---------------------------------------------------------------------
322             # Write a block from a ProDOS order disk:
323             #
324             # See AppleII::Disk::write_block
325              
326             sub write_block
327             {
328 21     21   54 my ($self, $block, $data, $pad) = @_;
329 21 50       50 croak("Disk image is read/only") unless $self->{writable};
330              
331 21   100     65 $data = AppleII::Disk::pad_block($data, $pad || '');
332              
333 20         49 my $pos = $self->seek_block($block);
334 20 50       25 print {$self->{file}} $data or die;
  20         67  
335              
336 20 100       69 $self->{actlen} = $pos + 0x200 unless $self->{actlen} > $pos;
337             } # end AppleII::Disk::ProDOS::write_block
338              
339             #=====================================================================
340             package AppleII::Disk::DOS33;
341             #
342             # Handle DOS 3.3-order disk images
343             #---------------------------------------------------------------------
344              
345             #$debug = 1;
346              
347 4     4   21 use Carp;
  4         7  
  4         196  
348 4     4   17 use bytes;
  4         6  
  4         14  
349 4     4   87 use integer;
  4         8  
  4         12  
350 4     4   72 use strict;
  4         6  
  4         75  
351 4     4   20 use warnings;
  4         15  
  4         2191  
352              
353             our @ISA = qw(AppleII::Disk);
354              
355             #---------------------------------------------------------------------
356             # Convert ProDOS block number to track & sectors:
357              
358             { my @sector1 = ( 0, 13, 11, 9, 7, 5, 3, 1);
359             my @sector2 = (14, 12, 10, 8, 6, 4, 2, 15);
360              
361             sub block2sector
362             {
363 4     4   6 my $block = shift;
364 4         5 my $offset = $block % 8;
365              
366 4         11 ($block/8, $sector1[$offset], $sector2[$offset]); # INTEGER division
367             } # end block2sector
368             }
369              
370             #---------------------------------------------------------------------
371             # Read a block from a DOS 3.3 order disk:
372             #
373             # See AppleII::Disk::read_block
374              
375             sub read_block
376             {
377 3     3   418 my ($self, $block) = @_;
378 3         7 my ($track, $sector1, $sector2) = block2sector($block);
379              
380 3         8 $self->read_sector($track,$sector1) . $self->read_sector($track,$sector2);
381             } # end AppleII::Disk::DOS33::read_block
382              
383             #---------------------------------------------------------------------
384             # Read a DOS 3.3 sector:
385             #
386             # See AppleII::Disk::read_sector
387              
388             sub read_sector
389             {
390 7     7   983 my $self = shift;
391             return "\0" x 0x100
392 7 100       20 if $self->seek_sector(@_[0..1]) >= $self->{actlen}; # Past EOF
393 4         6 my $buffer = '';
394 4 50       61 read($self->{file},$buffer,0x100) or die;
395              
396 4         19 $buffer;
397             } # end AppleII::Disk::DOS33::read_sector
398              
399             #---------------------------------------------------------------------
400             # Seek to the beginning of a sector:
401             #
402             # Input:
403             # track: The track number to seek to
404             # sector: The sector number to seek to
405             #
406             # Returns:
407             # The new position of the file pointer
408              
409             sub seek_sector
410             {
411 13     13   19 my ($self, $track, $sector) = @_;
412              
413 13         22 my $pos = $track * 0x1000 + $sector * 0x100;
414             croak("Invalid position track $track sector $sector")
415 13 100 66     245 if $pos < 0 or $pos >= $self->{maxlen};
416              
417 12 50       43 $self->{file}->seek($pos,0) or die;
418 12         222 $pos;
419             } # end AppleII::Disk::DOS33::seek_sector
420              
421             #---------------------------------------------------------------------
422             # Write a sector to a DOS 3.3 order image:
423             #
424             # See AppleII::Disk::write_sector
425              
426             sub write_sector
427             {
428 6     6   1307 my ($self, $track, $sector, $data, $pad) = @_;
429 6 50       14 croak("Disk image is read/only") unless $self->{writable};
430              
431 6   100     23 $data = AppleII::Disk::pad_block($data, $pad || '', 0x100);
432              
433 6         12 my $pos = $self->seek_sector($track, $sector);
434 6 50       10 print {$self->{file}} $data or die;
  6         30  
435              
436 6 100       22 $self->{actlen} = $pos + 0x100 unless $self->{actlen} > $pos;
437             } # end AppleII::Disk::DOS33::write_sector
438              
439             #---------------------------------------------------------------------
440             # Write a block to a DOS33 order disk:
441             #
442             # See AppleII::Disk::write_block
443              
444             sub write_block
445             {
446 1     1   513 my ($self, $block, $data, $pad) = @_;
447 1 50       4 croak("Disk image is read/only") unless $self->{writable};
448 1         3 my ($track, $sector1, $sector2) = block2sector($block);
449              
450 1   50     7 $data = AppleII::Disk::pad_block($data, $pad || '');
451              
452 1         6 $self->write_sector($track, $sector1, substr($data,0,0x100));
453 1         5 $self->write_sector($track, $sector2, substr($data,0x100,0x100));
454             } # end AppleII::Disk::DOS33::write_block
455              
456             #=====================================================================
457             # Package Return Value:
458              
459             1;
460              
461             __END__