#!/usr/bin/perl

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

# PRC/PDB extraction tool v1.1, 25 December 1997 by Ka-Ping Yee <ping@lfw.org>
# now check for type "rec" to extract records from record databases
# a little more help info about the database summary listing

# PRC/PDB extraction tool v1.0, 25 February 1997 by Ka-Ping Yee <ping@lfw.org>

$onehelp = <<ONEHELP;
PRC/PDB extraction tool v1.1, 26 December 1997 by Ka-Ping Yee <ping\@lfw.org>
This is the first page of help.  Type "prcx -H" for page two.

usage: prcx <file>
           Displays information about the database stored in <file> and lists
           the sizes and attributes of the records or resources within.  For
           resources, shows the type and id number.  For records, shows the
           attribute bits (d: delete, a: archive, b: busy, p: private), the
           category (A to O) in square brackets, and the unique id number.

       prcx <file> <type>
           From <file>, extracts the first resource of type <type> to stdout.

       prcx <file> <type> <id>
           From <file>, extracts the record or resource with type <type> and
           id <id> to stdout.  For record databases, specify type "rec" and
           the unique id of the desired record in decimal or hex.

To read from stdin, specify a single hyphen ("-") as the filename.
ONEHELP

$twohelp = <<TWOHELP;
PRC/PDB extraction tool v1.1, 26 December 1997 by Ka-Ping Yee <ping\@lfw.org>
This is the second page of help.  Type "prcx -h" for page one.

usage: prcx -a <file>
           Extracts all records or resources from <file>.

           If <file> is a record database, each record will be written to a
           separate file where the first eight characters of the filename give
           the category (as a letter from A to O or \@ for unfiled), attributes
           (as one hex digit), and unique id (as six hex digits) 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.

           If <file> is a resource database, each resource will be written to
           a separate file where the first eight characters of the filename
           give the type and id (in hex) of the corresponding resource.

       prcx -x <file>
           Extracts all the information from <file> into a text format and
           writes the textual information to stdout.
TWOHELP

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 warn { print STDERR "$_[0]\n"; }
sub die { print STDERR "prcx: $_[0]\n"; exit 1; }
sub sysread { local(*FILE) = $_[0];
    sysread(FILE, $_[1], $_[2]) == $_[2] || &die('unexpected end of file'); }
sub write { &warn('writing '.$_[0]);
    open(FILE, '>'.$_[0]); print FILE $_[1]; close FILE; }

sub ptimestr { return 'never' if $_[0] == 0 || $_[0] - 2082844800 >= 2**31;
    local($s, $m, $h, $d, $l, $y) = gmtime($_[0] - 2082844800);
    sprintf("%04d-%02d-%02d %02d:%02d:%02d", $y+1900, $l+1, $d, $h, $m, $s); }
sub dtimestr { &ptimestr($_[0]) =~ /.*\d.*/ ? $& : sprintf('0x%08x',$_[0]); }

sub hexdump
    { for ($off=0; $off<length($_[0]); $off+=16)
        { $hex = unpack('H*', $chunk = substr($_[0], $off, 16));
        $hex =~ s/../$& /g; $chunk =~ s/[^\x20-\x7e]/./g;
        printf("%04x: %-48s     %s\n", $off, $hex, $chunk); } }

&getopt();
if ($opt{'H'}) { print STDERR $twohelp; exit; }
if ($opt{'h'} || !@ARGV) { print STDERR $onehelp; exit; }

($file, $qtype, $qid) = @ARGV;
$qid = ($qid =~ /0x[0-9a-fA-F]+|0[0-7]+|[0-9]+/ ? eval($&) : '');
open(PRC, $file) || &die("$file is unreadable");
&sysread(PRC, $header, 78);
($name, $dbattr, $dbver, $crtime, $mdtime, $bktime, $mdcount, $aioff, $sioff,
    $type, $creator, $idseed, $nsec) = unpack('a32nnNNNNNNa4a4Nx4n', $header);
$name = $` if $name =~ /\x00/;
$entsize = ($dbattr & 1) ? 10 : 8;
$hdrsize = length($header) + $entsize * $nsec + 2;
$section = ($dbattr & 1) ? 'resource' : 'record';

foreach $si (0..$nsec-1)
    {
    &sysread(PRC, $entry, $entsize);
    if ($dbattr & 1)
        { ($type[$si], $id[$si], $offset[$si]) = unpack('a4nN', $entry);
        $filename[$si] = sprintf("%-4s%04x.res", $type[$si], $id[$si]); }
    else
        { ($offset[$si], $attr[$si], $idhi, $id[$si]) = unpack('NCCn', $entry);
        $filename[$si] = sprintf("%c%1x%06x.rec", $cat[$si]=($attr[$si]&15)+64,
            $attr[$si]>>4, $id[$si] |= ($idhi << 16)); }
    if (($qtype && $qtype eq $type[$si] || $qtype eq 'rec') &&
        ($qid eq '' || $qid eq $id[$si])) { $found = $si if !defined($found); }
    }
&sysread(PRC, $junk, 2);
if ($aioff)
    { if ($sioff) { &sysread(PRC, $ainfo, $sioff - $aioff); }
    elsif ($nsec) { &sysread(PRC, $ainfo, $offset[0] - $aioff); }
    else { 1 while sysread(PRC, $ainfo, 256, length($ainfo)) > 0; } }
if ($sioff)
    { if ($nsec) { &sysread(PRC, $sinfo, $offset[0] - $sioff); }
    else { 1 while sysread(PRC, $sinfo, 256, length($sinfo)) > 0; } }
foreach $si (0..$nsec-2)
    {
    &sysread(PRC, $data[$si], $offset[$si+1] - $offset[$si]);
    &write($filename[$si], $data[$si]) if $opt{'a'};
    }
1 while $nsec && sysread(PRC, $data[$nsec-1], 256, length($data[$nsec-1])) > 0;
&write($filename[$nsec-1], $data[$nsec-1]) if $opt{'a'};
close PRC;

if (defined($found)) { print $data[$found]; exit; }
if ($opt{'x'})
    {
    print "# prcx dump of $file\n";
    print "# (generated with prcx v1.1 by Ka-Ping Yee)\n";
    print "name $name\n"."$section-db\n"."type $type\n"."creator $creator\n";
    print "open" if $dbattr & 0x8000;
    print "read-only\n" if $dbattr & 2;
    print "appinfo-dirty\n" if $dbattr & 4;
    print "backup\n" if $dbattr & 8;
    print "version $dbver\n"."modify-count $mdcount\n"."id-seed $idseed\n";
    print "create-time " . &dtimestr($crtime) . "\n";
    print "modify-time " . &dtimestr($mdtime) . "\n";
    print "backup-time " . &dtimestr($bktime) . "\n";
    if ($ainfo) { print "\napp-info\n"; &hexdump($ainfo); }
    if ($sinfo) { print "\nsort-info\n"; &hexdump($sinfo); }
    print "\n# $nsec $section" . ($nsec==1 ? '' : 's');
    foreach $si (0..$nsec-1)
        {
        if ($dbattr & 1) { print "\nresource type=$type[$si] id=$id[$si]\n"; }
        else { printf "\nrecord cat=%c id=0x%06x", $cat[$si], $id[$si];
            print " private" if $attr[$si] & 0x10;
            print " busy" if $attr[$si] & 0x20;
            print " archive" if $attr[$si] & 0x40;
            print " delete" if $attr[$si] & 0x80; print "\n"; }
        &hexdump($data[$si]);
        }
    print "\n# prcx dump complete\n";
    }
elsif (!$opt{'a'})
    {
    print STDERR "name: $name (";
    print STDERR "open " if $dbattr & 0x8000;
    print STDERR "read-only " if $dbattr & 2;
    print STDERR "$section database";
    print STDERR " marked for backup" if $dbattr & 8;
    print STDERR ")\ntype: $type, creator: $creator, version: $dbver, ";
    print STDERR "changes: $mdcount, id seed: $idseed\n" .
        "created: ".&ptimestr($crtime) . ", modified: ".&ptimestr($mdtime) .
        "\nbacked up: ".&ptimestr($bktime)."\n";
    print STDERR "$nsec $section" . ($nsec == 1 ? '' : 's') . "\n";

    foreach $si (0..$nsec-1)
        { 
        if ($dbattr & 1) { printf STDERR "  %4s%6s%7s bytes at offset %d)\n",
            $type[$si], '#'.$id[$si], '('.length($data[$si]), $offset[$si]; }
        else { printf STDERR "  %4s[%c] 0x%06x %7s bytes at offset %d)\n",
            ($attr[$si]&0x80 ? 'd':'-').($attr[$si]&0x40 ? 'a':'-') .
            ($attr[$si]&0x20 ? 'b':'-').($attr[$si]&0x10 ? 'p':'-'), $cat[$si],
            $id[$si], '('.length($data[$si]), $offset[$si]; }
        }
    $size = $hdrsize + length(join('', @data));
    printf STDERR "total: %5d %s%6s bytes plus %d-byte header)\n", $size,
        ($dbattr & 1) ? '' : 'bytes  ', "(".($size - $hdrsize), $hdrsize;
    }