#!/usr/bin/perl

# PRC/PDB creation tool v1.1, 13 March 2000 by Ka-Ping Yee <ping@lfw.org>
# fix for years >= 2000 (thanks to Matt Curtin <cmcurtin@interhack.net>)

# PRC/PDB creation tool v1.0, 24 February 1997 by Ka-Ping Yee <ping@lfw.org>
#
# This script should be named "prc" to create PRC (resource database) files
# or "pdb" to create PDB (record database) files.  To install, save this
# script as a file named "prc", make "prc" executable with "chmod +x prc",
# and then create a link with the command "ln -s prc pdb".

$pdbhelp = <<PDBHELP;
PDB creation tool v1.1, 13 March 2000 by Ka-Ping Yee <ping\@lfw.org>

usage: pdb -t <type> -c <creator> -n <name> <record> <record> ...
           Creates a record database from the binary data in the files listed.
           Files will be stored as individual records in the order given.
           The first eight characters of each filename must give the category
           (as a letter from A to O or \@ for unfiled), attributes (as a single
           hex digit), and unique id (as a six-digit hex number) of the record.
           The attribute bits are 1 for a private record, 2 for a busy record,
           4 for a record to be archived, or 8 for a record to be deleted.

       pdb -x [-t <type>] [-c <creator>] [-n <name>] [<textfile>]
           Creates a record database using the information in the text file.
           If <textfile> is "-" or not given, information is read from stdin.

For both forms, the -b and -r options turn on the "backup" and "read-only"
attributes of the new database.  The -a and -s options can be used to give
the names of files containing app-info or sort-info, and the -v option can
be used to give a version number.  The created database is written to stdout.
PDBHELP

$prchelp = <<PRCHELP;
PRC creation tool v1.1, 13 March 2000 by Ka-Ping Yee <ping\@lfw.org>

usage: prc [-t <type>] -c <creator> -n <name> <resource> <resource> ...
           Creates a resource database from the binary data in the files
           listed.  If no database type is given, "appl" is assumed.  The
           first eight characters of each filename must give the type and id
           (in hex) of the corresponding resource; for example, a file named
           "tAIB03e8.bin" will be stored as resource type "tAIB" number 1000.  

       prc -x [-t <type>] [-c <creator>] [-n <name>] [<textfile>]
           Creates a resource database using the information in the text file.
           If <textfile> is "-" or not given, information is read from stdin.

For both forms, the -b and -r options turn on the "backup" and "read-only"
attributes of the new database.  The -a and -s options can be used to give
the names of files containing app-info or sort-info, and the -v option can
be used to give a version number.  The created database is written to stdout.
PRCHELP

sub monthtime
    {
    local($y, $l, $guess) = ($_[0], $_[1], time());
    local(@tm) = gmtime($guess);
    while ($diff = $y - ($tm[5] + 1900))
        { @tm = gmtime($guess += $diff * 363 * 86400); }
    while ($diff = $l - $tm[4])
        { @tm = gmtime($guess += $diff * 27 * 86400); }
    return $monthtime{pack('C2', $y, $l)} =
        $guess - $tm[3] * 86400 - $tm[2] * 3600 - $tm[1] * 60 - $tm[0];
    }

sub timegm
    {
    local($s, $m, $h, $d, $l, $y) = @_;
    $y += $y < 70 ? 2000 : 1900 if $y < 1900;
    $y = 1970 if $y < 1970;
    $l = $l < 0 ? 0 : $l > 11 ? 11 : $l;
    local($mt) = $monthtime{pack('C2', $y, $l)} || &monthtime($y, $l);
    return $mt + $d * 86400 + $h * 3600 + $m * 60 + $s;
    }

sub ptime
    { return ($_[5] ? &timegm(@_) : ($_[0] || time())) + 2082844800; }

sub getopt
    {
    local($arg, $opt, $o) = ($_[0]);
    while ($ARGV[0] =~ /^-(\w)/)
        {
        ($opt = shift(@ARGV)) =~ s/^-//;
        while ($opt =~ s/^(\w)//)
            {
            $o = $1;
            if ($arg !~ /$o/) { $opt{$o} = 1; }
            else { $opt{$o} = $opt ne '' ? $opt : shift(@ARGV); last; }
            }
        }
    }

sub streval
    { $_[0] =~ s/\\(r|t|n|x[0-9a-f]+|0[0-7]+|\\)/eval("\"$&\"")/eg; $_[0]; }

sub numeval
    { $_[0] =~ /0x[0-9a-fA-F]+|0[0-7]+|[0-9]+/ ? eval($&) : 0; }

sub dteval
    { return eval($&) if $_[0] =~ /0x[0-9a-fA-F]+/;
    $_[0] =~ m#(\d+)-(\d+)-(\d+)\s+((\d+):(\d+)(:(\d+))?)?# ||
        &warn("line $.: could not interpret date/time format");
    return &ptime($8, $6, $5, $3, $2-1, $1); }

($prefix = $0) =~ s/.*\///;
if ($prefix eq 'pdb') { $opt{'d'} = 1; }
sub warn { print STDERR "$prefix: $_[0]\n"; }
sub die { print STDERR "$prefix: $_[0]\n"; exit 1; }

&getopt('tcn');
if ($opt{'h'} || !(@ARGV || $opt{'x'}))
    { print STDERR ($opt{'d'} ? $pdbhelp : $prchelp); exit; }

$crtime = &ptime(); $mdtime = &ptime(); $bktime = 0; $si = $offset = 0;

if ($opt{'x'})
    {
    ($type, $creator, $name) = @opt{'t', 'c', 'n'};
    $dbver = &numeval($opt{'v'});
    while (<>)
        {
        next if /^#/; next unless /(\S+)\s*=?\s*/;
        chop($args = $'); ($dir = $1) =~ tr/A-Z/a-z/;
        $prefix = "line $.";
        if ($dir eq 'app-info' || $dir eq 'sort-info')
            { }
        elsif ($dir eq 'record')
            {
            foreach $arg (split(' ', $args))
                {
                ($attr, $val) = split('=', $arg); $attr =~ tr/A-Z/a-z/;
                if    ($attr =~ /^cat/)     { $cat[$si] = ord($val)%16; }
                elsif ($attr eq 'id')       { $id[$si] = &numeval($val); }
                elsif ($attr =~ /^priv/)    { $attr[$si] |= 0x10; }
                elsif ($attr =~ /^busy/)    { $attr[$si] |= 0x20; }
                elsif ($attr =~ /^arch/)    { $attr[$si] |= 0x40; }
                elsif ($attr =~ /^del/)     { $attr[$si] |= 0x80; }
                else { &warn("unknown record attribute $attr"); }
                }
            $attr[$si] |= $cat[$si];
            }
        elsif ($dir eq 'resource')
            {
            foreach $arg (split(' ', $args))
                {
                ($attr, $val) = split('=', $arg); $attr =~ tr/A-Z/a-z/;
                if    ($attr eq 'type')     { $type[$si] = substr($val,0,4); }
                elsif ($attr eq 'id')       { $id[$si] = &numeval($val); }
                else { &warn("unknown resource attribute $attr"); }
                }
            }
        else
            {
            if    ($dir eq 'name')          { $name = &streval($args); }
            elsif ($dir eq 'open')          { $dbattr |= 0x8000; }
            elsif ($dir eq 'record-db')     { $dbattr &= ~1; }
            elsif ($dir eq 'resource-db')   { $dbattr |= 1; }
            elsif ($dir eq 'read-only')     { $dbattr |= 2; }
            elsif ($dir eq 'appinfo-dirty') { $dbattr |= 4; }
            elsif ($dir eq 'backup')        { $dbattr |= 8; }
            elsif ($dir eq 'version')       { $dbver = &numeval($args); }
            elsif ($dir eq 'create-time')   { $crtime = &dteval($args); }
            elsif ($dir eq 'modify-time')   { $mdtime = &dteval($args); }
            elsif ($dir eq 'backup-time')   { $bktime = &dteval($args); }
            elsif ($dir eq 'modify-count')  { $mdcount = &numeval($args); }
            elsif ($dir eq 'id-seed')       { $idseed = &numeval($args); }
            elsif ($dir eq 'type')          { $type = substr($args,0,4); }
            elsif ($dir eq 'creator')       { $creator = substr($args,0,4); }
            else { &warn("unknown directive $dir"); }
            next;
            }

        $data = '';
        while (($_ = <>) =~ /^\s*[0-9a-fA-F]+\s*:\s*/)
            {
            ($hex, $bin) = split(/    |\t/, $', 2);
            &warn("invalid hex data") if $hex =~ /[^0-9a-fA-F\s]/;
            $hex =~ /[0-9a-fA-F ]+/; ($hex = $&) =~ s/ //g;
            $data .= pack('H*', $hex);
            }

        if ($dir eq 'record' && ($dbattr & 1))
            { &die("cannot put records in a resource database"); }
        elsif ($dir eq 'resource' && !($dbattr & 1))
            { &die("cannot put resources in a record database"); }
        elsif ($dir eq 'record' || $dir eq 'resource')
            {
            $data[$si] = $data;
            if (!defined($id[$si])) { $id[$si] = $idc++; }
            $offset[$si] = $offset;
            $offset[++$si] = ($offset += length($data));
            }
        elsif ($dir eq 'app-info') { $offset += length($ainfo = $data); }
        elsif ($dir eq 'sort-info') { $offset += length($sinfo = $data); }

        $_ eq '' ? last : redo;
        }
    $name =~ /\S/ || &die("no name given");
    $type =~ /\S/ || &die("no type given");
    $creator =~ /\S/ || &die("no creator given");
    }

else
    {
    $type = $opt{'t'} || (!$opt{'d'} && 'appl') || &die("require -t <type>");
    $creator = $opt{'c'} || &die("require -c <creator>");
    $name = $opt{'n'} || &die("require -n <name>");
    $dbver = &numeval($opt{'v'});
    $dbattr |= 1 unless $opt{'d'};

    foreach $file (@ARGV)
        {
        open(FILE, $file) || &die("$file is unreadable");
        undef $/; $data[$si] = <FILE>; close FILE;
        $len = length($data[$si]);
        if ($opt{'d'})
            {
            $file =~ /^[\@A-Oa-o]/;       $attr[$si] = ord($&)%16;
            &warn("filename $file has no category") if $& eq '';
            $file =~ /^.([0-9a-fA-F])?/;  $attr[$si] |= eval('0x'.$1.'0');
            &warn("filename $file has no attrs") if $1 eq '';
            $file =~ /^..([0-9a-fA-F]*)/; $id[$si] = eval('0x'.$1);
            &warn("filename $file has no id") if $1 eq '';
            }
        else
            {
            $type[$si] = substr($file, 0, 4);
            $file =~ /....([0-9a-fA-F]*)/;
            $id[$si] = eval('0x'.$1);
            &warn("filename $file has no id") if $1 eq '';
            }
        $offset[++$si] = ($offset += $len);
        }
    }

$nsec = scalar(@data);
$dbattr |= 8 if $opt{'b'};
$dbattr |= 2 if $opt{'r'};
$hdrsize = 78 + (($dbattr & 1) ? 10 : 8) * $nsec + 2;
$aioff = $ainfo eq '' ? 0 : $hdrsize;
$sioff = $sinfo eq '' ? 0 : ($aioff ? $aioff + length($ainfo) : $hdrsize);

print pack('a32nnNNNNNNa4a4Nx4n', $name, $dbattr, $dbver, $crtime, $mdtime,
    $bktime, $mdcount, $aioff, $sioff, $type, $creator, $idseed, $nsec);
for ($si = 0; $si < $nsec; $si++)
    { print ($dbattr & 1 ? 
        pack('a4nN', $type[$si], $id[$si], $offset[$si] + $hdrsize) :
        pack('NN', $offset[$si] + $hdrsize, ($attr[$si]<<24) + $id[$si])); }
print "\x00\x00" . $ainfo . $sinfo . join('', @data);