#!/usr/bin/perl
#
# Copyright © 2015-2020 by Vincent Slyngstad
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS LISTED ABOVE BE LIABLE
# FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF
# CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the names of the authors above
# shall not be used in advertising or otherwise to promote the sale, use
# or other dealings in this Software without prior written authorization
# from those authors.
@rem = '
@echo off
c:\perl5\bin\perl %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
goto endofperl
@rem ' if @rem;
#
@todo = @ARGV;
@todo = (".") unless @todo;
#
# Returns TRUE if file should be in BIN format.
sub isBIN {
return $_[0] =~ /-pb.*od$/ || $_[0] =~ /-ba.*od$/;
}
#
# Wander around finding directories named "Ok".
@Ok = (".");
while (@todo) {
$dir = shift @todo;
opendir(DIR, $dir) || die "$dir: $!";
# print STDERR "Reading '$dir' ...";
foreach (readdir(DIR)) {
$f = "$dir/$_";
next if $_ eq ".";
next if $_ eq "..";
next if $_ eq "done";
next unless -d $f;
if (/^[Oo][Kk]/) {
push(@Ok, $f);
next;
}
push(@todo, $f);
next;
}
# print STDERR "\n";
closedir(DIR);
}
#
#
while (@todo) {
$dir = shift @todo;
# Don't check known RIM tapes, as they look
# just like BIN tapes with a bad checksum.
next if $dir =~ /-pm.od$/;
&process($dir);
}
#
# Process each file.
sub process {
local($f) = @_;
#
# Don't check known RIM tapes, as they look
# just like BIN tapes with a bad checksum.
return if $f =~ /-pm.od$/;
#
# Open the file and process it.
open(INPUT, $f) || die "$f: $!";
$sum = $c1 = $c2 = 0;
return unless =~ /200/;
while () {
$byte = oct($_);
# Ignore Leader-Trailer
# Uncomment to force single-segment tapes.
#next if $byte == 0200;
# If 377, ignore the comment.
if ($byte == 0377) {
while () {
$byte = oct($_);
#printf "Got Here %3o\n", $byte;
last if $byte == 0377;
}
next;
}
if ($byte == 0200) {
# Leader trailer. Must have check checksum.
# Remove the checksum bytes from the checksum
$sum -= $c1;
$sum -= $c2;
# Form the checksum from the tape image.
$c1 = ($c1<<6) + $c2;
# Checksum calcs are 12 bits.
$sum %= 010000;
#
# Bail if the sum is wrong.
if ($sum != $c1) {
printf STDERR "$f: Checksum is %04o not %04o\n", $sum, $c1;
} else {
if ($sum) {
printf STDERR "Valid binary segment found in $f\n"
unless isBIN($f);
}
}
$sum = $c1 = $c2 = 0;
next;
}
# If high bit on, better be a valid field setting.
if ($byte&0200) {
next if ($byte&0307) == 0300;
printf STDERR "$f: not BIN format\n" if isBIN($f);
return;
}
# High bit off, just add it to the checksum.
$sum += $byte;
# Remember the last two (checksum) bytes for later fixup.
$c1 = $c2;
$c2 = $byte;
}
warn "$f: odd byte count: ", tell(INPUT) if tell(INPUT) % 1;
close(INPUT);
# Remove the checksum bytes from the checksum
$sum -= $c1;
$sum -= $c2;
# Form the checksum from the tape image.
$c1 = ($c1<<6) + $c2;
# Checksum calcs are 12 bits.
$sum %= 010000;
#
# Bail if the sum is wrong.
printf STDERR "$f: Checksum is %04o not %04o\n", $sum, $c1 if $sum != $c1;
}
#
# For "." and each directory named "Ok", process all the *.od files.
while (@Ok) {
$dir = shift @Ok;
opendir(DIR, $dir) || die "$dir: $!";
# print STDERR "Reading '$dir' ...";
foreach (readdir(DIR)) {
$f = "$dir/$_";
next unless -f $f;
next unless /\.od$/;
&process($f);
}
# print STDERR "\n";
closedir(DIR);
}
__END__
:endofperl