#!perl

#
# if2pdb.pl version 1.0
#
# By Rick Reynolds <rick@rickandviv.net> with code based on z2pdb.pl and 
# hugo2pdb.pl
#
# Perl author: Jonathan Ferro <jonrock@yahoo.com>
# Conversion routine based on C code by: Alien Hunter <alien_hunter@hotmail.com>
#


require Getopt::Long;

Getopt::Long::GetOptions("frotz","frobnitz","nointer","h","help", "v", "version");

# help screen
if (defined $opt_h or defined $opt_help) {
   print <<__USAGE__;
if2pdb.pl

A converter tool to create Palm DB files for use with PalmOS versions of 
Z-machine and Hugo IF interpreters.  

This tool will prompt the user for the story name (unless -nointer is chosen).

This tool can be used to convert multiple story files at one time.


Usage: perl if2pdb.pl [options] [filenames]

Convert the given filenames to .pdb files.

If no filenames are given, it will look at all the .z?, .dat, and .hex files 
in the current directory and convert them if they have not already been 
converted (if a file of the same name with a .pdb suffix is not present).

Options:
    -frobnitz  When converting .z? and .dat files, produce PDB files for use 
               with Frobnitz (default)
    -frotz     When converting .z? and .dat files, produce PDB files for use 
               with Pilot-Frotz
    -nointer   No prompts, just name games as filenames
__USAGE__
   exit;
}

# version
if (defined $opt_v or defined $opt_version) {
   print <<__VERSION__;
if2pdb.pl version 1.0
__VERSION__
   exit;
}


# there are 2 zcode interpreters supported, decide which will be used
$zinterpreter = "Frobnitz";   # default to Frobnitz

if (defined $opt_frotz) {
   $zinterpreter = "Frotz";
}

if (defined $opt_frobnitz) {
   $zinterpreter = "Frobnitz";
}

# did the user give any specific files?
if ($#ARGV > -1) {

   # copy the filenames from the command line
   @files = @ARGV;

} else {

   # open the current directory and get a list of all .hex and .z? files
   opendir DIRH, "." or die "Cannot open directory (??): $!\n";
   @files = readdir DIRH;
   closedir DIRH;
   
   @zfiles = grep /\.z.$/i,@files;
   @datfiles = grep /\.dat$/i,@files;
   @hexfiles = grep /\.hex$/i,@files;
   
   @files = @zfiles;
   push @files, @datfiles;
   push @files, @hexfiles;

   sort @files;
}

# loop over all the files found
foreach $file (@files) {

   # make sure the source file exists
   if (! -f "$file") {
      print "$file : No such file.\n";
      next;
   }

   #
   # deal with filenames and create default story name
   #

   # copy basename and extension of original filename
   ($pdb = $file) =~ s/\..*//;
   ($ext = $file) =~ s/[^.]*.//;

   #
   # make a default story name from the basename
   #

   # grab lowercase version of the filename
   $lower = lc($pdb);

   # uppercase first letter
   $default = substr($lower,0,1);
   $default = uc($default);

   # copy the rest of the name
   $default .= substr($lower,1);

   # change any _ to spaces
   $default =~ s/_/ /g;

   # make sure default name isn't > 31 chars
   if (length($default) > 31) {
      $default = substr($default,0,31);
   }

   #
   # add pdb extension to filename
   #
   
   # respect the user's naming convention (if possible)
   if ($ext eq uc($ext)) {
      $pdb .= ".PDB";
   } else {
      $pdb .= ".pdb";
   }

   # setup initial condition
   $processIt = 1;

   # check for a .pdb file already here
   if (-f $pdb) {
      #
      # should we convert again (is the game file newer?)
      #

      # get modified times for both the original story file and the pdb file
      $mtimeFile = (stat $file)[9];
      $mtimePdb = (stat $pdb)[9];

      # if the pdb file is newer, don't process this game
      if ($mtimeFile <= $mtimePdb) {
         $processIt = 0;
      }
   }


   if ($processIt) {
      # does the user want to input the story names or just let the program 
      # assign them?
      if (defined $opt_nointer) {

         # batch style processing
         $iffile = $file;
         $pdbfile = $pdb;
         $title = $default;  # this can't be longer than 31

      } else {

         # query the user for the story name
AGAIN: print "\nStoryname for $file (hit RETURN for \"$default\", SS to skip file, QQ to quit):";
         $name = <STDIN>;
   
         chomp($name);
   
         if ($name eq "") {
            $name = $default;
         }
   
         # allow user to exit
         if ($name eq "QQ") {
            exit;
         }

         # allow the user to skip conversion of this file
         if ($name eq "SS") {
            next;
         }
   
         # check name length
         if (length($name) > 31) {

            # offer to fix it
            $name = substr($name,0,31);
            print "\nThat title is too long, should I title the game \"$name\"?[Y/n]";
            $yn = <STDIN>;
            chomp($yn);
   
            # branch back to let the user input the name again
            if ($yn =~ m/n/i) {
               goto AGAIN;
            }
         }
      
         # we have the filenames and title
         $iffile = $file;
         $pdbfile = $pdb;
         $title = $name;
      }


      # based on the type of file, create Z-machine or Hugo files
      if ($ext =~ m/hex/i) {
         # doing a Hugo file
         $interpreter = "Hugo";
         $dbType = "Hugo";
         $dbId = "HUGO";

      } else {
         # doing a Z-machine file (either Frotz or Frobnitz)
         $interpreter = $zinterpreter;
         $dbType = "ZCOD";

         if ($interpreter eq "Frobnitz") {
            $dbId = "Frtz";
         } else {
            $dbId = "Fotz";
         }
      }

      print "Creating $interpreter file $pdbfile of game $title ...\n";
      convert2pdb($iffile,$pdbfile,$title,$dbType,$dbId);
   }
}

sub convert2pdb {
   # convert2pdb: convert an IF format file to a PDB format file suitable for 
   # installing on a Palm device for use with Frobnitz, Pilot-Frotz, or 
   # Palm-Hugo.
   #
   # Reconfigured slightly by Rick Reynolds, based on z2pdb.pl and hugo2pdb.pl
   # Perl author: Jonathan Ferro <jonrock@yahoo.com>
   # Based on C code by: Alien Hunter <alien_hunter@hotmail.com>
   #
   # Usage:
   #  convert2pdb(<IF filename>, <PDB filename>, <Story title>, 
   #              <Palm DB type>, <Palm DB ID>);
   #
   # convert2pdb will write a new file in the current directory.
   #
   # NOTE: since this routine accepts as inputs the Palm DB type and the Palm 
   # DB ID, it is conceivable that this will work for future PalmOS 
   # interpreters as well without modification (as long as they follow the 
   # pattern that has been laid down!).
   
   # get arguments
   my ($iffile, $pdbfile, $title, $dbType, $dbId) = (@_);

   # declare as local variables
   my ($reclen,$records,$ifdata,$buf,$pdbheader,$recheader,$offset,$rec);

   $reclen = 4096; # Use 4K chunks.
   
   ## Open appropriate files and check for errors.
   open IFF, "$iffile" or die "Can't open $iffile: $!\n";
   binmode IFF;
   open PF, ">$pdbfile" or die "Can't write to $pdbfile: $!\n";
   binmode PF;
   
   ## Slurp in IF file, counting the number of resulting records.
   $records = 0;

   while (read IFF, $buf, $reclen) {
      ## special case for Frotz
      if ($dbId eq "Fotz") {
         # Make sure that the last record is null-filled for Frotz
         $ifdata .= pack "a$reclen", $buf;
      } else {
         $ifdata .= $buf;
      }
      $records++;
   }
   
   ## Construct and write database header.
   $pdbheader = pack "a31xn2N6a4a4N2n",
     $title, # Name of database
     0, # Database attributes
     1, # Version number
     0x34ac829f, # Creation date
     0x34ac829f, # Modification date
     0, # Last backup date
     0, # Modification number
     0, # App info area (nonexistent)
     0, # Sort info area (nonexistent)
     $dbType, # Database type
     $dbId, # Database creator ID
     0, # Unique ID seed
     0, # Next record list ID (unused?)
     $records; # Number of records
   print PF $pdbheader;
   
   ## Calculate offset of first record, using dummy record header for size.
   $recheader = pack "NCx3";
   $offset = length($pdbheader) + $records * length($recheader);
   
   ## Construct and write record headers.
   for $rec (0 .. ($records - 1)) {
      $recheader = pack "NCx3",
        $rec * $reclen + $offset, # Record data offset
        0x60; # Record attributes (BUSY|DIRTY)
      print PF $recheader;
   }
   
   ## Finally, write the records themselves.
   print PF $ifdata;
   
   close PF;
}
