#!/usr/bin/perl -w
#
# Adds Atari800 emulator cartridge header if missing,
# otherwise it merely updates the header contents.
#
# Written by Nathan Hartwell
#
# 1.0 - 12/3/2001  - Initial release
#
# 1.1 - 12/3/2001  - Improved error handling if file does not exist.
#                    Added '@' to cartridge type selection.
#                    Added auto big-/little-endian check for checksum byte swap.
#
# 1.2 - 12/13/2001 - Rewritten based on the rewrite from Jindroush.  I don't like
#                    inability of having to wait until the user presses [ENTER]
#                    before processing the input given, but until I find a fully
#                    portable single character input solution, this will have to
#                    do.
#
# 1.3 - 12/14/2001 - I couldn't stand having to hit the [ENTER] key everytime.
#                    So, I dropped in some code to use the Term::ReadKey module.
#                    If your perl does't have this module, I'm sorry.  It works
#                    with the perl distribution for cygwin (perl 5.6.1), but the
#                    perl on my Linux router doesn't have that module.  The perl
#                    version on my home Linux system is 5.005_03 and will be
#                    upgraded shortly.  :)
#
# 1.4 - 12/17/2001 - Code cleaned up to remove warnings while "use strict;" is in
#                    place.
#
# 1.5 - 12/18/2001 - More code tweak suggestions from Jindroush added.
#

use strict;
use integer;
use Fcntl;
$| = 1;

my $use_ReadKey = 0;
if (!eval{require Term::ReadKey;})
{
  warn "Install Term::ReadKey to enable single character key input.\n";
}
else
{
  import Term::ReadKey;
  $use_ReadKey = 1;
}

my @TypeNames =
(
  "Standard 8K (800/XL/XE)",
  "Standard 16K (800/XL/XE)",
  "OSS '034M' 16K (800/XL/XE)",
  "Standard 32K (5200)",
  "DB 32K (800/XL/XE)",
  "2 chip 32K (5200)",
  "Bounty Bob Strikes Back (5200)",
  "8x8 D50x 64K (800/XL/XE )",
  "Express 64K (800/XL/XE)",
  "Diamond 64K (800/XL/XE)",
  "SpartaDOS X 64K (800/XL/XE)",
  "XEGS 32K (800/XL/XE)",
  "XEGS 64K (800/XL/XE)",
  "XEGS 128K (800/XL/XE)",
  "OSS 'M091' 16K (800/XL/XE)",
  "1 chip 16K (5200)",
  "ATRAX 128K (800/XL/XE)",
  "Bounty Bob Strikes Back (800/XL/XE)",
  "Standard 8K (5200)",
  "Standard 4K (5200)",
  "Right Slot 8K (800)" 
);

my %Types =
(
  4096 =>   [ 20 ],
  8192 =>   [ 0, 19, 21 ],
  16384 =>  [ 1, 2, 14, 15 ],
  32768 =>  [ 3, 4, 5, 11 ],
  40960 =>  [ 6, 17 ],
  65536 =>  [ 7, 8, 9, 10, 12 ],
  131072 => [ 13, 16 ]
);

print "\nAtari800 Cartridge Header Creator/Updater v1.5\n";
print "With major code improvements inspired by Jindroush\n";
print "By Nathan Hartwell - December 18th, 2001\n";

while (@ARGV)
{
  my $file = shift @ARGV;

  if (! -f $file)
  {
    print "File '$file' does not exist\n";
    next;
  }
  sysopen(ROM, $file, O_RDWR)
    or die "Error opening '$file'\n";
  my $size = -s $file;

  binmode(ROM);

  my $magic;
  my $ct;
  my $csum0;
  my $dirty = 1;

  if (($size & 0x1F) == 0x10)
  {
    #possibly valid header found
    $size -= 16;
    my $curhdr;
    sysread(ROM, $curhdr, 16);
    ($magic, $ct, $csum0, undef) = unpack("A4NNN", $curhdr);
    $dirty = 0;
  }
  else
  {
    #check for valid image size
    if (!exists($Types{$size}))
    {
      printf(STDERR "Unsupported image size: '$file' size=$size\n");
      next;
    }
    print "\nMissing header, adding...\n";
  }

  print "\n     ROM: $file\n";

  my $body;
  sysread(ROM, $body, $size);

  my $csum = 0;
  foreach my $bv (unpack('C*', $body))
  {
    $csum += $bv;
  }

  print "Checksum: ";
  if ($csum != $csum0)
  {
    if ($dirty)
    {
      print "New Header - Computing\n";
    }
    else
    {
      print "Bad\n";
    }
  }
  else
  {
    print "OK\n";
  }

  if (defined $ct)
  {
    printf "    Type: %c - %s\n", $ct + 0x40, $TypeNames[$ct - 1];
  }
  print "\nSelect cartridge type:\n\n";

  my $vt = $Types{$size};
  foreach my $_t (@$vt)
  {
    print " " . chr($_t + 0x41), ') ' . $TypeNames[$_t], "\n";
  }
  print "\n  Just press [Enter] to keep current header value.\n\n";
  print "    Choose: ";

  while (1)
  {
    my $key;

    if (!$use_ReadKey)
    {
      $key = getc();
    }
    else
    {
      ReadMode(4);
      $key = ReadKey(0);
      ReadMode(0);
    }

    $key = uc($key);

    if ($dirty)
    {
      next unless ($key ge 'A' and $key le 'Z');
    }
    else
    {
      next unless ($key eq chr(10) or $key eq chr(13) or ($key ge 'A' and $key le 'Z'));
    }

    if ($key eq chr(10) or $key eq chr(13))
    {
      last;
    }

    $key = ord($key) - 0x41;

    my $found;
    map($found |= ($_ == $key) ? 1 : 0, @$vt);

    if ($found)
    {
      $ct = $key + 1;
      last;
    }

  }

  if (!$use_ReadKey)
  {
    print "\nSelected type: ";
  }

  print $TypeNames[$ct - 1], "\n\n";

  #rewrite image file with new/valid header
  seek(ROM, 0, 0);
  my $hdr = pack('A4NNN', 'CART', $ct, $csum, 0);
  syswrite(ROM, $hdr, 16);
  if ($dirty)
  {
    syswrite(ROM, $body, $size);
  }
  close(ROM);

}