Moved to ProDOS
This commit is contained in:
parent
6d1bcaf499
commit
11b796d35e
169
PO.pm
169
PO.pm
|
@ -1,169 +0,0 @@
|
||||||
#!/usr/bin/perl -w
|
|
||||||
|
|
||||||
package PO;
|
|
||||||
|
|
||||||
#
|
|
||||||
# PO.pm:
|
|
||||||
#
|
|
||||||
# Module for low level access to Apple II .PO disk images (ProDOS Order)
|
|
||||||
#
|
|
||||||
# 20190115 LSH
|
|
||||||
#
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
|
|
||||||
use Exporter::Auto;
|
|
||||||
|
|
||||||
my $debug = 0;
|
|
||||||
|
|
||||||
my $min_blk = 0; # Minimum block number
|
|
||||||
my $max_blk = 280; # Maximum block number
|
|
||||||
my $blk_size = 512; # Block size
|
|
||||||
|
|
||||||
#
|
|
||||||
# Read entire .po image.
|
|
||||||
#
|
|
||||||
sub read_po {
|
|
||||||
my ($pofile) = @_;
|
|
||||||
|
|
||||||
my %po = ();
|
|
||||||
|
|
||||||
my $dfh;
|
|
||||||
|
|
||||||
if (open($dfh, "<$pofile")) {
|
|
||||||
for (my $blk = 0; $blk <= $max_blk; $blk++) {
|
|
||||||
my $bytes_read = read($dfh, $po{$blk}, $blk_size);
|
|
||||||
if (defined $bytes_read && $bytes_read == $blk_size) {
|
|
||||||
print '.';
|
|
||||||
} else {
|
|
||||||
print "\nError reading $blk\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
print "\n";
|
|
||||||
} else {
|
|
||||||
print "Unable to open $pofile\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
return %po;
|
|
||||||
}
|
|
||||||
|
|
||||||
#
|
|
||||||
# Calculate position in .po file based on block.
|
|
||||||
#
|
|
||||||
sub calc_pos {
|
|
||||||
my ($blk) = @_;
|
|
||||||
|
|
||||||
my $pos = $blk * $blk_size;
|
|
||||||
|
|
||||||
#print "pos=$pos\n";
|
|
||||||
|
|
||||||
return $pos;
|
|
||||||
}
|
|
||||||
|
|
||||||
#
|
|
||||||
# Hex dump of block
|
|
||||||
#
|
|
||||||
sub dump_blk {
|
|
||||||
my ($buf) = @_;
|
|
||||||
|
|
||||||
my @bytes = unpack "C$blk_size", $buf;
|
|
||||||
|
|
||||||
print " ";
|
|
||||||
for (my $c = 0; $c < 16; $c++) {
|
|
||||||
print sprintf(" %1x ", $c);
|
|
||||||
}
|
|
||||||
print "\n";
|
|
||||||
|
|
||||||
print " +------------------------------------------------\n";
|
|
||||||
|
|
||||||
for (my $r = 0; $r < 32; $r++) {
|
|
||||||
print sprintf("%02x| ", $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 block
|
|
||||||
#
|
|
||||||
sub read_blk {
|
|
||||||
my ($pofile, $blk, $buf) = @_;
|
|
||||||
|
|
||||||
#print "blk=$blk\n";
|
|
||||||
|
|
||||||
my $dfh;
|
|
||||||
|
|
||||||
my $pos = calc_pos($blk);
|
|
||||||
|
|
||||||
if (open($dfh, "<$pofile")) {
|
|
||||||
binmode $dfh;
|
|
||||||
|
|
||||||
seek($dfh, $pos, 0);
|
|
||||||
|
|
||||||
my $bytes_read = read($dfh, $$buf, $blk_size);
|
|
||||||
|
|
||||||
close $dfh;
|
|
||||||
|
|
||||||
if (defined $bytes_read && $bytes_read == $blk_size) {
|
|
||||||
#print "bytes_read=$bytes_read\n";
|
|
||||||
return 1;
|
|
||||||
} else {
|
|
||||||
print "Error reading $blk\n";
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
print "Unable to open $pofile\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub clear_buf {
|
|
||||||
my ($buf) = @_;
|
|
||||||
|
|
||||||
$$buf = pack "C*", 0x00 x 512;
|
|
||||||
}
|
|
||||||
|
|
||||||
#
|
|
||||||
# Write Track/Sector
|
|
||||||
#
|
|
||||||
sub write_blk {
|
|
||||||
my ($pofile, $blk, $buf) = @_;
|
|
||||||
|
|
||||||
#print "blk=$blk\n";
|
|
||||||
|
|
||||||
my $dfh;
|
|
||||||
|
|
||||||
my $pos = calc_pos($blk);
|
|
||||||
|
|
||||||
if (open($dfh, "+<$pofile")) {
|
|
||||||
binmode $dfh;
|
|
||||||
|
|
||||||
seek($dfh, $pos, 0);
|
|
||||||
|
|
||||||
print $dfh $buf;
|
|
||||||
|
|
||||||
close $dfh;
|
|
||||||
|
|
||||||
return 1;
|
|
||||||
} else {
|
|
||||||
print "Unable to write $pofile\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
|
|
Loading…
Reference in New Issue