File Coverage

blib/lib/Palm/StdAppInfo.pm

Criterion	Covered	Total	%
statement	53	133	39.8
branch	6	34	17.6
condition	0	12	0.0
subroutine	10	18	55.5
pod	10	10	100.0
total	79	207	38.1

package Palm::StdAppInfo;
#
# ABSTRACT: Handle standard AppInfo blocks in Palm OS PDBs
#
#	Copyright (C) 1999, 2000, Andrew Arensburger.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.

use strict;
use Palm::Raw();

# Don't harass me about these variables
use vars qw( $VERSION @ISA $error );
	# $error acts like $! in that it reports the error that occurred

# One liner, to allow MakeMaker to work.
$VERSION = '1.400';
# This file is part of Palm 1.400 (March 14, 2015)

@ISA = qw( Palm::Raw );

#'

use constant APPINFO_PADDING => 1;	# Whether to add the padding byte at
					# the end of the AppInfo block.
			# Note that this might be considered a hack:
			# this relies on the fact that 'use constant'
			# defines a function with no arguments; that
			# therefore this can be called as an instance
			# method, with full inheritance. That is, if
			# the handler class doesn't define it, Perl
			# will find the constant in the parent. If
			# this ever changes, the code below that uses
			# $self->APPINFO_PADDING will need to be
			# changed.
use constant numCategories => 16;	# Number of categories in AppInfo block
use constant categoryLength => 16;	# Length of category names
use constant stdAppInfoSize =>		# Length of a standard AppInfo block
		2 +
		(categoryLength * numCategories) +
		numCategories +
		1 + 1;			# The padding byte at the end may
					# be omitted

sub import
{
	&Palm::PDB::RegisterPDBHandlers(__PACKAGE__,
		[ "", "" ],
		);
}


# seed_StdAppInfo
# *** THIS IS NOT A METHOD ***
# Given a reference to an appinfo hash, creates all of the fields for
# a new AppInfo block.
sub seed_StdAppInfo
{
	my $appinfo = shift;
	my $i;

	$appinfo->{categories} = [];	# Create array of categories

	# Initialize the categories
	# Note that all of the IDs are initialized to $i. There's no
	# real good reason for doing it this way, except that that's
	# what the Palm appears to do with new category lists.
	for ($i = 0; $i < numCategories; $i++)
	{
		$appinfo->{categories}[$i] = {};

		$appinfo->{categories}[$i]{renamed} = 0;
		$appinfo->{categories}[$i]{name}    = undef;
		$appinfo->{categories}[$i]{id}      = $i;
	}

	# The only fixed category is "Unfiled". Initialize it now
	$appinfo->{categories}[0]{name} = "Unfiled";
	$appinfo->{categories}[0]{id}   = 0;

	# I'm not sure what this is, but let's initialize it.
	# The Palm appears to initialize this to numCategories - 1.
	$appinfo->{lastUniqueID} = numCategories - 1;
}


sub newStdAppInfo
{
	my $class = shift;
	my $retval = {};

	&seed_StdAppInfo($retval);
	return $retval;
}

#'

sub new
{
	my $classname	= shift;
	my $self	= $classname->SUPER::new(@_);
			# Create a generic PDB. No need to rebless it,
			# though.

	# Initialize the AppInfo block
	$self->{appinfo} = &newStdAppInfo();

	return $self;
}

#'

# parse_StdAppInfo
# *** THIS IS NOT A METHOD ***
#
# Reads the raw data from $data, parses it as a standard AppInfo
# block, and fills in the corresponding fields in %$appinfo. Returns
# the number of bytes parsed.
sub parse_StdAppInfo
{
	my $appinfo = shift;	# A reference to hash, to fill in
	my $data = shift;	# Raw data to read
	my $nopadding = shift;	# Optional: no padding byte at end
	my $unpackstr;		# First argument to unpack()
	my $renamed;		# Bitmap of renamed categories
	my @labels;		# Array of category labels
	my @uniqueIDs;		# Array of category IDs
	my $lastUniqueID;	# Not sure what this is

	return undef
		if length $data < 4+(categoryLength*numCategories)+numCategories;

	if (!defined($nopadding))
	{
		$nopadding = 0;
	}

	# Make sure $appinfo contains all of the requisite fields
	&seed_StdAppInfo($appinfo);

	# The argument to unpack() isn't hard to understand, it's just
	# hard to write in a readable fashion.
	$unpackstr =		# Argument to unpack(), since it's hairy
		"n" .		# Renamed categories
		("a" . categoryLength) x numCategories .
				# Category labels
		"C" x numCategories .
				# Category IDs
		"C" .		# Last unique ID
		"x";

	# Unpack the data
	($renamed,
	 @labels[0..(numCategories-1)],
	 @uniqueIDs[0..(numCategories-1)],
	 $lastUniqueID) =
		unpack $unpackstr, $data;

	# Clean this stuff up a bit
	for (@labels)
	{
		s/\0.*$//;	# Trim at NUL
	}

	# Now put the data into $appinfo
	my $i;

	for ($i = 0; $i < numCategories; $i++)
	{
		$appinfo->{categories}[$i]{renamed} =
			($renamed & (1 << $i) ? 1 : 0);
		$appinfo->{categories}[$i]{name} = $labels[$i];
		$appinfo->{categories}[$i]{id}   = $uniqueIDs[$i];
	}
	$appinfo->{lastUniqueID} = $lastUniqueID;

	# There might be other stuff in the AppInfo block other than
	# the standard categories. Put everything else in
	# $appinfo->{other}.
	$appinfo->{other} = substr($data,
				   stdAppInfoSize - ($nopadding ? 1 : 0));

	return ($nopadding ? stdAppInfoSize - 1 : stdAppInfoSize);
}

#'

sub ParseAppInfoBlock
{
	my $self = shift;
	my $data = shift;

	my $appinfo = {};

	&parse_StdAppInfo($appinfo, $data, $self->APPINFO_PADDING);
	return $appinfo;
}

#'

# pack_StdAppInfo
# *** THIS IS NOT A METHOD ***
#
# Given a reference to a hash containing an AppInfo block (such as
# that initialized by parse_StdAppInfo()), returns a packed string
# that can be written to the PDB file.
sub pack_StdAppInfo
{
	my $appinfo = shift;
	my $nopadding = shift;
	my $retval;
	my $i;

	$nopadding = 0 if !defined($nopadding);

	# Create the bitfield of renamed categories
	my $renamed;

	$renamed = 0;
	for ($i = 0; $i < numCategories; $i++)
	{
		if ($appinfo->{categories}[$i]{renamed})
		{
			$renamed |= (1 << $i);
		}
	}
	$retval = pack("n", $renamed);

	# There have to be exactly 16 categories in the AppInfo block,
	# even though $appinfo->{categories} may have been mangled
	# by a naive (or clever) user or broken program.
	for ($i = 0; $i < numCategories; $i++)
	{
		my $name;		# Category name

		# This is mainly to stop Perl 5.6 from complaining if
		# the category name is undefined.
		if ((!defined($appinfo->{categories}[$i]{name})) ||
		    $appinfo->{categories}[$i]{name} eq "")
		{
			$name = "";
		} else {
			$name = $appinfo->{categories}[$i]{name};
		}

		$retval .= pack("a" . categoryLength, $name);
	}

	# Ditto for category IDs
	for ($i = 0; $i < numCategories; $i++)
	{
		$retval .= pack("C", $appinfo->{categories}[$i]{id});
	}

	# Last unique ID, and alignment padding
	$retval .= pack("Cx", $appinfo->{lastUniqueID});

	$retval .= $appinfo->{other} if defined($appinfo->{other});

	return $retval;
}

#'

sub PackAppInfoBlock
{
	my $self = shift;

	return &pack_StdAppInfo($self->{appinfo}, $self->{APPINFO_PADDING});
}

#'
# XXX - When choosing a new category ID, should pick them from the
# range 128-255.
sub addCategory
{
	my $self = shift;	# PDB
	my $name = shift;	# Category name
	my $id = shift;		# Category ID (optional)
	my $renamed = $#_ >= 0 ? $_[0] : 1;
				# Flag: was the category renamed (optional)
				# This initialization may look weird,
				# but it's this way so that it'll
				# default to true if omitted.
	my $categories = $self->{appinfo}{categories};
	my $i;
	my %used;		# Category IDs in use

	# Collect all the IDs in the current list
	for (@{$categories})
	{
		next if !defined($_->{name}) || $_->{name} eq "";
		$used{$_->{id}} = 1;
	}

	if (defined($id))
	{
		# Sanity check: make sure this ID isn't already in use
		if (defined($used{$id}))
		{
			$error = "Category ID already in use";
			return undef;
		}
	} else {
		# Find an unused category number, if none was specified
		for ($id = 128; $id < 256; $id++)
		{
			last if !defined($used{$id});
		}
	}

	# Go through the list of categories, looking for an unused slot
	for ($i = 0; $i < numCategories; $i++)
	{
		# Ignore named categories
		next unless !defined($categories->[$i]{name}) or
			$categories->[$i]{name} eq "";

		# Found an empty slot
		$categories->[$i]{name}    = $name;
		$categories->[$i]{id}      = $id;
		$categories->[$i]{renamed} = $renamed;
		return 1;
	}

	# If we get this far, there are no empty category slots
	$error = "No unused categories";
	return undef;
}

#'
sub deleteCategory
{
	my $self = shift;
	my $name = shift;		# Category name

	for (@{$self->{appinfo}{categories}})
	{
		# Find the category named $name
		next if $_->{name} ne $name;

		# Erase this category
		$_->{name} = "";

		# You'd think it would make sense to set the "renamed"
		# field here, but the Palm doesn't do that.
	}
}

#'
# XXX - This doesn't behave the same way as the Palm: the Palm also
# picks a new category ID.
sub renameCategory
{
	my $self = shift;
	my $oldname = shift;
	my $newname = shift;

	for (@{$self->{appinfo}{categories}})
	{
		# Look for a category named $oldname
		next if !defined($_->{name}) || $_->{name} ne $oldname;

		# Found it. Rename it and mark it as renamed.
		$_->{name} = $newname;
		$_->{renamed} = 1;
		return 1;
	}

	$error = "No such category";
	return undef;
}

1;

__END__