libpalm-perl 1:1.013-1 / usr / bin / pdbdump

#!/usr/bin/perl

eval 'exec /usr/bin/perl  -S $0 ${1+"$@"}'
    if 0; # not running under some shell
#
# Dump a Palm PDB or PRC database.
#
# $Id: pdbdump,v 3.5 2002/04/10 00:58:28 arensb Exp $

use strict;
use Palm::PDB;
use Palm::Raw;

# Load handlers for the built-in apps by default
use Palm::Memo;
use Palm::Address;
use Palm::Datebook;
use Palm::Mail;
use Palm::ToDo;

use vars qw( $VERSION %PDBHandlers %PRCHandlers $hexdump );

$VERSION = sprintf "%d.%03d_%03d_%03d",
	'$Revision: 3.5 $ ' =~ m{(\d+)(?:\.(\d+))};

*PDBHandlers = *Palm::PDB::PDBHandlers;
*PRCHandlers = *Palm::PDB::PRCHandlers;

&Palm::PDB::RegisterPRCHandlers("Palm::Raw",
	[ "", "" ]
	);

$hexdump = 1;			# By default, print hex dumps of everything

# Parse command-line arguments
my $arg;
while (($arg = $ARGV[0]) =~ /^-/)
{
	$arg = shift;

	if (($arg eq "-h") || ($arg eq "-help") || ($arg eq "--help"))
	{
		print <<EOT;
Usage: $0 [options] pdb-file
Options:
	-h, -help, --help	This message.
	-nohex			Don't print hex dumps
	-M<module>		Load <module> (e.g., -MPalm::Address)
EOT
#'
		exit 0;
	} elsif ($arg =~ /^-M/)
	{
		eval "use $';";
	} elsif ($arg eq "-nohex")
	{
		$hexdump = 0;
	} else {
		die "Unrecognized option: $arg\n";
	}
}

my $fname = shift;

die "No such file: $fname\n" if ! -f $fname;

my $EPOCH_1904 = 2082844800;		# Difference between Palm's
					# epoch (Jan. 1, 1904) and
					# Unix's epoch (Jan. 1, 1970),
					# in seconds.
my $HeaderLen = 32+2+2+(9*4);		# Size of database header
my $RecIndexHeaderLen = 6;		# Size of record index header
my $IndexRecLen = 8;			# Length of record index entry
my $IndexRsrcLen = 10;			# Length of resource index entry

#%PDBHandlers = ();			# Record handler map
#%PRCHandlers = ();			# Resource handler map


#&Palm::PDB::rawread($fname);
&rawread($fname);

#package Palm::PDB;		# XXX - Gross hack!
sub rawread
{
	my $self = new Palm::Raw;
	my $fname = shift;		# Filename to read from
	my $buf;			# Buffer into which to read stuff

	# Open database file
	open PDB, "< $fname" or die "Can't open \"$fname\": $!\n";
	binmode PDB;			# Parse as binary file under MS-DOS

	# Get the size of the file. It'll be useful later
	seek PDB, 0, 2;		# 2 == SEEK_END. Seek to the end.
	$self->{_size} = tell PDB;
	print "File size: $self->{_size}\n";
	seek PDB, 0, 0;		# 0 == SEEK_START. Rewind to the beginning.

	# Read header
	my $name;
	my $attributes;
	my $version;
	my $ctime;
	my $mtime;
	my $baktime;
	my $modnum;
	my $appinfo_offset;
	my $sort_offset;
	my $type;
	my $creator;
	my $uniqueIDseed;

	read PDB, $buf, $HeaderLen;	# Read the PDB header
	print "Database header:\n";
	if ($hexdump)
	{
		&hexdump("   ", $buf);
		print "\n";
	}

	# Split header into its component fields
	($name, $attributes, $version, $ctime, $mtime, $baktime,
	$modnum, $appinfo_offset, $sort_offset, $type, $creator,
	$uniqueIDseed) =
		unpack "a32 n n N N N N N N a4 a4 N", $buf;

	($self->{name} = $name) =~ s/\0*$//;
	$self->{attributes}{resource} = 1 if $attributes & 0x0001;
	$self->{attributes}{"read-only"} = 1 if $attributes & 0x0002;
	$self->{attributes}{"AppInfo dirty"} = 1 if $attributes & 0x0004;
	$self->{attributes}{backup} = 1 if $attributes & 0x0008;
	$self->{attributes}{"OK newer"} = 1 if $attributes & 0x0010;
	$self->{attributes}{reset} = 1 if $attributes & 0x0020;
	$self->{attributes}{open} = 1 if $attributes & 0x0040;
	$self->{attributes}{launchable} = 1 if $attributes & 0x0200;
	$self->{version} = $version;
	$self->{ctime} = $ctime - $EPOCH_1904;
	$self->{mtime} = $mtime - $EPOCH_1904;
	$self->{baktime} = $baktime - $EPOCH_1904;
	$self->{modnum} = $modnum;
	# _appinfo_offset and _sort_offset are private fields
	$self->{_appinfo_offset} = $appinfo_offset;
	$self->{_sort_offset} = $sort_offset;
	$self->{type} = $type;
	$self->{creator} = $creator;
	$self->{uniqueIDseed} = $uniqueIDseed;

	print <<EOT;
    Name:           $name
    Attributes:     @{[sprintf("0x%02x", $attributes)]}
EOT
	print " "x19;
	print " LAUNCHABLE"	if $self->{attributes}{launchable};
	print " OPEN"		if $self->{attributes}{open};
	print " RESET"		if $self->{attributes}{reset};
	print " OKNEWER"	if $self->{attributes}{"OK newer"};
	print " BACKUP"		if $self->{attributes}{backup};
	print " APPINFO-DIRTY"	if $self->{attributes}{"AppInfo dirty"};
	print " READ-ONLY"	if $self->{attributes}{"read-only"};
	print " RESOURCE"	if $self->{attributes}{resource};
	print "\n";
	print <<EOT;
    Version:        $version
    Ctime:          $ctime	@{[scalar(localtime($ctime-$EPOCH_1904))]}
    Mtime:          $mtime	@{[scalar(localtime($mtime-$EPOCH_1904))]}
    Backup time:    $baktime	@{[scalar(localtime($baktime-$EPOCH_1904))]}
    Mod number:     $modnum
    AppInfo offset: $appinfo_offset
    Sort offset:    $sort_offset
    Type:           $type
    Creator:        $creator
    Unique ID seed: $uniqueIDseed

EOT

	# Rebless this PDB object, depending on its type and/or
	# creator. This allows us to magically invoke the proper
	# &Parse*() function on the various parts of the database.

	# Look for most specific handlers first, least specific ones
	# last. That is, first look for a handler that deals
	# specifically with this database's creator and type, then for
	# one that deals with this database's creator and any type,
	# and finally for one that deals with anything.

	my $handler;
	if ($self->{attributes}{resource})
	{
		# Look among resource handlers
		$handler = $PRCHandlers{$self->{creator}}{$self->{type}} ||
			$PRCHandlers{undef}{$self->{type}} ||
			$PRCHandlers{$self->{creator}}{""} ||
			$PRCHandlers{""}{""};
	} else {
		# Look among record handlers
		$handler = $PDBHandlers{$self->{creator}}{$self->{type}} ||
			$PDBHandlers{""}{$self->{type}} ||
			$PDBHandlers{$self->{creator}}{""} ||
			$PDBHandlers{""}{""};
	}

	if (defined($handler))
	{
		bless $self, $handler;
	} else {
		# XXX - This should probably return 'undef' or something,
		# rather than die.
		die "No handler defined for creator \"$creator\", type \"$type\"\n";
	}

	## Read record/resource index
	# Read index header
	read PDB, $buf, $RecIndexHeaderLen;
	print "Record/resource index header:\n";
	if ($hexdump)
	{
		&hexdump("   ", $buf);
		print "\n";
	}

	my $next_index;
	my $numrecs;

	($next_index, $numrecs) = unpack "N n", $buf;
	$self->{_numrecs} = $numrecs;

	print <<EOT;
    Next index:     $next_index
    # records:      $numrecs

EOT

	# Read the index itself
	if ($self->{attributes}{resource})
	{
		&_load_rsrc_index($self, \*PDB);
	} else {
		&_load_rec_index($self, \*PDB);
	}

	# Ignore the two NUL bytes that are usually here. We'll seek()
	# around them later.

	# Read AppInfo block, if it exists
	if ($self->{_appinfo_offset} != 0)
	{
		&_load_appinfo_block($self, \*PDB);
	}

	# Read sort block, if it exists
	if ($self->{_sort_offset} != 0)
	{
		&_load_sort_block($self, \*PDB);
	}

	# Read record/resource list
	if ($self->{attributes}{resource})
	{
		&_load_resources($self, \*PDB);
	} else {
		&_load_records($self, \*PDB);
	}

	# These keys were needed for parsing the file, but are not
	# needed any longer. Delete them.
	delete $self->{_index};
	delete $self->{_numrecs};
	delete $self->{_appinfo_offset};
	delete $self->{_sort_offset};
	delete $self->{_size};

	close PDB;
}


# _load_rec_index
# Private function. Read the record index, for a record database
sub _load_rec_index
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $i;
my $lastoffset = 0;

	print "Record index:\n";

	# Read each record index entry in turn
	for ($i = 0; $i < $pdb->{_numrecs}; $i++)
	{
		my $buf;		# Input buffer

		print "  Record index entry $i\n";

		# Read the next record index entry
		my $offset;
		my $attributes;
		my @id;			# Raw ID
		my $id;			# Numerical ID
		my $entry = {};		# Parsed index entry

		read $fh, $buf, $IndexRecLen;
		if ($hexdump)
		{
			&hexdump("   ", $buf);
			print "\n";
		}

		# The ID field is a bit weird: it's represented as 3
		# bytes, but it's really a double word (long) value.

		($offset, $attributes, @id) = unpack "N C C3", $buf;
if ($offset == $lastoffset)
{
print STDERR "Record $i has same offset as previous one: $offset\n";
}
$lastoffset = $offset;

		$entry->{offset} = $offset;
		$entry->{attributes}{expunged} = 1 if $attributes & 0x80;
		$entry->{attributes}{dirty} = 1 if $attributes & 0x40;
		$entry->{attributes}{deleted} = 1 if $attributes & 0x20;
		$entry->{attributes}{private} = 1 if $attributes & 0x10;
		$entry->{id} = ($id[0] << 16) |
				($id[1] << 8) |
				$id[2];

		# The lower 4 bits of the attributes field are
		# overloaded: If the record has been deleted and/or
		# expunged, then bit 0x08 indicates whether the record
		# should be archived. Otherwise (if it's an ordinary,
		# non-deleted record), the lower 4 bits specify the
		# category that the record belongs in.
		if (($attributes & 0xa0) == 0)
		{
			$entry->{category} = $attributes & 0x0f;
		} else {
			$entry->{attributes}{archive} = 1
				if $attributes & 0x08;
		}

		print <<EOT;
    Offset:         $offset
    Attributes:     @{[sprintf("0x%02x", $attributes), keys %{$entry->{attributes}}]}
    Category:       $entry->{category}
    ID:             @{[sprintf("0x%02x%02x%02x", @id)]}

EOT

		# Put this information on a temporary array
		push @{$pdb->{_index}}, $entry;
	}
}

# XXX - Make this print out debugging information
# _load_rsrc_index
# Private function. Read the resource index, for a resource database
sub _load_rsrc_index
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $i;

	print "Resource index:\n";

	# Read each resource index entry in turn
	for ($i = 0; $i < $pdb->{_numrecs}; $i++)
	{
		my $buf;		# Input buffer

		print "  Resource index entry $i\n";

		# Read the next resource index entry
		my $type;
		my $id;
		my $offset;
		my $entry = {};		# Parsed index entry

		read $fh, $buf, $IndexRsrcLen;
		if ($hexdump)
		{
			&hexdump("   ", $buf);
			print "\n";
		}

		($type, $id, $offset) = unpack "a4 n N", $buf;

		$entry->{type} = $type;
		$entry->{id} = $id;
		$entry->{offset} = $offset;

		print <<EOT;
    Offset:         $offset
    ID:             $id
    Type:           $type

EOT

		push @{$pdb->{_index}}, $entry;
	}
}

# _load_appinfo_block
# Private function. Read the AppInfo block
sub _load_appinfo_block
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $len;		# Length of AppInfo block
	my $buf;		# Input buffer

	print "AppInfo block:\n";

	# Sanity check: make sure we're positioned at the beginning of
	# the AppInfo block
	if (tell($fh) > $pdb->{_appinfo_offset})
	{
		die "Bad AppInfo offset: expected ",
			sprintf("0x%08x", $pdb->{_appinfo_offset}),
			", but I'm at ",
			tell($fh), "\n";
	}

	# Seek to the right place, if necessary
	if (tell($fh) != $pdb->{_appinfo_offset})
	{
		seek PDB, $pdb->{_appinfo_offset}, 0;
	}

	# There's nothing that explicitly gives the size of the
	# AppInfo block. Rather, it has to be inferred from the offset
	# of the AppInfo block (previously recorded in
	# $pdb->{_appinfo_offset}) and whatever's next in the file.
	# That's either the sort block, the first data record, or the
	# end of the file.

	if ($pdb->{_sort_offset})
	{
		# The next thing in the file is the sort block
		$len = $pdb->{_sort_offset} - $pdb->{_appinfo_offset};
	} elsif ((defined $pdb->{_index}) && @{$pdb->{_index}})
	{
		# There's no sort block; the next thing in the file is
		# the first data record
		$len = $pdb->{_index}[0]{offset} -
			$pdb->{_appinfo_offset};
	} else {
		# There's no sort block and there are no records. The
		# AppInfo block goes to the end of the file.
		$len = $pdb->{_size} - $pdb->{_appinfo_offset};
	}

	# Read the AppInfo block
	read $fh, $buf, $len;
	if ($hexdump)
	{
		&hexdump("   ", $buf);
		print "\n";
	}

	# Tell the real class to parse the AppInfo block
	$pdb->{appinfo} = $pdb->ParseAppInfoBlock($buf);

	# Print out the parsed values
	if (ref($pdb->{appinfo}) ne "")
	{
		&dumphash($pdb->{appinfo}, "\t");
		print "\n";
	}
}

# _load_sort_block
# Private function. Read the sort block.
sub _load_sort_block
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $len;		# Length of sort block
	my $buf;		# Input buffer

	print "Sort block:\n";

	# Sanity check: make sure we're positioned at the beginning of
	# the sort block
	if (tell($fh) > $pdb->{_sort_offset})
	{
		die "Bad sort block offset: expected ",
			sprintf("0x%08x", $pdb->{_sort_offset}),
			", but I'm at ",
			tell($fh), "\n";
	}

	# Seek to the right place, if necessary
	if (tell($fh) != $pdb->{_sort_offset})
	{
		seek PDB, $pdb->{_sort_offset}, 0;
	}

	# There's nothing that explicitly gives the size of the sort
	# block. Rather, it has to be inferred from the offset of the
	# sort block (previously recorded in $pdb->{_sort_offset})
	# and whatever's next in the file. That's either the first
	# data record, or the end of the file.

	if (defined($pdb->{_index}))
	{
		# The next thing in the file is the first data record
		$len = $pdb->{_index}[0]{offset} -
			$pdb->{_sort_offset};
	} else {
		# There are no records. The sort block goes to the end
		# of the file.
		$len = $pdb->{_size} - $pdb->{_sort_offset};
	}

	# Read the AppInfo block
	read $fh, $buf, $len;
	if ($hexdump)
	{
		&hexdump("   ", $buf);
		print "\n";
	}

	# XXX - Check to see if the sort block has some predefined
	# structure. If so, it might be a good idea to parse the sort
	# block here.

	# Tell the real class to parse the sort block
	$pdb->{sort} = $pdb->ParseSortBlock($buf);
}

# _load_records
# Private function. Load the actual data records, for a record database
# (PDB)
sub _load_records
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $i;

	print "Records:\n";
	# Read each record in turn
	for ($i = 0; $i < $pdb->{_numrecs}; $i++)
	{
		my $len;	# Length of record
		my $buf;	# Input buffer

		print "  Record $i\n";

		# Sanity check: make sure we're where we think we
		# should be.
		if (tell($fh) > $pdb->{_index}[$i]{offset})
		{
# XXX - The two NULs are really optional.
#			die "Bad offset for record $i: expected ",
#				sprintf("0x%08x",
#					$pdb->{_index}[$i]{offset}),
#				" but it's at ",
#				sprintf("[0x%08x]", tell($fh)), "\n";
		}

		# Seek to the right place, if necessary
		if (tell($fh) != $pdb->{_index}[$i]{offset})
		{
			seek PDB, $pdb->{_index}[$i]{offset}, 0;
		}

		# Compute the length of the record: the last record
		# extends to the end of the file. The others extend to
		# the beginning of the next record.
		if ($i == $pdb->{_numrecs} - 1)
		{
			# This is the last record
			$len = $pdb->{_size} -
				$pdb->{_index}[$i]{offset};
		} else {
			# This is not the last record
			$len = $pdb->{_index}[$i+1]{offset} -
				$pdb->{_index}[$i]{offset};
		}

		# Read the record
		read $fh, $buf, $len;
		if ($hexdump)
		{
			&hexdump("   ", $buf);
			print "\n";
		}

		# Tell the real class to parse the record data. Pass
		# &ParseRecord all of the information from the index,
		# plus a "data" field with the raw record data.
		my $record;

		$record = $pdb->ParseRecord(
			%{$pdb->{_index}[$i]},
			"data"	=> $buf,
			);
		push @{$pdb->{records}}, $record;

		# Print out the parsed values
		&dumphash($record, "\t");
		print "\n";
	}
}

# _load_resources
# Private function. Load the actual data resources, for a resource database
# (PRC)
sub _load_resources
{
	my $pdb = shift;
	my $fh = shift;		# Input file handle
	my $i;

	print "Resources:\n";
	# Read each resource in turn
	for ($i = 0; $i < $pdb->{_numrecs}; $i++)
	{
		my $len;	# Length of record
		my $buf;	# Input buffer

		print "  Resource $i\n";

		# Sanity check: make sure we're where we think we
		# should be.
		if (tell($fh) > $pdb->{_index}[$i]{offset})
		{
			die "Bad offset for resource $i: expected ",
				sprintf("0x%08x",
					$pdb->{_index}[$i]{offset}),
				" but it's at ",
				sprintf("0x%08x", tell($fh)), "\n";
		}

		# Seek to the right place, if necessary
		if (tell($fh) != $pdb->{_index}[$i]{offset})
		{
			seek PDB, $pdb->{_index}[$i]{offset}, 0;
		}

		# Compute the length of the resource: the last
		# resource extends to the end of the file. The others
		# extend to the beginning of the next resource.
		if ($i == $pdb->{_numrecs} - 1)
		{
			# This is the last resource
			$len = $pdb->{_size} -
				$pdb->{_index}[$i]{offset};
		} else {
			# This is not the last resource
			$len = $pdb->{_index}[$i+1]{offset} -
				$pdb->{_index}[$i]{offset};
		}

		# Read the resource
		read $fh, $buf, $len;
		if ($hexdump)
		{
			&hexdump("   ", $buf);
			print "\n";
		}

		# Tell the real class to parse the resource data. Pass
		# &ParseResource all of the information from the
		# index, plus a "data" field with the raw resource
		# data.
		my $resource;

		$resource = $pdb->ParseResource(
			%{$pdb->{_index}[$i]},
			"data"	=> $buf,
			);
		push @{$pdb->{resources}}, $resource;

		# Print out the parsed values
		&dumphash($resource, "\t");
		print "\n";
	}
}

sub hexdump
{
	my $prefix = shift;	# What to print in front of each line
	my $data = shift;	# The data to dump
	my $maxlines = shift;	# Max # of lines to dump
	my $offset;		# Offset of current chunk

	for ($offset = 0; $offset < length($data); $offset += 16)
	{
		my $hex;		# Hex values of the data
		my $ascii;		# ASCII values of the data
		my $chunk;		# Current chunk of data

		last if defined($maxlines) && ($offset >= ($maxlines * 16));

		$chunk = substr($data, $offset, 16);

		($hex = $chunk) =~ s/./sprintf "%02x ", ord($&)/ges;

		($ascii = $chunk) =~ y/\040-\176/./c;

		printf "%s %-48s|%-16s|\n", $prefix, $hex, $ascii;
	}
}

# XXX - Ought to have a &dumparray as well. The two can call each other
# recursively.

sub dumphash
{
	my $hash = shift;
	my $indent = shift;
	my $key;
	my $value;

	while (($key, $value) = each %{$hash})
	{
		if (ref($value) eq "HASH")
		{
			print $indent, $key, ":\n";
			&dumphash($value, $indent . "\t");
		} elsif (ref($value) eq "ARRAY")
		{
			my($i,$j);

			print $indent, $key, ":\n";
			for ($i = 0; $i <= $#{$value}; $i++)
			{
				if (ref($value->[$i]) eq "HASH")
				{
					print $indent, "    $i:\n";
					&dumphash($value->[$i],
						$indent . "\t");
				} elsif (ref($value->[$i]) eq "ARRAY")
				{
					my @v2 = @{$value->[$i]};
					for ($j = 0; $j <= $#v2; $j++)
					{
						print $indent,
							"\t$i-$j: [$v2[$j]]\n";
					}
				}else {
					print $indent,
						"\t$i: [$value->[$i]]\n";
				}
			}
		} else {
			print $indent, $key, " -> [", $value, "]\n";
		}
	}
}

__END__

=head1 NAME

pdbdump - Print the contents of a Palm PDB file

=head1 SYNOPSIS

C<pdbdump> I<[options]> F<filename>

=head1 DESCRIPTION

C<pdbdump> reads a PalmOS F<.pdb> file, parses it, and prints its
contents. This includes both a hex dump of the raw data of each piece,
and a human-readable list of the various values, insofar as possible.
The aim of C<pdbdump> is to allow one to verify whether a particular
file is a well-formed PalmOS database file and if not, where the error
lies.

If the database is of a known type, C<pdbdump> parses the AppInfo
block and records. Otherwise, it simply prints out a hex dump of their
contents. C<pdbdump> includes, by default, support for most of the
built-in applications. Other helper modules may be loaded with the
C<-M> option.

=head1 OPTIONS

=over 4

=item -h -help --help

Print a usage message and exit.

=item -nohex

Don't print the hex dump of the various parts.

=item -MI<module>

C<use> the named module. This can be useful for loading additional
helper modules.

=back

=head1 BUGS

C<pdbdump> only recognizes record databases (C<.pdb> files), not
resource databases (C<.prc> files).

=head1 SEE ALSO

Palm::PDB(3)

=head1 AUTHOR

Andrew Arensburger <arensb@ooblick.com>