Initial import, split off from DOS33
This commit is contained in:
parent
415c09540b
commit
bba469de97
|
@ -0,0 +1,169 @@
|
||||||
|
#!/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;
|
||||||
|
|
|
@ -0,0 +1,11 @@
|
||||||
|
TODO:
|
||||||
|
|
||||||
|
prozap.pl -- partially working
|
||||||
|
procat.pl -- partially working
|
||||||
|
profree.pl -- partially working
|
||||||
|
proread.pl -- partially working
|
||||||
|
prowrite.pl
|
||||||
|
prorename.pl
|
||||||
|
prodelete.pl
|
||||||
|
procopy.pl
|
||||||
|
|
|
@ -0,0 +1,37 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
#
|
||||||
|
# procat.pl:
|
||||||
|
#
|
||||||
|
# Utility to get a 'catalog' (directory listing) of an Apple II ProDOS volume.
|
||||||
|
#
|
||||||
|
# 20190115 LSH
|
||||||
|
#
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use ProDOS;
|
||||||
|
|
||||||
|
my $debug = 0;
|
||||||
|
|
||||||
|
my $blk = 0x0;
|
||||||
|
|
||||||
|
while (defined $ARGV[0] && $ARGV[0] =~ /^-/) {
|
||||||
|
if ($ARGV[0] eq '-d') {
|
||||||
|
$debug = 1;
|
||||||
|
shift;
|
||||||
|
} elsif ($ARGV[0] eq '-b' && defined $ARGV[1] && $ARGV[1] =~ /^\d+$/) {
|
||||||
|
$blk = $ARGV[1];
|
||||||
|
shift;
|
||||||
|
shift;
|
||||||
|
} else {
|
||||||
|
die "Unknown command line argument $ARGV[0]\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $pofile = shift or die "Must supply .po filename\n";
|
||||||
|
|
||||||
|
cat($pofile, $debug);
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
|
@ -0,0 +1,31 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
#
|
||||||
|
# profree.pl:
|
||||||
|
#
|
||||||
|
# Utility to get a free sector map of an Apple II ProDOS volume.
|
||||||
|
#
|
||||||
|
# 20190116 LSH
|
||||||
|
#
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use ProDOS;
|
||||||
|
|
||||||
|
my $debug = 0;
|
||||||
|
|
||||||
|
while (defined $ARGV[0] && $ARGV[0] =~ /^-/) {
|
||||||
|
if ($ARGV[0] eq '-d') {
|
||||||
|
$debug = 1;
|
||||||
|
shift;
|
||||||
|
} else {
|
||||||
|
die "Unknown command line argument $ARGV[0]\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $pofile = shift or die "Must supply .po filename\n";
|
||||||
|
|
||||||
|
freemap($pofile, $debug);
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
|
@ -0,0 +1,66 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
#
|
||||||
|
# proread.pl:
|
||||||
|
#
|
||||||
|
# Utility to read a file out of an Apple II ProDOS .po disk image.
|
||||||
|
#
|
||||||
|
# 20190116 LSH
|
||||||
|
#
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use ProDOS;
|
||||||
|
|
||||||
|
my $mode = 'T'; # T=Text
|
||||||
|
my $conv = 1; # Convert \r to \n
|
||||||
|
my $debug = 0;
|
||||||
|
|
||||||
|
while (defined $ARGV[0] && $ARGV[0] =~ /^-/) {
|
||||||
|
# Mode
|
||||||
|
if ($ARGV[0] eq '-m' && defined $ARGV[1] && $ARGV[1] ne '') {
|
||||||
|
# Text
|
||||||
|
if ($ARGV[1] eq 'T') {
|
||||||
|
$mode = 'T';
|
||||||
|
$conv = 1;
|
||||||
|
# Integer BASIC
|
||||||
|
} elsif ($ARGV[1] eq 'I') {
|
||||||
|
$mode = 'I';
|
||||||
|
$conv = 0;
|
||||||
|
# Applesoft
|
||||||
|
} elsif ($ARGV[1] eq 'A') {
|
||||||
|
$mode = 'A';
|
||||||
|
$conv = 0;
|
||||||
|
# Binary
|
||||||
|
} elsif ($ARGV[1] eq 'B') {
|
||||||
|
$mode = 'B';
|
||||||
|
$conv = 0;
|
||||||
|
# S
|
||||||
|
} elsif ($ARGV[1] eq 'S') {
|
||||||
|
$mode = 'S';
|
||||||
|
$conv = 0;
|
||||||
|
} else {
|
||||||
|
die "Unknown mode for -m, must be T, I, A, B or S\n";
|
||||||
|
}
|
||||||
|
shift;
|
||||||
|
shift;
|
||||||
|
# Convert (carriage return to linefeed)
|
||||||
|
} elsif ($ARGV[0] eq '-c') {
|
||||||
|
$conv = 0;
|
||||||
|
shift;
|
||||||
|
# Debug
|
||||||
|
} elsif ($ARGV[0] eq '-d') {
|
||||||
|
$debug = 1;
|
||||||
|
shift;
|
||||||
|
} else {
|
||||||
|
die "Unknown command line argument $ARGV[0]\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $pofile = shift or die "Must supply .po filename\n";
|
||||||
|
my $filename = shift or die "Must supply filename (on disk image)\n";
|
||||||
|
|
||||||
|
read_file($pofile, $filename, $mode, $conv, $debug);
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
|
@ -0,0 +1,119 @@
|
||||||
|
#!/usr/bin/perl -w
|
||||||
|
|
||||||
|
#
|
||||||
|
# prozap.pl:
|
||||||
|
#
|
||||||
|
# Utility to edit a ProDOS block (.PO image).
|
||||||
|
#
|
||||||
|
# 20190115 LSH
|
||||||
|
#
|
||||||
|
|
||||||
|
use strict;
|
||||||
|
|
||||||
|
use PO;
|
||||||
|
|
||||||
|
my $debug = 0;
|
||||||
|
|
||||||
|
my $blk = -1;
|
||||||
|
my $dst_blk = -1;
|
||||||
|
my $write = 0;
|
||||||
|
|
||||||
|
my @mods = ();
|
||||||
|
|
||||||
|
while (defined $ARGV[0] && $ARGV[0] =~ /^-/) {
|
||||||
|
# Debug
|
||||||
|
if ($ARGV[0] eq '-d') {
|
||||||
|
$debug = 1;
|
||||||
|
shift;
|
||||||
|
# Block to read
|
||||||
|
} elsif ($ARGV[0] eq '-b' && defined $ARGV[1] && $ARGV[1] =~ /^\d+$/) {
|
||||||
|
$blk = $ARGV[1];
|
||||||
|
shift;
|
||||||
|
shift;
|
||||||
|
# Destination block
|
||||||
|
} elsif ($ARGV[0] eq '-db' && defined $ARGV[1] && $ARGV[1] =~ /^\d+$/) {
|
||||||
|
$dst_blk = $ARGV[1];
|
||||||
|
shift;
|
||||||
|
shift;
|
||||||
|
# Allow modifying data.
|
||||||
|
} elsif ($ARGV[0] =~ /^-m([ahA])/ && defined $ARGV[1] && $ARGV[1] ne '') {
|
||||||
|
my $typ = $1;
|
||||||
|
print "$ARGV[1] typ=$typ\n" if $debug;
|
||||||
|
if ($ARGV[1] =~ /^([0-9a-fA-F]+):\s*(.+)$/) {
|
||||||
|
print "1=$1 2=$2\n" if $debug;
|
||||||
|
push @mods, { 'typ' => $typ, 'addr' => $1, 'vals' => $2 };
|
||||||
|
}
|
||||||
|
shift;
|
||||||
|
shift;
|
||||||
|
} elsif ($ARGV[0] eq "-w") {
|
||||||
|
$write = 1;
|
||||||
|
shift;
|
||||||
|
} else {
|
||||||
|
die "Unknown command line argument $ARGV[0]\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
my $pofile = shift or die "Must supply .po filename\n";
|
||||||
|
die "Must supply block number 0-280\n" unless $blk >= 0 && $blk <= 280;
|
||||||
|
|
||||||
|
$dst_blk = $blk unless $dst_blk >= 0;
|
||||||
|
|
||||||
|
my $buf;
|
||||||
|
|
||||||
|
# Read the block
|
||||||
|
if (read_blk($pofile, $blk, \$buf)) {
|
||||||
|
# Display the data in the block.
|
||||||
|
dump_blk($buf);
|
||||||
|
|
||||||
|
# Allow modifying the data.
|
||||||
|
if ($write) {
|
||||||
|
print "WRITING $dst_blk\n" if $debug;
|
||||||
|
# Unpack the data in the block
|
||||||
|
my @bytes = unpack "C512", $buf;
|
||||||
|
|
||||||
|
# Process each modification.
|
||||||
|
foreach my $mod (@mods) {
|
||||||
|
my @mbytes = ();
|
||||||
|
if ($mod->{'typ'} eq 'a') {
|
||||||
|
print "ASCII vals=$mod->{'vals'}\n" if $debug;
|
||||||
|
# Normal ASCII
|
||||||
|
@mbytes = map { pack('C', ord($_)) } ($mod->{'vals'} =~ /(.)/g);
|
||||||
|
} elsif ($mod->{'typ'} eq 'A') {
|
||||||
|
print "HEX vals=$mod->{'vals'}\n" if $debug;
|
||||||
|
# Apple II ASCII
|
||||||
|
@mbytes = map { pack('C', ord($_) | 0x80) } ($mod->{'vals'} =~ /(.)/g);
|
||||||
|
} elsif ($mod->{'typ'} eq 'h') {
|
||||||
|
print "A2 ASCII vals=$mod->{'vals'}\n" if $debug;
|
||||||
|
# HEX
|
||||||
|
@mbytes = map { pack('C', hex(lc($_))) } ($mod->{'vals'} =~ /(..)/g);
|
||||||
|
}
|
||||||
|
my $addr = hex($mod->{'addr'});
|
||||||
|
print "addr=$addr\n" if $debug;
|
||||||
|
foreach my $byte (@mbytes) {
|
||||||
|
print sprintf("byte=%02x\n", ord($byte)) if $debug;
|
||||||
|
$bytes[$addr++] = ord($byte);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Re-pack the data in the block
|
||||||
|
$buf = pack "C*", @bytes;
|
||||||
|
|
||||||
|
# Write the destination block (default to block read).
|
||||||
|
if (write_blk($pofile, $dst_blk, $buf)) {
|
||||||
|
# Read the block back in.
|
||||||
|
if (read_blk($pofile, $dst_blk, \$buf)) {
|
||||||
|
# Display the data in the modified block.
|
||||||
|
dump_blk($buf);
|
||||||
|
} else {
|
||||||
|
print "Failed final read!\n";
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
print "Failed write!\n";
|
||||||
|
}
|
||||||
|
}
|
||||||
|
} else {
|
||||||
|
print "Failed initial read!\n";
|
||||||
|
}
|
||||||
|
|
||||||
|
1;
|
||||||
|
|
Loading…
Reference in New Issue