Added prozap

This commit is contained in:
Leeland Heins 2019-01-11 18:38:21 -06:00 committed by GitHub
parent 1d317eeab3
commit b041b5a934
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 255 additions and 8 deletions

155
PO.pm Normal file
View File

@ -0,0 +1,155 @@
#!/usr/bin/perl -w
package PO;
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;
#
# 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;
}
#
# 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;

View File

@ -4,7 +4,7 @@ package PRODOS;
use strict;
use DSK;
use PO;
use Exporter::Auto;
@ -37,12 +37,12 @@ my $key_vol_dir_blk = 2;
# 29-2a TOTAL_BLOCKS
#
my $vol_dir_blk_tmpl = 'CCCCa252';
my $vol_dir_hdr_tmpl = '';
my $vol_dir_hdr_tmpl = 'Ca15x8nnCCCCCnnn';
#
# Volume Bit Map
#
my $vol_bit_map_tmpl = '';
my $vol_bit_map_tmpl = 'C*';
#
# File Descriptive Entries
@ -96,11 +96,7 @@ my $vol_bit_map_tmpl = '';
# 21-24 LAST_MOD
# 25-26 HEADER_POINTER
#
my $file_desc_ent_tmpl = '';
sub read_blk {
my ($dskfile) = @_;
}
my $file_desc_ent_tmpl = 'Ca15CnnnnnCCCa8nnCC';
1;

96
prozap.pl Normal file
View File

@ -0,0 +1,96 @@
#!/usr/bin/perl -w
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] =~ /^-/) {
if ($ARGV[0] eq '-d') {
$debug = 1;
shift;
} elsif ($ARGV[0] eq '-b' && defined $ARGV[1] && $ARGV[1] =~ /^\d+$/) {
$blk = $ARGV[1];
shift;
shift;
} elsif ($ARGV[0] eq '-db' && defined $ARGV[1] && $ARGV[1] =~ /^\d+$/) {
$dst_blk = $ARGV[1];
shift;
shift;
} 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;
}
}
my $pofile = shift or die "Must supply filename\n";
die "Must supply block number 0-280\n" unless $blk >= 0 && $blk <= 280;
$dst_blk = $blk unless $dst_blk >= 0;
my $buf;
if (read_blk($pofile, $blk, \$buf)) {
dump_blk($buf);
if ($write) {
print "WRITING $dst_blk\n" if $debug;
my @bytes = unpack "C512", $buf;
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);
}
}
my $buf = pack "C*", @bytes;
if (write_blk($pofile, $dst_blk, $buf)) {
if (read_blk($pofile, $dst_blk, \$buf)) {
dump_blk($buf);
} else {
print "Failed final read!\n";
}
} else {
print "Failed write!\n";
}
}
} else {
print "Failed initial read!\n";
}
1;