#!/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.

#
# Convert a suitable .sv file to .sd (PQS8 System  DIRECTory) format.
# The .sv file may have one or two segments, which are each expected
# to be 4K long.
#
#2345678901234567890123456789012345678901234567890123456789012345678901234567890

#
# Read a block from an OS/8 packed file and unpack it.
sub getblk {
    local($blk) = @_;
    local(*buf, $w1, $w2, @r);

    # OS/8 packing means each block is 384 bytes (for 256 words).
    seek(INPUT, 384*$blk, 0) || die "seek($f): $!";
    read(INPUT, $buf, 384) || die "read($f): $!";
    @buf = unpack("C384", $buf);
    @r = ();
    while (@buf) {
        $w1 = shift @buf;
        $w2 = shift @buf;
        $buf = shift @buf;
        $w1 |= ($buf&0xF0) << 4;
        $w2 |= ($buf&0x0F) << 8;
        push(@r, $w1, $w2);
    }
    return @r;
}

#
# Copy out a segment to the output file.
sub dosegment {
    local($field, $blk) = @_;
    local($i, @buf);

warn "dosegment($field, $blk, $pages)\n";
    # Each segment is essentially a field.
    # Seek to the correct position for the field.
    seek(OUTPUT, 010000*2*$field, 0) || die "seek($f): $!";
    for ($i = 0; $i < $pages; $i+=2) {
        @buf = getblk($blk);
        $blk++;
        $buf = pack("S256", @buf);
        print OUTPUT $buf;
    }
}

#
# Look for flags to build up the system directory entry.
# -S	5-5	Scan for file names inhibit
# -R	5-6	Use current Radix
# -O	6-5	Scan for output files only
# -\d+	6-6:11	Set file type
# File types:
#  "          ", 0
#  "GENO  GENI", 1
#  "      BIN ", 2
#  "BIN   BIN ", 3
#  "BIN       ", 4
#  "ASC   ASC ", 5
#  "ASC       ", 6
#  "BIN   PAL ", 7
#  "PAL   PAL ", 8
#  "      BAT ", 9
#  "      DUMP", 10
#  "      FOC ", 11
#  "PAL       ", 12
#  "      PAL ", 13
#
$type = $blkno = 0;
$bit55 = $bit56 = $bit65 = $bit66 = 0;
while ($ARGV[0] =~ s/-([SRO\d]+)/-/) {
  $flags = $1;
  while ($flags) {
    if ($flags =~ s/(\d+)//) {
      $type = $1;
    } elsif ($flags =~ s/S//g) {
      $bit55 = 0100;
    } elsif ($flags =~ s/R//g) {
      $bit56 = 0040;
    } elsif ($flags =~ s/O//g) {
      $bit65 = 0100;
    } else {
      die "Unknown option flag: $flags\n";
    }
  }
}
$ARGV[0] =~ s/-//g;

# Open the input file for binary input.
open(INPUT, $ARGV[0]) || die "$ARGV[0]: $!";
binmode(INPUT);

# Read and sanity check the first block.
@buf = &getblk(0);
$segments = shift @buf;
$segments = 010000 - $segments;
$cdif = shift @buf;
$sa = shift @buf;
$jsw = shift @buf;
die "Only one or two segments allowed: $segments" if $segments < 1;
die "Only one or two segments allowed: $segments" if $segments > 2;

#
# Open the output file for binary output.
$f = @ARGV[0]; $f =~ s/[.]sv$//;
$f .= ".sd";
open(OUTPUT, ">$f") || die "$f: $!";
binmode(OUTPUT);

#
# BUGBUG: blkno is still zero here!
# Emit the system directory entry first.
#
# Words 1-3 are the file name in SIXBIT.
$n = $f; $n =~ s/[.]sd$//; $n =~ y/a-z/A-Z/;
@c = unpack("C6", $n);
grep($_ = $_ & 077, @c);
$w1 = (shift(@c) << 6) + shift(@c);
$w2 = (shift(@c) << 6) + shift(@c);
$w3 = (shift(@c) << 6) + shift(@c);
# Word 4 is the starting (128 byte) block number.
$w4 = $blkno;
# Words 5 and 6 also contain flags to control command line parsing.
# Word 5 is the load address and length for the initial segment.
# Assume field 0 is first, if both are present.
$la = (($buf[1]&070)<<9) + $buf[0];
$len = $buf[1] >> 6;
$w5 = $la + $bit55 + $bit56 + $len;
# Word 6 is the start address and file type information.
$w6 = $sa + $bit65 + $type;
printf STDERR "0%0o 0%0o 0%0o: 0%0o 0%0o 0%0o\n", $w1, $w2, $w3, $w4, $w5, $w6;
print OUTPUT pack("S6", $w1, $w2, $w3, $w4, $w5, $w6);

#
# Walk the segment table, outputting segments to
# their new home.
$blk = 1;
for ($s = 0; $s < $segments; $s++) {
     $origin = shift @buf;
     $w2 = shift @buf;
     $pages = ($w2 >> 6) & 037;
     $field = $w2 & 070;
#    warn "Segment size must be 4K: $pages\n" unless $pages == 037;
     die "Segment field must be 0 or 1: $field\n" if $field & 060;
     &dosegment($field>>3, $blk, $pages);
     $blk += $pages;
}