#!/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.
#
# Read the .xml descriptions of disk volumes,
# re-create them. (We don't try to be tolerant
# of free format XML.)
#
# Write a block to the new image.
sub writeblk {
local($blk, @buf) = @_;
seek(IMAGE, ($blk+$fsbase)*512, 0) || die "seek($iname): $!";
$buf = pack("S*", @buf);
return unless length($buf);
syswrite(IMAGE, $buf) || die "write($iname) $f: $!";
# FEATURE: Should book-keep which blocks were written,
# and which were forgotten.
}
#
# Ensure at least enough words remain in the directory
# segment for the next directory entry. If not, wrap
# up (and output) the directory block, and start a new
# one.
sub reserve {
local($needed) = $_[0];
return unless $doff + $needed > 255;
$dbuf[0] = 07777 & -$dent;
$dbuf[2] = $dblk + 1; # Link to next block.
# Write the directory block.
&writeblk($dblk, @dbuf);
$dblk++;
die "$fsname: directory full: $file" if $dblk > 6;
$dbuf[0] = $dent = 0; # No entries yet
$dbuf[1] = $sblk; # Start here
$dbuf[2] = 0; # No link yet
$doff = 5; # New buffer ptr
}
#
# Trim a date to 12 bits in OS/8 format.
sub os8date {
local($file) = $_[0];
local($date) = (stat$file)[9];
local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($date);
$mon++;
#warn "os8date($f:$date): $mday-$mon-$year\n";
$year -= 1970;
$year %= 8;
return ($mon<<8) + ($mday<<3) + $year;
}
#
# Process a <file></file> sequence.
sub file {
$_ = <XML>;
return 0 unless /^<file name='(.*)' start=([0-7]+) end=([0-7]+) mode=(.*)><\/file>$/;
($file, $start, $end, $mode) = ($1, $2, $3, $4);
$start = oct($start) if $start =~ /^0/;
$end = oct($end) if $end =~ /^0/;
# Uppercase a copy of the file name and extension.
$f = $file; $f =~ y/a-z/A-Z/;
$f =~ s/.*\///;
# Copy the data for the file into the disk image.
# An empty area of the disk has a file name .NNN,
# where NNN is the starting block number.
if ($f eq ".$start") {
# Don't bother to actually write empty areas.
#©out($file, $start, $end);
# Output 00000, -length
&reserve(2); # Need room for 2 words
$dbuf[$doff+0] = 0;
$dbuf[$doff+1] = 07777 & ($start-$end-1);
$doff += 2;
$sblk = $end + 1;
$dent++;
} else {
©out($file, $start, $end);
# Seperate name, extension
$ext = $f; $ext =~ s/^.*[.]//;
$f =~ s/[.]$ext$//;
# Pad with spaces.
$f = pack("a6", $f);
$ext = pack("a2", $ext);
# Pack character pairs into 6bit.
@f = split(//, $f);
@ext = split(//, $ext);
$datew = &os8date($file);
&reserve(5); # Need room for 2 words
$dbuf[$doff+0] = ((ord($f[0])&077)<<6) + (ord($f[1])&077);
$dbuf[$doff+1] = ((ord($f[2])&077)<<6) + (ord($f[3])&077);
$dbuf[$doff+2] = ((ord($f[4])&077)<<6) + (ord($f[5])&077);
$dbuf[$doff+3] = ((ord($ext[0])&077)<<6) + (ord($ext[1])&077);
$dbuf[$doff+4] = $datew;
$dbuf[$doff+5] = 07777 & ($start-$end-1);
$doff += 6;
$sblk = $end + 1;
$dent++;
}
return 1;
}
sub copyout {
local($f, $start, $last) = @_;
open(FILE, "$f") || die "$f: $!";
binmode(FILE);
local($buf, @ibuf, @obuf);
local($mode, $eof, $eofpos) = (0, 0, 0);
# Check that the file fits in the allocated space!
local($blks) = int(((-s $f)+383) / 384);
if ($blks != $last-$start+1) {
die "$f doesn't fit the allocated space!\n" if $blks != $last-$start+1;
}
# Unpack the file as if binary.
for ($first = $start; $first <= $last; $first++) {
# Read a (packed, 384 byte) block.
read(FILE, $buf, 384) || die "read($f): $!";
@ibuf = unpack("C*", $buf);
# Must be text if not a multiple of block size
# Add an EOF marker, if so.
push(@ibuf, 032) unless $#ibuf%384 == 383;
$foo = ".rsvd";
#warn "$f: ibuf[$#ibuf] = $ibuf[$#ibuf]\n" if $f =~ /$foo/;
# Pad last block to a multiple of 3 bytes.
push(@ibuf, 0) unless $#ibuf%3 == 2;
push(@ibuf, 0) unless $#ibuf%3 == 2;
# Unpack the block.
while (@ibuf) {
$c1 = shift @ibuf;
$c2 = shift @ibuf;
$c3 = shift @ibuf;
#warn "$f: $c1 $c2 $c3\n" if $f =~ /$foo/;
# Worry about it is truly text mode.
$mode = 1 if $c1 & 0200; # Must be binary
$eofpos++ unless $eof;
$eof++ if $c1 == 032;
$mode = 1 if $c2 & 0200; # Must be binary
$eofpos++ unless $eof;
$eof++ if $c2 == 032;
$mode = 1 if $c3 & 0200; # Must be binary
$eofpos++ unless $eof;
$eof++ if $c3 == 032;
$mode = 1 if $eof > 1; # Another EOF, must be binary
$c1 |= ($c3&0360)<<4;
$c2 |= ($c3&0017)<<8;
#warn "$f: pushing $c1 $c2\n" if $f =~ /$foo/;
push(@obuf, $c1, $c2);
}
}
# Force binary treatment for un-named files.
$mode = 1 if $f =~ /^\..../;
#warn "$f: mode is $mode\n" if $f =~ /$foo/;
#warn "$f: obuf is $obuf[0] $obuf[1]\n" if $f =~ /$foo/;
# We walked the file, so we know if it is truly binary.
if (!$mode) {
# Text file, more mangling is needed!
# NOTE: We don't fix your line endings, so
# ~/.exrc: set fileformats=unix,dos
# or equivalent is probably needed to perserve them..
#
# Each word in needs 0200 set, and the first
# in each pair also need 04000.
for ($i = 0; $i < $#obuf; $i += 2) {
$obuf[$i] |= 04200;
$obuf[$i+1] |= 00200;
}
# Pad the length to an even block.
while ($#obuf%256 != 255) {
push(@obuf, 04200, 00200);
}
}
#warn "$f: obuf is $obuf[0] $obuf[1]\n" if $f =~ /$foo/;
# Write @obuf as the result.
&writeblk($start, @obuf);
return $mode;
}
sub os8fs {
$_ = <XML>;
return 0 unless /^<os8fs name='(.*)' base=(.*) size=(.*)>$/;
($fsname, $fsbase, $fssize) = ($1, $2, $3);
$fsbase = oct($fsbase) if $fsbase =~ /^0/;
©out("$fsname/.boot", 0, 0);
$sblk = 07;
if (-f "$fsname/.kmon") {
# System disk, copy out .kmon, etc.
©out("$fsname/.kmon", 07, 012);
©out("$fsname/.usr", 013, 015);
©out("$fsname/.dhand", 016, 025);
©out("$fsname/.ent", 026, 026);
©out("$fsname/.sblks", 027, 050);
©out("$fsname/.cdec", 051, 053);
©out("$fsname/.sdate", 054, 055);
©out("$fsname/.merr", 056, 056);
©out("$fsname/.chain", 057, 057);
©out("$fsname/.sodt", 060, 063);
©out("$fsname/.rsvd", 064, 064);
©out("$fsname/.cclr", 065, 065);
©out("$fsname/.td8e", 066, 066);
©out("$fsname/.cclo", 067, 067);
$sblk = 070;
}
$dblk = 1; # Start directory here
$dbuf[0] = $dent = 0; # No entries yet
$dbuf[1] = $sblk; # Files start here
$dbuf[2] = 0; # No link yet
$dbuf[3] = 0; # No flag
$dbuf[4] = 07777; # 1 additional data word (date)
$doff = 5; # Start file entries with word 5
$_ = <XML>;
die "no <directory>" unless /^<directory>$/;
while (&file) {}
die "no </directory>" unless /^<\/directory>$/;
#
# Write out the last directory block.
$dbuf[0] = 07777 & -$dent;
$dbuf[2] = 0; # Zero link to next block.
&writeblk($dblk, @dbuf);
# Skip over .kmon, etc.!
while (($_ = <XML>)) {
last if /^<\/os8fs>$/;
}
die "no </os8fs>" unless /^<\/os8fs>$/;
}
foreach $x (@ARGV) {
open(XML, "$x") || die "$x: $!";
$_ = <XML>;
die "no <image>" unless /^<image name='(.*)' size=(.*)>$/;
($iname, $isize) = ($1, $2);
open(IMAGE, ">$iname") || die "$iname: $!";
while (&os8fs) {}
die "no </image>" unless /^<\/image>$/;
}