Added prozap

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;
+

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;
 

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;
+