#!/usr/bin/perl -w

use Fcntl qw(SEEK_SET);
use integer;

# Extract information from within a TADS GAM file

sub ord1($;$) {
 my $str = shift;
 my $ofs = shift || 0;

 return ord(substr($str, $ofs));
}

sub read1(*) {
 my $FH = shift;

 return ord(getc($FH));
}

sub ord2($;$) {
 my $str = shift;
 my $ofs = shift || 0;
 my $c1 = ord1($str, $ofs);
 my $c2 = ord1($str, $ofs + 1);

 return ($c2 << 8) | $c1;
}

sub ord2s($;$) {
 my $str = shift;
 my $ofs = shift || 0;
 my $result = ord2($str, $ofs);
 $result -= 0x10000 if ($result >= 0x8000);
 return $result;
}

sub read2(*) {
 my $FH = shift;
 my $str;

 read($FH, $str, 2);
 return ord2($str);
}

sub ord4($;$) {
 my $str = shift;
 my $ofs = shift || 0;

 my $c1 = ord1($str, $ofs);
 my $c2 = ord1($str, $ofs + 1);
 my $c3 = ord1($str, $ofs + 2);
 my $c4 = ord1($str, $ofs + 3);
 $c4 -= 256 if ($c4 >= 128);   # In case of a signed value

 return ($c4 << 24) | ($c3 << 16) | ($c2 << 8) | $c1;
}

sub read4(*) {
 my $FH = shift;
 my $str;

 read($FH, $str, 4);
 return ord4($str);
}

$xorseed = 0x3f;
$xorinc = 0x40;

sub decode($) {
 my $block = shift;

 return $block unless ($crypt);

 my $len = length($block);
 my $mask = $xorseed;
 my $maskstr;

 for (my $i = 0; $i < $len; $i++) {
   $maskstr .= chr($mask);
   $mask = ($mask + $xorinc) % 256;
 }

 return $block ^ $maskstr;
}

sub hexl($) {
 my $block = shift;

 local *HEXL;
 open(HEXL, "|/usr/lib/xemacs-21.4.8/i386-debian-linux/hexl");
 print HEXL $block;
 close HEXL;
}

sub sigend($) {
 print "(END REACHED)";
 return shift;
}

# Datatype numbers
sub DAT_NUMBER() { return 1; }
sub DAT_OBJECT() { return 2; }
sub DAT_SSTRING() { return 3; }
sub DAT_BASEPTR() { return 4; }
sub DAT_NIL() { return 5; }
sub DAT_CODE() { return 6; }
sub DAT_LIST() { return 7; }
sub DAT_TRUE() { return 8; }
sub DAT_DSTRING() { return 9; }
sub DAT_FNADDR() { return 10; }
sub DAT_TPL() { return 11; }
sub DAT_PROPNUM() { return 13; }
sub DAT_DEMAND() { return 14; }
sub DAT_SYN() { return 15; }
sub DAT_REDIR() { return 16; }
sub DAT_TPL2() { return 17; }

# Print a value, returning the length it occupied
sub printValue($$$) {
 my $block = shift;
 my $pos = shift;
 my $type = shift;
 my $lenleft = length($block) - $pos;

 if ($type == DAT_NUMBER) {
   return sigend($lenleft) if ($lenleft < 4);
   print ord4($block, $pos);
   return 4;
 }
 elsif ($type == DAT_OBJECT || $type == DAT_FNADDR) {
   print "&" if ($type == DAT_FNADDR);
   return sigend($lenleft) if ($lenleft < 2);
   printObj(ord2($block, $pos));
   return 2;
 }
 elsif ($type == DAT_SSTRING || $type == DAT_DSTRING) {
   return sigend($lenleft) if ($lenleft < 2);
   my $strlen = ord2($block, $pos);
   # Check for valid string length
   return sigend($lenleft) if ($strlen > $lenleft || $strlen < 2);
   my $delim = "\"";
   $delim = "'" if ($type == DAT_SSTRING);
   print $delim, substr($block, $pos + 2, $strlen - 2), $delim;
   return $strlen;
 }
 elsif ($type == DAT_NIL) {
   print "nil";
   return 0;
 }
 elsif ($type == DAT_LIST) {
   return sigend($lenleft) if ($lenleft < 2);
   my $listlen = ord2($block, $pos);
   # Check for valid list length
   return sigend($lenleft) if ($listlen > $lenleft || $listlen < 2);
   printList(substr($block, $pos, $listlen));
   return $listlen;
 }
 elsif ($type == DAT_TRUE) {
   print "true";
   return 0;
 }
 elsif ($type == DAT_PROPNUM) {
   return sigend($lenleft) if ($lenleft < 2);
   print "&";
   printProp(ord2($block, $pos));
   return 2;
 }
 else {
   print "Unexpected data type: $type\n";
   return $lenleft;
 }
}

sub printList($) {
 my $block = shift;

 print "[";
 my $pos = 2;
 my $len = ord2($block);
 return sigend(length($block)) if ($len > length($block) || $len < 2);
 while ($pos < $len) {
   my $type = ord1($block, $pos);
   $pos++;
   $pos += printValue($block, $pos, $type);
   print " " if ($pos < $len);
 }
 print "]";
 return $len;
}

# Define operand type values
sub OPBYTE() { return 1; }
sub OPWORD() { return 2; }
sub OPQUAD() { return 3; }
sub OPOBJ() { return 4; }
sub OPFUNC() { return 5; }
sub OPPROP() { return 6; }
sub OPRET() { return 7; }
sub OPLABEL() { return 8; }
sub OPDSTR() { return 9; }
sub OPBIF() { return 10; }
sub OPSSTR() { return 11; }
sub OPLIST() { return 12; }
sub OPSWITCH() { return 13; }   # Switch table
sub OPLINE() { return 14; }     # Debugger line record
sub OPFRAME() { return 15; }    # Local variable frame record

# Print an operand, returning the number of bytes it occupied
sub printOperand($$$) {
 my $block = shift;
 my $pos = shift;
 my $type = shift;
 my $lenleft = length($block) - $pos;

 if ($type == OPBYTE) {
   return sigend($lenleft) if ($lenleft < 1);
   print ord1($block, $pos);
   return 1;
 }
 elsif ($type == OPWORD || $type == OPRET) {
   return sigend($lenleft) if ($lenleft < 2);
   print ord2s($block, $pos);
   return 2;
 }
 elsif ($type == OPQUAD) {
   return printValue($block, $pos, DAT_NUMBER);
 }
 elsif ($type == OPOBJ || $type == OPFUNC) {
   return printValue($block, $pos, DAT_OBJECT);
 }
 elsif ($type == OPPROP) {
   return sigend($lenleft) if ($lenleft < 2);
   printProp(ord2($block, $pos));
   return 2;
 }
 elsif ($type == OPLABEL || $type == OPSWITCH) {
   return sigend($lenleft) if ($lenleft < 2);
   print $pos + ord2s($block, $pos);
   return 2;
 }
 elsif ($type == OPDSTR) {
   return printValue($block, $pos, DAT_DSTRING);
 }
 elsif ($type == OPSSTR) {
   return printValue($block, $pos, DAT_SSTRING);
 }
 elsif ($type == OPBIF) {
   return sigend($lenleft) if ($lenleft < 2);
   printBuiltin(ord2($block, $pos));
   return 2;
 }
 elsif ($type == OPLIST) {
   return printValue($block, $pos, DAT_LIST);
 }
 elsif ($type == OPLINE) {
   return sigend($lenleft) if ($lenleft < 1);
   my $linelen = ord1($block, $pos);
   return sigend($lenleft) if ($linelen > $lenleft || $linelen < 1);
   print "line record (", $linelen, " bytes)";
   return $linelen;
 }
 elsif ($type == OPFRAME) {
   return sigend($lenleft) if ($lenleft < 2);
   my $framelen = ord2($block, $pos);
   return sigend($lenleft) if ($framelen > $lenleft || $framelen < 2);
   print "frame record (", $framelen, " bytes)";
   return $framelen;
 }
 else {
   print "This shouldn't happen: unknown operand type ", $type, "\n";
   die;
 }
}

@props = (undef, "doAction", "verb", "noun", "adjective", "preposition",
         "article", "plural", "sdesc", "thedesc", "doDefault",
         "ioDefault", "ioAction", "location", "value",
         "roomAction", "actorAction", "contents", "tpl",
         "prepDefault", "verActor", "validDo", "validIo",
         "lookAround", "roomCheck", "statusLine", "locationOK",
         "isVisible", "cantReach", "isHim", "isHer", "action",
         "validDoList", "validIoList", "iobjGen", "dobjGen",
         "nilPrep", "rejectMultiDobj", "moveInto", "construct",
         "destruct", "validActor", "preferredActor", "isEquivalent",
         "adesc", "multisdesc", "tpl2", "anyvalue",
         "newNumbered", "unknown", "parseUnknownDobj",
         "parseUnknownIobj", "dobjCheck", "iobjCheck", "verbAction",
         "disambigDobj", "disambigIobj", "prefixdesc", "isThem");

sub printProp($) {
 my $n = shift;

 if ($n == 0) {
   print "noprop";
 }
 elsif ($n > 0 && defined $props[$n]) {
   print $props[$n];
 }
 else {
   print "prop", $n;
 }
}

@objs = ();

sub printObj($) {
 my $n = shift;

 if ($n == 65535) {
   print "nullobj";
 }
 elsif (defined $objs[$n]) {
   print $objs[$n];
 }
 else {
   print "obj", $n;
 }
}

sub printBuiltin($) {
 my $n = shift;
 my @builtins = ("say", "car", "cdr", "length", "randomize", "rand",
                 "substr", "cvtstr", "cvtnum", "upper", "lower",
                 "caps", "find", "getarg", "datatype", "setdaemon",
                 "setfuse", "setversion", "notify", "unnotify",
                 "yorn", "remfuse", "remdaemon", "incturn", "quit",
                 "save", "restore", "logging", "input", "setit",
                 "askfile", "setscore", "firstobj", "nextobj",
                 "isclass", "restart", "debugTrace", "undo", "defined",
                 "proptype", "outhide", "runfuses", "rundaemons",
                 "gettime", "getfuse", "intersect", "inputkey",
                 "objwords", "addword", "delword", "getwords",
                 "nocaps", "skipturn", "clearscreen", "firstsc",
                 "verbinfo", "fopen", "fclose", "fwrite", "fread",
                 "fseek", "fseekeof", "ftell", "outcapture",
                 "systemInfo", "morePrompt", "parserSetMe",
                 "parserGetMe", "reSearch", "reGetGroup", "inputevent",
                 "timeDelay", "setOutputFilter", "execCommand",
                 "parserGetObj", "parseNounList", "parserTokenize",
                 "parserGetTokTypes", "parserDictLookup",
                 "parserResolveObjects", "parserReplaceCommand",
                 "exitobj", "inputdialog", "resourceExists");

 if ($n < 0 || $n > $#builtins) {
   print "invalid builtin $n";
 }
 else {
   print $builtins[$n];
 }
}

@opcodes =
 ([],
  ["pushnum", OPQUAD],
  ["pushobj", OPOBJ],
  ["neg"],
  ["not"],
  ["add"],
  ["sub"],
  ["mul"],
  ["div"],
  ["and"],
  ["or"],
  ["eq"],
  ["ne"],
  ["gt"],
  ["ge"],
  ["lt"],
  ["le"],
  ["call", OPBYTE, OPFUNC],
  ["getp", OPBYTE, OPPROP],
  ["getpdata", OPBYTE, OPPROP],
  ["getlcl", OPWORD],
  ["ptrgetpdata", OPBYTE],
  ["return", OPRET],
  ["retval", OPRET],
  ["enter", OPWORD],
  ["discard"],
  ["jmp", OPLABEL],
  ["jf", OPLABEL],
  ["pushself"],
  ["say", OPDSTR],
  ["builtin", OPBYTE, OPBIF],
  ["pushstr", OPSSTR],
  ["pushlst", OPLIST],
  ["pushnil"],
  ["pushtrue"],
  ["pushfn", OPFUNC],
  ["getpselfdata", OPBYTE, OPPROP],
  [],
  ["ptrcall", OPBYTE],
  ["ptrinh", OPBYTE],
  ["ptrgetp", OPBYTE],
  ["pass", OPPROP],
  ["exit"],
  ["abort"],
  ["askdo"],
  ["askio", OPOBJ],
  ["expinh", OPBYTE, OPPROP, OPOBJ],
  ["expinhptr", OPBYTE, OPOBJ],
  ["calld", OPBYTE, OPFUNC],
  ["getpd", OPBYTE, OPPROP],
  ["builtind", OPBYTE, OPBIF],
  ["je", OPLABEL],
  ["jne", OPLABEL],
  ["jgt", OPLABEL],
  ["jge", OPLABEL],
  ["jlt", OPLABEL],
  ["jle", OPLABEL],
  ["jnand", OPLABEL],
  ["jnor", OPLABEL],
  ["jt", OPLABEL],
  ["getpself", OPBYTE, OPPROP],
  ["getpslfd", OPBYTE, OPPROP],
  ["getpobj", OPBYTE, OPOBJ, OPPROP],
  ["getpobjd", OPBYTE, OPOBJ, OPPROP],
  ["index"],
  [],
  [],
  ["pushpn", OPPROP],
  ["jst", OPLABEL],
  ["jsf", OPLABEL],
  ["jmpd", OPLABEL],
  ["inherit", OPBYTE, OPPROP],
  ["callext", OPBYTE, OPWORD],
  ["dbgret"],
  ["cons", OPBYTE],
  ["switch", OPSWITCH],
  ["argc"],
  ["chkargc", OPBYTE],
  ["line", OPLINE],
  ["frame", OPFRAME],
  ["bp", OPLINE],
  ["getdblcl", OPWORD, OPWORD, OPWORD],
  ["getpptrself", OPBYTE],
  ["mod"],
  ["band"],
  ["bor"],
  ["xor"],
  ["bnot"],
  ["shl"],
  ["shr"],
  ["new"],
  ["delete"]);

sub disasm($) {
 my $block = shift;

 my @switches;
 my $pos = 0, $len = length($block);
 my $numswitches = -1;         # Number of switch table entries left,
                               # -1 means not in switch table
 # (It's this way so that switch tables with only a default get
 # disassembled correctly.)

 while ($pos < $len) {
   print $pos, "\t";

   # The one case where we're not pointed at an opcode: the end of
   # a switch table
   if ($numswitches == 0) {
     print "default\t-> ";
     $pos += printOperand($block, $pos, OPLABEL);
     $numswitches = -1;
     print "\n", $pos, "\t";
   }
   if ($#switches >= 0 && $pos == $switches[0]) {
     print "Switch table\n";
     $numswitches = ord2($block, $pos);
     $pos += 2;
     shift @switches;
   }
   else {
     my $opc = ord1($block, $pos);
     $pos++;
     if ($opc >= 1 && $opc <= $#opcodes) {
       my @opcdata = @{$opcodes[$opc]};
       if ($#opcdata < 0) {
         print "Invalid opcode $opc\n";
         last;
       }
       print $opcdata[0], "\t";
       for (my $i = 1; $i <= $#opcdata; $i++) {
         # Handle operand to switch
         if ($opcdata[$i] == OPSWITCH) {
           @switches = sort(@switches, $pos + ord2s($block, $pos));
         }

         $pos += printOperand($block, $pos, $opcdata[$i]);
         print ", " if ($i < $#opcdata);
       }
     }
     elsif (($opc & 0xc0) == 0xc0) { # Assignment
       print "assign\t";

       my $ext = 0;
       if (($opc & 0x1c) == 0x1c) {
         $ext = ord1($block, $pos);
         $pos++;
       }
       if (($opc & 3) == 0) {
         print "local ", ord2($block, $pos);
         $pos += 2;
       } elsif (($opc & 3) == 1) {
         print "property ";
         printProp(ord2($block, $pos));
         $pos += 2;
       } elsif (($opc & 3) == 2) {
         print "list";
       } else {
         print "property pointer";
       }

       print " :=" if (($opc & 0x1c) == 0x00);
       print " +=" if (($opc & 0x1c) == 0x04);
       print " -=" if (($opc & 0x1c) == 0x08);
       print " *=" if (($opc & 0x1c) == 0x0c);
       print " /=" if (($opc & 0x1c) == 0x10);
       print " ++" if (($opc & 0x1c) == 0x14);
       print " --" if (($opc & 0x1c) == 0x18);
       print " %=" if ($ext == 1);
       print " &=" if ($ext == 2);
       print " |=" if ($ext == 3);
       print " ^=" if ($ext == 4);
       print " <<=" if ($ext == 5);
       print " >>=" if ($ext == 6);

       if (($opc & 0x1c) == 0x14 || ($opc & 0x1c) == 0x18) {
         if ($opc & 0x20) {
           print " pre";
         }
         else {
           print " post";
         }
       }
       else {
         print " and discard" if ($opc & 0x20);
       }
     }
     else {
       print "Invalid opcode ", $opc, "\n";
       last;
     }

     if ($numswitches >= 0) {
       print "\t-> ";
       $pos += printOperand($block, $pos, OPLABEL);
       $numswitches--;
     }
     print "\n";
   }
 }
}

sub processXSI(*$) {
 my $FH = shift;

 $xorseed = read1($FH);
 $xorinc = read1($FH);

 print "  xorseed = ", $xorseed, ", xorinc = ", $xorinc, "\n";
}

sub processOBJ(*$) {
 my $FH = shift;
 my $len = shift;

 while ($len > 0) {
   my $type = read1($FH);
   my $n = read2($FH);
   my $size = read2($FH);
   my $use = read2($FH);
   print "  Object ";
   printObj($n);
   print ":\n    Type $type";
   print " (function)" if ($type == 1);
   print " (object)" if ($type == 2);
   print " (extern)" if ($type == 10);
   print "\n    Size $size\n";
   print "    Size used $use\n";

   my $block;
   read($FH, $block, $use);
   $block = decode($block);

   if ($type == 1) {
     disasm($block);
   }
   else {
     print "    Workspace ", ord2($block, 0), "\n";
     print "    Flags ", ord2($block, 2), "\n";
     print "    Free ", ord2($block, 8), "\n";
     print "    Reset ", ord2($block, 10), "\n";
     print "    Static ", ord2($block, 12), "\n";
     print "    Superclasses:";
     my $n = ord2($block, 4);
     for (my $i = 0; $i < $n; $i++) {
       print " ";
       printObj(ord2($block, 14 + 2 * $i));
     }
     print "\n";

     my $flags = ord2($block, 2);
     my $nprop = ord2($block, 6);

     my $pos = 14 + 2 * $n;

     if ($flags & 2) {
       # Skip the index table if present
       $pos += 2 * $nprop;
     }

     for (my $i = 0; $i < $nprop; $i++) {
       my $num = ord2($block, $pos);
       my $type = ord1($block, $pos + 2);
       my $size = ord2($block, $pos + 3);
       print "    Property ";
       printProp($num);
       print ":\n";
       print "      Datatype ", $type, "\n";
       print "      Size ", $size, "\n";
       print "      Flags ", ord1($block, $pos + 5), "\n";

       if ($type == DAT_CODE) {        # code
         disasm(substr($block, $pos + 6, $size));
       }
       elsif ($type == DAT_DEMAND) {
         print "      implicit contents list\n";
       }
       elsif ($type == DAT_SYN) {      # property synonym
         print "      synonym to property ";
         printProp(ord2($block, $pos + 6));
         print "\n";
       }
       elsif ($type == DAT_REDIR) {    # redirection to another object
         print "      redirection to object ";
         printObj(ord2($block, $pos + 6));
         print "\n";
       }
       elsif ($type == DAT_TPL2) {     # tpl2
         my $i = ord1($block, $pos + 6);
         my $intpos = $pos + 7;

         for (my $j = 0; $j < $i; $j++) {
           print "      preposition ";
           printObj(ord2($block, $intpos));
           print ":\n        verIoVerb ";
           printProp(ord2($block, $intpos + 2));
           print "\n        ioVerb ";
           printProp(ord2($block, $intpos + 4));
           print "\n        verDoVerb ";
           printProp(ord2($block, $intpos + 6));
           print "\n        doVerb ";
           printProp(ord2($block, $intpos + 8));
           print "\n        flags ", ord1($block, $intpos + 10), "\n";
           $intpos += 16;
         }
       }
       else {
         print "      ";
         printValue($block, $pos + 6, $type);
         print "\n";
       }
       $pos += 6 + $size;
     }
   }
   $len -= $use + 7;
 }
}

sub processFST(*$) {
 my $FH = shift;
 my $len = shift;

 while ($len > 0) {
   my $type = read1($FH);
   my $n = read2($FH);
   my $size = read2($FH);
   my $use = read2($FH);
   my $ofs = read4($FH);
   print "  Object ";
   printObj($n);
   print ":\n    Type $type";
   print " (function)" if ($type == 1);
   print " (object)" if ($type == 2);
   print " (extern)" if ($type == 10);
   print "\n    Size $size\n";
   print "    Size used $use\n";
   print "    Offset $ofs\n";
   $len -= 11;
 }
}

sub processINH(*$) {
 my $FH = shift;
 my $len = shift;

 while ($len > 0) {
   my $flag = read1($FH);
   my $n = read2($FH);
   my $loc = read2($FH);
   my $ilc = read2($FH);
   my $i = read2($FH);
   print "  Object ";
   printObj($n);
   print ":\n    Flags $flag\n";
   print "    Loc ";
   printObj($loc);
   print "\n    Ilc ";
   printObj($ilc);
   print "\n    Superclasses:";
   for (my $j = 0; $j < $i; $j++) {
     print " ";
     printObj(read2($FH));
   }
   print "\n";
   $len -= (9 + 2 * $i);
 }
}

sub processREQ(*$) {
 my $FH = shift;
 my $len = shift;

 my @reqnames = ("Me", "takeVerb", "strObj", "numObj", "pardon",
                 "againVerb", "init", "preparse", "parseError",
                 "cmdPrompt", "parseDisambig", "parseError2",
                 "parseDefault", "parseAskobj", "preparseCmd",
                 "parseAskobjActor", "parseErrorParam", "commandAfterRead",
                 "initRestore", "parseUnknownVerb", "parseNounPhrase",
                 "postAction", "endCommand", "preCommand",
                 "parseAskobjIndirect");

 foreach $name(@reqnames) {
   return if ($len <= 0);
   print "  $name: "; printObj(read2($FH)); print "\n";
   $len -= 2;
 }
}

sub processFMTSTR(*$) {
 my $FH = shift;
 my $len = shift;

 my $block;
 $len = read2($FH);
 read($FH, $block, $len);
 $block = decode($block);

 my $pos = 0;
 while ($pos < $len) {
   my $strlen = ord2($block, $pos + 2);
   print "  ", substr($block, $pos + 4, $strlen - 2), " -> ";
   printProp(ord2($block, $pos));
   print "\n";
   $pos += $strlen + 2;
 }
}

sub processCMPD(*$) {
 my $FH = shift;
 my $len = shift;

 my $block;
 $len = read2($FH);
 read($FH, $block, $len);
 $block = decode($block);

 my $pos = 0, $i = 0;

 while ($pos < $len) {
   my $thislen = ord2($block, $pos);
   print "  " if ($i % 3 == 0);
   print substr($block, $pos + 2, $thislen - 2);
   print " " if ($i % 3 == 0);
   print " => " if ($i % 3 == 1);
   print "\n" if ($i % 3 == 2);
   $i++;
   $pos += $thislen;
 }
 print "\n" unless ($i % 3 == 0);
}

sub processSPECWORD(*$) {
 my $FH = shift;
 my $len = shift;

 my $block;
 $len = read2($FH);
 read($FH, $block, $len);
 $block = decode($block);

 my $pos = 0;
 while ($pos < $len) {
   $flags = ord1($block, $pos);
   $strlen = ord1($block, $pos + 1);
   print "  ", substr($block, $pos + 2, $strlen),
     ", flags ", $flags, "\n";
   $pos += $strlen + 2;
 }
}

sub processVOC(*$) {
 my $FH = shift;
 my $len = shift;

 my $pos = 0;

 while ($pos < $len) {
   my $len1 = read2($FH);
   my $len2 = read2($FH);
   my $prpnum = read2($FH);
   my $objnum = read2($FH);
   my $classflg = read2($FH);

   my $block;
   read($FH, $block, $len1 + $len2);
   $block = decode($block);
   print "  ", substr($block, 0, $len1);
   print " ", substr($block, $len1, $len2) if ($len2 != 0);

   print "\n    Prpnum: ";
   printProp($prpnum);
   print "\n    Object: ";
   printObj($objnum);
   print "\n    Class flags: $classflg\n";

   $pos += 10 + $len1 + $len2;
 }
}

if ($#ARGV >= 1 && $ARGV[0] eq '-s') {
 unless ($return = do $ARGV[1]) {
   warn "couldn't parse file: $@" if $@;
   warn "couldn't do $ARGV[1]: $!" unless defined ($return);
   warn "couldn't run $ARGV[1]" unless $return;
 }
 splice(@ARGV, 0, 2);
}
if ($#ARGV != 0) {
 die "Usage: untads [-s symbols] file.gam\n";
}

open(GAM, $ARGV[0]) || die("Couldn't find file $ARGV[0]");
# Assume for now that it is a TADS game; skip to the header flags
seek(GAM, 20, SEEK_SET);
$flags = read1(GAM);
$crypt = $flags & 8;
seek(GAM, 48, SEEK_SET);

for (;;) {
 $namelen = read1(GAM);
 read(GAM, $name, $namelen);
 $nextofs = read4(GAM);
 $curofs = tell(GAM);
 $sectlen = $nextofs - $curofs;
 if ($name eq '$EOF') {
   print "\$EOF marker\n";
   close GAM;
   exit(0);
 }
 print "Section $name: $sectlen bytes ($curofs to $nextofs)\n";

 processXSI(GAM, $sectlen) if ($name eq 'XSI');
 processOBJ(GAM, $sectlen) if ($name eq 'OBJ');
 processFST(GAM, $sectlen) if ($name eq 'FST');
 processINH(GAM, $sectlen) if ($name eq 'INH');
 processREQ(GAM, $sectlen) if ($name eq 'REQ');
 processFMTSTR(GAM, $sectlen) if ($name eq 'FMTSTR');
 processCMPD(GAM, $sectlen) if ($name eq 'CMPD');
 processSPECWORD(GAM, $sectlen) if ($name eq 'SPECWORD');
 processVOC(GAM, $sectlen) if ($name eq 'VOC');

 seek(GAM, $nextofs, SEEK_SET);
}

You are viewing proxied material from mercury.661.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.