$VERSION = 'HYPACK.PL V005, 2002-11-14';
$AUTHOR  = 'Dipl.-Inf. Herbert Oppmann';
#PURPOSE =  pack / unpack NexGen Nx586 hypercode

$PAKFILE = 'p06y034q.prd';
$UNPFILE = 'hyp034q.bin';

# --- help (no return) -----------------------------------------------------

sub help {
   die <<_quote;
Pack / unpack NexGen Nx586 PCI hypercode

syntax:
  perl hypack.pl {-option}* [inputfile [outputfile]]

options:
  ?            show this help screen
  tn           test version n (default n=0)
  u            unpack
  vn           verbose output (default n=0, 1=more verbose)
  V            show program version

defaults (pack / unpack):
  inputfile    $UNPFILE / $PAKFILE
  outputfile   $PAKFILE / $UNPFILE
_quote
   ;
}

# --- parse command line ---------------------------------------------------

$opt_t = -1;   # test version
$opt_u = 0;    # unpack
$opt_v = -1;   # verbose output
$src_n = '';   # source file
$dst_n = '';   # destination file

$fcount =0; # filename counter
foreach $arg (@ARGV) {
   if ($arg =~ /^-(.*)/) {
      # option(s)
      die "option syntax error!" if $1 !~ /^([?tuvV])([0-9]*)$/;
         if ($1 eq '?') { &help; }
      elsif ($1 eq 't') { $opt_t = ($2 eq '') ? 0 : $2; }
      elsif ($1 eq 'u') { $opt_u =1; }
      elsif ($1 eq 'v') { $opt_v = ($2 eq '') ? 0 : $2; }
      else { print "$VERSION by $AUTHOR"; exit; } # 'V'
   } else {
      # filename
      if ($fcount > 1) {
         print "warning: argument \"$arg\" ignored, use -? for help\n";
      }
      $src_n = $arg if $fcount == 0;
      $dst_n = $arg if $fcount == 1;
      $fcount++;
   }
}
die "option -t can't be used on unpacking!" if $opt_u && ($opt_t != -1);
die "option -t: n must be < 99!" if length($opt_t) >2;

if ($src_n eq '') {
   $src_n = $opt_u ? $UNPFILE : $PAKFILE;
}
if ($dst_n eq '') {
   $dst_n = $opt_u ? $PAKFILE : $UNPFILE;
}

# --- open files, un/pack, close files -------------------------------------

open(SRC,"<$src_n") || die "error: can't open $src_n";
binmode(SRC);
open(DST,">$dst_n") || die "error: can't open $dst_n";
binmode(DST);
print "Reading $src_n, writing to $dst_n\n" if $opt_v;

if ($opt_u) {
   &unpack();
} else {
   &pack();
}

close SRC;
close DST;
end;

# --- unpack ---------------------------------------------------------------

# unpack_fill
# arguments: count size, fill size (1=byte, 2=word)
sub unpack_fill {
   my ($cs, $fs) = @_;
   my $r, $len;
   read(SRC,$r,$cs);
   $len = unpack(($cs==1) ? 'C':'S',$r);
   read(SRC,$r,$fs);
   print DST $r x $len;
   if ($opt_v >0) {
      printf("%5Xh | fill%5d | %02Xh\n",
      $curr,$len,unpack(($fs==1) ? 'C':'S',$r));
   }
}

# unpack_copy
# arguments: count size (1=byte, 2=word)
sub unpack_copy {
   my ($cs) = @_;
   my $r, $len, $lout, @u;
   read(SRC,$r,$cs);
   $len = unpack(($cs==1) ? 'C':'S',$r);
   read(SRC,$r,$len);
   print DST $r;
   if ($opt_v >0) {
      printf("%5Xh | copy%5d |",$curr,$len);
      $lout = ($len > 12) ? 12 : $len;
      @u = unpack("C$len",$r);
      while ($lout--) {
         printf(" %02Xh", shift @u);
      }
      print ' ..' if $len >12;
      print "\n";
   }
}

sub unpack {
   my $matched, $r, $pak_start, $pak_end, $pak_len, $unp_end, $unp_len;
   # find signature 'ASRE', copying unpacked stream
   # (packed byte stream starts after this signature)
   $matched=0;
   while (not eof SRC) {
      read(SRC,$r,1);
      print DST $r;
         if (($matched == 0) && ($r eq 'A')) { $matched++; }
      elsif (($matched == 1) && ($r eq 'S')) { $matched++; }
      elsif (($matched == 2) && ($r eq 'R')) { $matched++; }
      elsif (($matched == 3) && ($r eq 'E')) { last; }
      else { $matched =0; }
   }
   die "error: can't find signature 'ASRE'!" if eof SRC;
   $pak_start = tell(SRC);
   printf("Packed stream starts at %Xh\n",$pak_start) if $opt_v > -1;

   # unpack
   read(SRC,$r,1);
   if ($r ne "\x7F") {
      printf("warning: packed data starts with code %Xh instead of 7Fh at %Xh",
         unpack('C',$r), $pak_start);
   }
   seek(SRC,-1,1);

   print "\n",
         "input\n",
         "offset |action len | value(s)\n",
         "-------+-----------+---------------------------------------------------\n" if $opt_v >0;
   while (not eof SRC) {
      $curr = tell(SRC) if $opt_v >0;
      read(SRC,$r,1);
      if ($r eq "\x00") {
         &unpack_fill(1, 1); # fill byte (small amount)
      } elsif ($r eq "\x80") {
         &unpack_fill(2, 1); # fill byte (big amount)
      } elsif ($r eq "\x01") {
         &unpack_fill(1, 2); # fill word (small amount)
      } elsif ($r eq "\x81") {
         &unpack_fill(2, 2); # fill word (big amount)
      } elsif ($r eq "\x7F") {
         &unpack_copy(1);    # copy (small amount)
      } elsif ($r eq "\xFF") {
         &unpack_copy(2);    # copy (big amount)
      } elsif ($r eq "\xFE") {
         last;               # done (just after signature 'ASRD')
      } else {
         die sprintf("error: unknown code %Xh found at %Xh",
            unpack('C',$r), tell(SRC));
      }
   }
   ($r eq "\xFE") || die "error: unexpected end of file";
   print "-------+-----------+---------------------------------------------------\n\n" if $opt_v >0;

   # statistics
   if ($opt_v > -1) {
      $pak_end = tell(SRC);
      $pak_len = $pak_end-$pak_start;
      $unp_end = tell(DST);
      $unp_len = $unp_end-$pak_start;
      printf("Packed stream ends at %Xh\n",$pak_end);
      printf("Unpacked stream ends at %Xh\n",$unp_end);
      printf("Unpacked %d byte to %d byte (%d%% expansion)\n",
         $pak_len, $unp_len, (($unp_len*100)/$pak_len)-100);
   }
}


# --- pack -----------------------------------------------------------------

# output a "copy" sequence
sub pack_copy {
   my ($menge) = @_;
   if ($menge < 256) {
      print DST pack('CC',0x7F,$menge); # small
   } else {
      print DST pack('CS',0xFF,$menge); # large
   }
   while ($menge--) {
      print DST pop @cache;
   }
}


# output a "fill byte" sequence
sub pack_fillb {
   my ($menge, $value) = @_;
   if ($menge < 256) {
      print DST pack('CC',0x00,$menge), $value; # small
   } else {
      print DST pack('CS',0x80,$menge), $value; # large
   }
}


# output a "fill word" sequence
sub pack_fillw {
   my ($menge, $valu1, $valu2) = @_;
   if ($menge < 256) {
      print DST pack('CC',0x01,$menge), $valu1, $valu2; # small
   } else {
      print DST pack('CS',0x81,$menge), $valu1, $valu2; # large
   }
}


# handle end of sequence of bytes
sub pack_bytes {
   # ok to do a "fill byte" sequence?
   if (($multiple >= 8) && ($fpos < $pak_stop)) {
      # flush cache and output "fill byte" sequence
      if ($#cache > 0) {
         &pack_copy($#cache);
      }
      &pack_fillb($multiple, $cache[0]);
      @cache = ();
   } else {
      # undo byte sequence
      while (--$multiple) {
         unshift @cache, $cache[0];
      }
   }
}


# handle end of sequence of words
sub pack_words {
   # ok to do a "fill word" sequence?
   if (($multiple >= 5) && ($fpos < $pak_stop)) {
      # flush cache and output "fill word" sequence
      if ($#cache > 1) {
         &pack_copy($#cache-1);
      }
      &pack_fillw($multiple, $cache[1], $cache[0]);
      @cache = ();
   } else {
      # undo word sequence
      while (--$multiple) {
         unshift @cache, $cache[0], $cache[1];
      }
   }
}


sub pack {
   my $matched, $r, $fpos, $checksum, $unp_start, $pak_stop;
   my $state, @cache, $multiple, $tmp, $pak_end, $pak_len, $unp_end, $unp_len;

   # first pass
   # ==========
   # calculate checksum from 0-0x800 and 0x1800-official end of
   # unpacked stream; find signature 'ASRE' (start of packing),
   # official end of unpacked stream

   print "First pass ...\n" if $opt_v >0;
   $checksum =0;
   $ENDHYP =0x14A4; # hypercode data structure, entry h_endhyp

   # first few words
   $fpos =0;
   while ($fpos < 0x10) {
      die 'error: unexpected end of file' if eof SRC;
      read(SRC,$r,2);
      $checksum += unpack('S',$r);
      $fpos +=2;
   }
   # skip magic, checksum field
   read(SRC,$r,4);
   $checksum += 0x1234; # magic
   $fpos += 4;
   # search for signature 'ASRE' (must be word-aligned!)
   $matched =0;
   while ($fpos < 0x800) {
      die 'error: unexpected end of file' if eof SRC;
      read(SRC,$r,2);
      $checksum += unpack('S',$r);
      $fpos +=2;
      if ($matched ==0) {
         $matched =1 if $r eq 'AS';
      } elsif ($matched ==1) {
         if ($r eq 'RE') {
            $matched =2;
            $unp_start =$fpos;
            printf("Signature 'ASRE' found at %Xh\n",$fpos-4) if $opt_v >0;
         } else {
            $matched =0;
         }
      }
   }
   ($matched ==2) || die "Can't find signature 'ASRE'!";
   printf("Unpacked stream starts at %Xh\n",$unp_start) if $opt_v > -1;

   # read official end of unpacked stream (for checksum)
   seek(SRC,$ENDHYP,0) || die sprintf("error: can't seek to %Xh",$ENDHYP);
   (read(SRC,$r,4) ==4) || die sprintf("error: can't read from offset $Xh",$ENDHYP);
   $unp_end = unpack('L',$r);

   # continue calculating checksum
   seek(SRC,0x1800,0) || die "error: can't seek to 1800h";
   $fpos = 0x1800;
   while ($fpos < $unp_end) {
      die 'error: unexpected end of file' if eof SRC;
      read(SRC,$r,2);
      $checksum += unpack('S',$r);
      $fpos +=2;
   }
   $checksum = 0x10000 - ($checksum & 0xFFFF);

   # second pass
   # ===========
   # copy unpacked part, inserting new checksum
   # pack all bytes from signature to actual end of file
   # stop packing at signature sig2

   print "Second pass ...\n" if $opt_v >0;
   seek(SRC,0,0);
   $sig2 = '@(#)cpustub.asm';
   @sig2s = split(//,$sig2);
   $sig2n = $#sig2s;

   # copy unpacked part, inserting new checksum
   read(SRC,$r,16);
   seek(SRC,4,1); # skip checksum, magic fields
   print DST $r, pack('SS',$checksum, 0x1234);
   read(SRC,$r,$unp_start - 0x14);
   print DST $r;

   # pack
   $fpos = $unp_start;
   $state =0;
   @cache = ();
   $matched =0;
   $pak_stop = 0x20000; # 128 KB (don't stop)

   # state:
   # 0 = searching for duplicate byte or word
   # 1 = do sequence of identical bytes
   # 2 = do sequence of identical words (even byte)
   # 3 = do sequence of identical words (odd byte)
   while (not eof SRC) {
      read(SRC,$r,1);
      $fpos++;
      if ($matched <= $sig2n) {
         if ($r eq $sig2s[$matched]) {
            $matched++;
            if ($matched > $sig2n) {
               $pak_stop = $fpos;
               printf("Signature '$sig2' found at %Xh\n",$fpos-$sig2n-1) if $opt_v >0;
            }
         } else {
            $matched =0;
         }
      }
      if ($state ==0) {
         if (($#cache >= 0) && ($r eq $cache[0])) {
            $state =1;
            $multiple =2;
         } elsif (($#cache >= 2) && ($r eq $cache[1]) && ($cache[0] eq $cache[2])) {
            $state = 2;
            $multiple =2;
            shift @cache; # remove half word
         } else {
            unshift @cache, $r;
         }
      } elsif ($state ==1) { # byte
         if ($r eq $cache[0]) {
            $multiple++;
         } else {
            &pack_bytes();
            unshift @cache, $r;
            $state =0;
         }
      } elsif ($state ==2) { # word, even byte
         if ($r eq $cache[1]) {
            $state =3;
         } else {
            &pack_words();
            unshift @cache, $r;
            $state =0;
         }
      } elsif ($state ==3) { # word, odd byte
         if ($r eq $cache[0]) {
            $multiple++;
            $state =2;
         } else {
            $tmp = $cache[1];
            &pack_words();
            unshift @cache, $r, $tmp;
            $state =0;
         }
      }
   }

   # drain cache and terminate packed byte stream
   if ($state ==1) {
      &pack_bytes();
   } elsif ($state ==2) {
      &pack_words();
   } elsif ($state ==3) {
      $tmp = $cache[1];
      &pack_words();
      unshift @cache, $tmp;
   }
   if ($#cache >=0) { &pack_copy($#cache+1); }
   print DST pack('C',0xFE);

   # fill up to 0x8000 (32 KB)
   $pak_end = tell(DST);
   $pak_ceil = ($opt_t > -1) ? 0x7FF0 : 0x7FFE;
   die 'error: code does not fit in 32 KB!' if $pak_end > $pak_ceil;
   $multiple = $pak_ceil - $pak_end;

   while ($multiple--) {
      print DST pack('C',0xFF);
   }
   if ($opt_t > -1) {
      printf DST "Test Vers %02d", $opt_t;
      print DST pack('CC',0xFF,0xFF);
   }
   print DST pack('S',0x0C34);

   # statistics
   if ($opt_v > -1) {
      $unp_end = tell(SRC);
      $unp_len = $unp_end-$unp_start;
      $pak_len = $pak_end-$unp_start;
      printf("Unpacked stream ends at %Xh\n",$unp_end);
      printf("Packed stream ends at %Xh\n",$pak_end);
      printf("Packed %d byte to %d byte (%d%% compression)\n",
         $unp_len, $pak_len, 100-($pak_len*100)/$unp_len);
   }
}