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__ |