From b041b5a934ea7aa7539f1a3eb61cacc6735de054 Mon Sep 17 00:00:00 2001 From: Leeland Heins Date: Fri, 11 Jan 2019 18:38:21 -0600 Subject: [PATCH] Added prozap --- PO.pm | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ ProDOS.pm | 12 ++--- prozap.pl | 96 +++++++++++++++++++++++++++++++++ 3 files changed, 255 insertions(+), 8 deletions(-) create mode 100644 PO.pm create mode 100644 prozap.pl diff --git a/PO.pm b/PO.pm new file mode 100644 index 0000000..edb1508 --- /dev/null +++ b/PO.pm @@ -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; + diff --git a/ProDOS.pm b/ProDOS.pm index e13c890..43e53da 100644 --- a/ProDOS.pm +++ b/ProDOS.pm @@ -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; diff --git a/prozap.pl b/prozap.pl new file mode 100644 index 0000000..0c8438e --- /dev/null +++ b/prozap.pl @@ -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; +