168 lines
2.7 KiB
Perl
168 lines
2.7 KiB
Perl
#!/usr/bin/perl -w
|
|
|
|
package DSK;
|
|
|
|
#
|
|
# DSK.pm:
|
|
#
|
|
# Module for low level access to Apple II .DSK and .DO disk image file (DOS Order).
|
|
#
|
|
# 20190115 LSH
|
|
#
|
|
|
|
use strict;
|
|
|
|
use Exporter::Auto;
|
|
|
|
my $debug = 0;
|
|
|
|
my $min_trk = 0; # Minimum track number
|
|
my $max_trk = 34; # Maximum track number
|
|
my $min_sec = 0; # Minimum sector number
|
|
my $max_sec = 15; # Maximum sector number
|
|
my $sec_size = 256; # Sector size
|
|
|
|
#
|
|
# Read entire .dsk image.
|
|
#
|
|
sub read_dsk {
|
|
my ($dskfile) = @_;
|
|
|
|
my %dsk = ();
|
|
|
|
my $dfh;
|
|
|
|
if (open($dfh, "<$dskfile")) {
|
|
for (my $trk = 0; $trk <= $max_trk; $trk++) {
|
|
for (my $sec = 0; $sec <= $max_sec; $sec++) {
|
|
my $bytes_read = read($dfh, $dsk{$trk}{$sec}, $sec_size);
|
|
if (defined $bytes_read && $bytes_read == $sec_size) {
|
|
print '.';
|
|
} else {
|
|
print "\nError reading $trk, $sec\n";
|
|
}
|
|
}
|
|
}
|
|
print "\n";
|
|
} else {
|
|
print "Unable to open $dskfile\n";
|
|
}
|
|
|
|
return %dsk;
|
|
}
|
|
|
|
#
|
|
# Calculate position in .dsk file based on track/sector.
|
|
#
|
|
sub calc_pos {
|
|
my ($trk, $sec) = @_;
|
|
|
|
my $pos = ($trk * ($sec_size * ($max_sec + 1))) + ($sec * $sec_size);
|
|
|
|
#print "pos=$pos\n";
|
|
|
|
return $pos;
|
|
}
|
|
|
|
#
|
|
# Hex dump of sector
|
|
#
|
|
sub dump_sec {
|
|
my ($buf) = @_;
|
|
|
|
my @bytes = unpack "C$sec_size", $buf;
|
|
|
|
print " ";
|
|
for (my $c = 0; $c < 16; $c++) {
|
|
print sprintf(" %01x ", $c);
|
|
}
|
|
print "\n";
|
|
|
|
print " +------------------------------------------------\n";
|
|
|
|
for (my $r = 0; $r < 16; $r++) {
|
|
print sprintf("%01x| ", $r);
|
|
for (my $c = 0; $c < 16; $c++) {
|
|
print sprintf("%02x ", $bytes[($r * 16) + $c]);
|
|
}
|
|
print "\n";
|
|
print " |";
|
|
for (my $c = 0; $c < 16; $c++) {
|
|
my $a = $bytes[($r * 16) + $c] & 0x7f;
|
|
if (($a > 32) && ($a < 127)) {
|
|
print sprintf(" %c ", $a);
|
|
} else {
|
|
print " ";
|
|
}
|
|
}
|
|
print "\n";
|
|
}
|
|
print "\n";
|
|
}
|
|
|
|
#
|
|
# Read Track/Sector
|
|
#
|
|
sub rts {
|
|
my ($dskfile, $trk, $sec, $buf) = @_;
|
|
|
|
#print "trk=$trk sec=$sec\n";
|
|
|
|
my $dfh;
|
|
|
|
my $pos = calc_pos($trk, $sec);
|
|
|
|
if (open($dfh, "<$dskfile")) {
|
|
binmode $dfh;
|
|
|
|
seek($dfh, $pos, 0);
|
|
|
|
my $bytes_read = read($dfh, $$buf, $sec_size);
|
|
|
|
close $dfh;
|
|
|
|
if (defined $bytes_read && $bytes_read == $sec_size) {
|
|
#print "bytes_read=$bytes_read\n";
|
|
return 1;
|
|
} else {
|
|
print "Error reading $trk, $sec\n";
|
|
}
|
|
} else {
|
|
print "Unable to open $dskfile\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
#
|
|
# Write Track/Sector
|
|
#
|
|
sub wts {
|
|
my ($dskfile, $trk, $sec, $buf) = @_;
|
|
|
|
#print "trk=$trk sec=$sec\n";
|
|
|
|
my $dfh;
|
|
|
|
my $pos = calc_pos($trk, $sec);
|
|
|
|
if (open($dfh, "+<$dskfile")) {
|
|
binmode $dfh;
|
|
|
|
seek($dfh, $pos, 0);
|
|
|
|
print $dfh $buf;
|
|
|
|
close $dfh;
|
|
|
|
return 1;
|
|
} else {
|
|
print "Unable to write $dskfile\n";
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
1;
|
|
|