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

# MFD: <acct>  <pass1> <pass2> <next> <0.012> <cputime> <devtime> <frib>
# UFD: <name1> <name2> <name3> <next> <ext.prot> <size> <date>    <frib>
# <next> and <frib> are offsets within this block.
# <size> is in blocks.  There's no smaller resolution.

# TSS/8 <ext.prot>:
# ext.prot&7700	EXTENSION
# 0000		[NONE]
# 0200		.ASC
# 0400		.SAV
# 0600		.BIN
# 1000		.BAS
# 1200		.BAC
# 1400		.FCL
# 1600		.TMP
# 2000		[NONE]
# 2200		.DAT
# 2400		.LST
# 2600		.PAL
@ext = ("", ".ASC", ".SAV", ".BIN", ".BAS", ".BAC", ".FCL", ".TMP", "", ".DAT", ".LST", ".PAL");
$text{".ASC"} = 1;
$text{".LST"} = 1;
$text{".PAL"} = 1;
sub ext {
  return $ext[($_[0]&07700)/2];
}
# ext.prot & 077: <NC uw gw gr ow or> where a set bit prohibits the action.
# There seems to be no way to prevent one from reading his own files.
# The default permission is 012; "group write" and "all write" are prohibited.
# Permissions where u<g, u<o, or g<o are probably silly, but are allowed.
@prot = (0666, 0662, 0664, 0660, 0626, 0622, 0624, 0620,
         0646, 0642, 0644, 0640, 0606, 0602, 0604, 0600,
         0446, 0442, 0444, 0440, 0406, 0402, 0404, 0400);

#
# This flavor of sixbit encodes "A" as 041 (not 001)..
sub sixbit {
  return ord($_[0])-040;
}
sub asc {
  return chr($_[0]+040);
}

#
# The date is not optional in TSS directories.
# DATE FORMAT: <mmmm><ddddd><yyy>  Year is yyy+74.
$epoch = 1974; # Or should it be 1964, per the User's Guide?
@month = ("0",  "JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL",
	 "AUG", "SEP", "OCT", "NOV", "DEC", "13",  "14",  "15");

open(INPUT, $ARGV[0]) || die "$ARGV[0]: $!";
binmode(INPUT);
#
# Convert TSS8 date word to time_t.
# Would it be more efficient to know the 
# seconds in a (short) year and the number 
# of seconds in each month since the epoch?
sub cvtdate {
  local($mo, $dy, $yr) = @_;
  local($tm, $td, $ty, $days);
  local($t) = time;

  $yr += $epoch - 1900;
  $dy = 1 if $dy == 0;
  while (1) {
    # Convert the estimate, $t, to local time.
    ($_, $_, $_, $td, $tm, $ty) = localtime($t);
    # Estimate the difference in days.
    $days = ($ty-$yr)*365 + ($tm-$mo)*30 + $td-$dy;
    # Return if on the right day.
    return $t unless $days;
    # Kludge prevents cycling on the missing leap day
    # Dates like 2/29/93, 2/30/93, 2/31/93, etc.
    # Also dates like 4/31/xx, etc.
    return $t + 24*60*60 if $days == -1;
    return $t + 48*60*60 if $days == -2;
    return $t + 72*60*60 if $days == -3;
    # Adjust $t.
    $t -= $days * 22*60*60;
  }
}

#
# Lifted from os8xplode.pl.  Stubbed out non-binary 
# support, but left the bones in case we want them 
# someday.  Changed byte packing order to TSS.
sub ofile {
  local($f, $first, $last, $ctime) = @_;
  local($mask, $eof, $chr1, $chr2, $chr3);
  local(@buf);

  open(OUTPUT, ">$f") || die "$f: $!";
  binmode(OUTPUT);
  $mask = 0377; $chr1 = "binary";

  printf XML "<file name='$f' start=0%o end=0%o mode=$chr1>", $first, $last;
  seek(INPUT, $bsize*($fsbase+$first), 0) || die "seek($dsk): $!";
  $eof = 0;
  for ($i = $first; $i <= $last; $i++) {
    # Read a block
    read(INPUT, $buf, $bsize) || die "read($dsk): $!";
    @buf = unpack("S512", $buf);
    # Repack the bits amd write the block.
    while (@buf && !$eof) {
      $chr1 = shift @buf;
      $chr2 = shift @buf;
      $chr3 = $chr2 & 0377;
      $chr2 = ($chr2>>8) + (($chr1<<4)&0360);
      $chr1 = $chr1 >> 4;
      if ((($chr1 & $mask) == 032) && ($mask == 0177)) {
        $eof = 1;
        next;
      }
      print OUTPUT pack("C", $chr1 & $mask);
      if ((($chr2 & $mask) == 032) && ($mask == 0177)) {
        $eof = 1;
        next;
      }
      print OUTPUT pack("C", $chr2 & $mask);
      if ((($chr3 & $mask) == 032) && ($mask == 0177)) {
        $eof = 1;
        next;
      }
      print OUTPUT pack("C", $chr3 & $mask);
    }
    # Mark the block used
    die "Block $i was used for both $blocks[$i] and $f\n"
      if defined $blocks[$i];
    $blocks[$i] = $f;
  }
  close(OUTPUT) || die "close($f): $!";
  # Set the creation time on the output file.
  utime($ctime, $ctime, $f) || die "utime($f): $!";
  # Now update the XML
  print XML "</file>\n";
}

#
# An OS/8 directory starts in block 1, but the TSS MFD 
# location depends on the number of users.  There are 
# 4K each for SIP, FIP, INIT, then 8K for the RM.
# That's 20K of fixed overhead, followed by the swap
# area, 4K per user.
$mfbase = 0;
for ($users = 8; $users <= 32; $users++) {
    $link = (20 + 4*$users) * 4; # 1K == 4 blocks
    #
    # Attempt to find the MFD at the next proposed spot.
    # The block should start with 8 dummy words, a 0010 
    # being in the fourth word.  This should be followed
    # by the MFD: 0001 <pw1> <pw2> 0012 <cpu> <dev> <frb>
    # and then the FRB: 0000 0001 <s2> <s3> <s4> <s5> <s6> <s7>
    # Example: The MFD has been found at offset 0620020,
    # following a dummy block at 0620000.  Each 4K is 
    # 20000, so that corresponds to 031 or 25 core images.
    # Five core images are not part of swap, so the system
    # Has a maxximum of 20 users.
    seek(INPUT, $link*01000, 0) || die "directory seek: $!";
    read(INPUT, $mfd, 01000) || die "directory read: $!";
    @mfd = unpack("S*", $mfd);
    #
    # @mfd starts with an MFD.
#warn "$mfd[003] == 010? ($users)\n";
    next unless $mfd[003] == 0010;
#warn "$mfd[014] == 012?\n";
#   next unless $mfd[014] == 0012;
    next if $mfd[014] & 07740;
#warn "$mfd[017] == 020?\n";
    next unless $mfd[017] == 0020;
#warn "$mfd[020] == 0?\n";
    next unless $mfd[020] == 0000;
    warn "users = $users\n";
    $mfbase = $link*01000;
    $mfbase -= 512; # Work around "first block is block 1".
    last;
}
exit 1 unless $mfbase;
#warn "mfbase is $mfbase\n";

#
# OK, $mfbase establishes the base for block access, 
# and @ufd is the relevant directory.  That's sufficient
# to read the file, given an offset to it's first 
# frib.  @ufd is the relevant directory context, and
# $frib # is an offset into @ufd..
sub readfile {
    local(*ufd, $frib, $offset, $bytes) = @_;
    local($count, $buf, $cblk);
    $buf = "";
    while ($bytes > 0) {
      # Calculate a block number
      $block = int($offset / 256); # 256 words / block
      $count = 256 - $offset%256;
      $count = $bytes if $count > $bytes; # Last block.
      # Locate the block.
      $cblk = $block;
      $fribo = $frib;
      while ($cblk > 6) {
	# Did we fall off the end?
        die "Walked off end of frib!\n" if $fribo == 0;
#print STDERR "Got here for $block: $fribo -> $ufd[$fribo]\n";
        $fribo = $ufd[$fribo]; # Follow link
        $cblk -= 7; # Just skipped forward 7 blocks
      }
      # This is the right FRIB segment.
      $cblk++; # Skip over the frib's link
      $cblk = $ufd[$fribo+$cblk]; # Get absolute block number, not relative.
      # Stop reading if no more blocks.
      return $buf if $cblk == 0;
      # Found the next block.  Read it.
      seek(INPUT, $mfbase+$cblk*512, 0) || die "data seek: $!";
      read(INPUT, $cb, 2*$count) || die "data read: $! ($cblk)";
      $buf .= $cb;
      $offset += $count;
      $bytes -= $count;
    }
    return $buf;
}

# Since the MFD is allowed just the one RIB, we have 
# enough context now to read in the rest of the MFD.
$mfd = &readfile(*mfd, 020, 0, 4096);
@mfd = unpack("S*", $mfd); # Read in the entire MFD.

# We found a TSS image, let's start the XML.
$fs = $ARGV[0];
$fs =~ s/[.]dsk$//;
$fs =~ s/[.]tss8*$//;
open(XML, ">$fs.xml") || die "$fs.xml: $!";
$bsize = 256*2;
($_, $_, $_, $_, $_, $_, $_, $b, $_, $_, $ctime) = stat(INPUT);
die "$dsk: Not an integral number of blocks!\n" if $b % $bsize;
$blocks = $b / $bsize;
printf XML "<image name='$ARGV[0]' size=0%o>\n", $blocks;

#
# Create a directory for the filesystem contents.
$fs .= ".0";
mkdir($fs) unless -d $fs;
die "mkdir($fs): $!" unless -d $fs;
printf XML "<tss8fs name='$fs' users=%d base=0%o size=0%o>\n", $users, 0, $blocks;
#
# Walk the MFD, processing each UFD.
printf XML "<mfd>\n";
for ($link = 010; $link; $link = $next) {
    #
    # Process a user's UFD.
    $uid  = $mfd[$link+0];
    $pw1  = $mfd[$link+1];
    $pw2  = $mfd[$link+2];
    $next = $mfd[$link+3];
    $prot = $mfd[$link+4];
    $cput = $mfd[$link+5];
    $devt = $mfd[$link+6];
    $frib = $mfd[$link+7];
    # Read the directory.
    $ufd = &readfile(*mfd, $frib, 0, 4096);
    @ufd = unpack("S*", $ufd);
    # Make a pretty name for the directory.
    $dir = sprintf("$fs/[%o,%o]", $uid>>6, $uid&077);
    $pwd = sprintf("%s%s%s%s", &asc($pw1>>6), &asc($pw1&077), &asc($pw2>>6), &asc($pw2&077));
    $pwd =~ s/ *$//;
    mkdir("$dir") unless -d "$fs/dir";
    die "mkdir($dir): $!" unless -d $dir;
    printf XML "<ufd user=%04o password='%s' prot=%02o cputime=%d devtime=%d>\n", $uid, $pwd, $prot, $cput, $devt;
    # Walk the directory, listing the files.
    for ($fl = $ufd[3]; $fl; $fl = $lnxt) {
        $nam1 = $ufd[$fl+0];
        $nam2 = $ufd[$fl+1];
        $nam3 = $ufd[$fl+2];
        $lnxt = $ufd[$fl+3];
        $prot = $ufd[$fl+4];
        $size = $ufd[$fl+5];
        $date = $ufd[$fl+6];
        $day = $date % 31;
        $month = ($date / 31) % 12;
        $year = int($date / 372); # 12*31=372
        $ctime = cvtdate($month, $day, $year);
        $frib = $ufd[$fl+7];
        $fn = sprintf("%s%s%s%s%s%s", &asc($nam1>>6), &asc($nam1&077), &asc($nam2>>6), &asc($nam2&077), &asc($nam3>>6), &asc($nam3&077));
        $ext = $ext[$prot>>7];
        $fn =~ s/ *$//; $fn .= $ext; $fn =~ y/A-Z/a-z/;
        $mode = $text{$ext}? "text": "binary";
$fn =~ s:/:.:g; # BUGBUG: No slashes allowed in file name!
        chmod(0666, "$dir/$fn"); # Ignore error here.
        open(OUTPUT, ">$dir/$fn") || die "$dir/$fn: $!";
        binmode(OUTPUT);
        printf XML "<file name='%s' prot=%02o size=%d ctime=%d mode=%s>", $fn, $prot, $size, $ctime, $mode;
        $file = &readfile(*ufd, $frib, 0, 4096*256);
        #
        # At this point the native TSS data is in "S*" format.
        # Please note that TSS packs bytes into words differently 
        # thank OS/8.  That means when we convert words back to 
        # bytes here, we get a different bit ordering than the 
        # OS/8 tools do.
        $mask = 0377;
        $mask = 0177 if $text{$ext};
        @file = unpack("S*", $file);
        $file = "";
        $eof = 0;
        while (@file) {
            # 0000aaaaaaaabbbb 0000bbbbcccccccc
            $dword = ((shift @file)<<12) + (shift @file);
            # 00000000aaaaaaaabbbbbbbbcccccccc
            $c1 = $mask & ($dword >> 16); # aaaaaaaa
            $c2 = $mask & (($dword >> 8) & 0xFF); # bbbbbbbb
            $c3 = $mask & ($dword & 0xFF); # cccccccc
            # The variable $eof suppresses the cruft after
            # the ^Z at the end of text files.
            if ($mask != 0377) {
                last if $eof;
                $eof = 1 if $c1 == 032;
                $c3 = 0 if $eof;
                $eof = 1 if $c2 == 032;
                $c3 = 0 if $eof;
                $eof = 1 if $c3 == 032;
            }
            $file .= pack("CCC", $c1, $c2, $c3);
        }
        # Write the result.
        print OUTPUT $file;
        close(OUTPUT) || die "close($fn): $!";
        # Set the creation time on the output file.
        utime($ctime, $ctime, "$dir/$fn") || die "utime($dir/$fn): $!";
        # Set the permissions on the output file.
        $prot = $prot[$prot&037];
        chmod($prot, "$dir/$fn") || die "chmod($prot, $dir/$fn): $!";
        printf XML "</file>\n";
    }
    printf XML "</ufd>\n";
}
print XML "</mfd>\n";

#
# Dump reserved areas as well!
&ofile("$fs/.si", 0, 15, $ctime);
&ofile("$fs/.fip", 16, 31, $ctime);
&ofile("$fs/.init", 32, 47, $ctime);
&ofile("$fs/.tss8", 48, 79, $ctime);
&ofile("$fs/.swap", 80, 80+$users*16-1, $ctime);

printf XML "</tss8fs>\n";
print XML "</image>\n";
exit 0;