#!/usr/bin/perl
use Palm::Address;

$KABFILE = "$ENV{HOME}/.kde/share/apps/kab/addressbook.database";
$SIG{"__DIE__"} = \&Die;
$SIG{"__WARN__"} = \&Warn;

# Parse command-line arguments
if ($ARGV[0] ne "conduit")
{
	die "402 Missing or bad conduit argument\n";
}

# Make sure there's a flavor argument
if (!defined($ARGV[1]))
{
	die "403 Missing flavor argument\n";
}

# Make sure the flavor is supported
if (lc($ARGV[1]) ne "dump")
{
	die "404 Unsupported flavor\n";
}

# Read the conduit fields from stdin
%HEADERS = ();

while (<STDIN>)
{
	my $header;		# Header field
	my $value;		# Header field's value

	chomp;
	last if /^$/;		# Blank line is end of headers

	if (!/^(\w+):\s(.*)/)
	{
		die "405 Invalid input\n";
	}
	$header = $1;
	$value = $2;

	$HEADERS{$header} = $value;
}

if (!defined($HEADERS{"InputDB"}))
{
	die "406 Missing header field: InputDB\n";
}

# Read the PDB file specified by the "InputDB" header.
$pdb = new Palm::PDB;
$pdb->Load($HEADERS{"InputDB"});

# Read the 'kab' address book.
$kab = &load_kab($KABFILE);

# Dump the kab file header
open KAB, "> $KABFILE" or die "Can't write $KABFILE: $!\n";
print KAB <<EndOfHeader;
# [File created by $0]
# subsections
[Config]
  # key-value-pairs
  Background="$kab->{header}{Background}"
  CreateBackup="$kab->{header}{CreateBackup}"
  FileFormat="$kab->{header}{FileFormat}"
  MailCommand="$kab->{header}{MailCommand}"
  MailParameters="$kab->{header}{MailParameters}"
  MailSelectAddress="$kab->{header}{MailSelectAddress}"
  QueryOnChange="$kab->{header}{QueryOnChange}"
  QueryOnDelete="$kab->{header}{QueryOnDelete}"
  QueryOnSave="$kab->{header}{QueryOnSave}"
  SaveOnExit="$kab->{header}{SaveOnExit}"
  TalkCommand="$kab->{header}{TalkCommand}"
  TalkParameters="$kab->{header}{TalkParameters}"
  Version="$kab->{header}{Version}"
[END Config]
[Entries]
  # subsections
EndOfHeader

# Handle each record in turn
my $entry_num = 1;
foreach $record (@{$pdb->{"records"}})
{
	my $fields = $record->{"fields"};
	my $kab_entry = &find_kab_entry($kab,
					$record);

	# Copy the PDB's values to the kab entry
	$kab_entry->{"X-PilotID"}	= $record->{"id"};
	$kab_entry->{"name"}		= $fields->{"name"};
	$kab_entry->{"firstname"}	= $fields->{"firstName"};
	$kab_entry->{"org"}		= $fields->{"company"};
	$kab_entry->{"address"}		= $fields->{"address"};
	$kab_entry->{"town"}		= $fields->{"city"};
	$kab_entry->{"state"}		= $fields->{"state"};
	$kab_entry->{"zip"}		= $fields->{"zipCode"};
	$kab_entry->{"country"}		= $fields->{"country"};
	$kab_entry->{"role"}		= $fields->{"title"};
	$kab_entry->{"comment"}		= $fields->{"note"};

	# Deal with the "Custom *" fields.
	my $custom;
	foreach $custom ( qw( custom1 custom2 custom3 custom4 ) )
	{
		my $kab_label;

		# Store this information under the user-given name.
		# That is, if the user has renamed "Custom 1" to
		# "URL", then store the "custom1" field under "URL" in
		# the kab file.
		$kab_label = $pdb->{"appinfo"}{"fieldLabels"}{$custom};
		$kab_label =~ s/\W+/-/g;	# Escape bogus characters

		$kab_entry->{$kab_label} = $fields->{$custom};
	}

	# Deal with the phone fields. This section is a bit
	# complicated, since PalmOS doesn't define specific fields for
	# "Home phone", "Work phone", "Fax" or even "E-mail". Rather,
	# it defines five "phoneN" fields, each of which can be a
	# phone or fax number or an e-mail address. See
	# Palm::Address(1) for the gruesome details.

	my @fax = ();
	my @email = ();
	my @phone = ();

	foreach $phone ( qw( phone1 phone2 phone3 phone4 phone5 ) )
	{
		my $label = $Palm::Address::phoneLabels[
				$record->{"phoneLabel"}{$phone}];

		if (($label eq "Fax") && ($fields->{$phone} ne ""))
		{
			push @fax, split(/\n/, $fields->{$phone});
		} elsif (($label eq "E-mail") && ($fields->{$phone} ne ""))
		{
			push @email, split(/\n/, $fields->{$phone});
		} elsif (($label eq "Main") && ($fields->{$phone} ne ""))
		{
			unshift @phone, split(/\n/, $fields->{$phone});
		} elsif ($fields->{$phone} ne "") {
			push @phone, split(/\n/, $fields->{$phone});
		}
	}
	$kab_entry->{"fax"}       = join("\n", @fax);
	$kab_entry->{"emails"}    = join("\\e", @email);
	$kab_entry->{"emails"}   .= "\\e" if $#email >= 0;
	$kab_entry->{"telephone"} = join("\n", @phone);

	# Write this entry
	my $key;
	my $value;

	print KAB "  [$entry_num]\n    # key-value-pairs\n";

	# The list is printed in alphabetical order because that's
	# what kab does, so that makes it easier to compare
	# differences. Other than that, there's no fundamental reason
	# not to use "while (($key, $value) = each %{$kab_entry})".
	foreach $key (sort keys %{$kab_entry})
	{
		$value = $kab_entry->{$key};

		$key =~ s/\W+/-/g;	# Remove bogus characters
		$value =~ s/\n/\\n/g;	# Escape returns
		$value =~ s/\"/\\\"/g;	# And double quotes
		print KAB "    $key=\"$value\"\n";
	}
	print KAB "  [END $entry_num]\n";

	$entry_num++;
}

# Dump the kab file footer
print KAB "[END Entries]\n";
close KAB;

# load_kab
# Read a 'kab'-style address book. Return a hash with the results.
sub load_kab
{
	my $fname = shift;		# Input file name
	my $retval = {
		header	=> {},		# Hash for the header
		entries	=> [],		# List of addresses
		};

	open KAB, $fname or do {
		# Can't open the address book. Create an empty file
		# with just a header
		$retval->{"header"}{"Background"} = "background_1.jpg";
		$retval->{"header"}{"CreateBackup"} = "true";
		$retval->{"header"}{"FileFormat"} = "2";
		$retval->{"header"}{"MailCommand"} = "kmail";
		$retval->{"header"}{"MailParameters"} =
			"<person>\\e-s\\e<subject>\\e";
		$retval->{"header"}{"MailSelectAddress"} = "true";
		$retval->{"header"}{"QueryOnChange"} = "true";
		$retval->{"header"}{"QueryOnDelete"} = "true";
		$retval->{"header"}{"QueryOnSave"} = "true";
		$retval->{"header"}{"SaveOnExit"} = "true";
		$retval->{"header"}{"TalkCommand"} = "ktalk";
		$retval->{"header"}{"TalkParameters"} =
			"--autoexit\\e<person>\\e";
		$retval->{"header"}{"Version"} = "1.000000";

		return $retval;
	};

	# Read the KAB file
	my $target;		# Reference to the hash to add to:
				# either the header or an entry.

    mainloop:

	# XXX - This parser isn't terribly sophisticated. On the other
	# hand, it probably doesn't need to be.

	while (<KAB>)
	{
		chomp;
		next if /^\s*\#/;	# Ignore comments
		next if /^\s*$/;	# And blank lines

		if ($_ eq "[Config]")
		{
			# Start of header block
			$target = $retval->{"header"};
			next mainloop;
		} elsif ($_ eq "[Entries]")
		{
			# Nothing to do here, really. This is just
			# here for completeness.
			$target = undef;
			next mainloop;
		} elsif ($_ =~ /^\s*\[(\d+)\]/)
		{
			# Start of address block
			my $entry = {};

			push @{$retval->{"entries"}}, $entry;
			$target = $entry;
			next mainloop;
		} elsif (/^\s*\[END\s\w+\]/)
		{
			$target = undef;
			next mainloop;
		}

		# Read the next header entry
		if (/^\s*(\w+)=\"(.*)\"$/)
		{
			# Add this entry to the header
			$target->{$1} = $2;
		}
		# XXX - Complain about malformed entry
	}

	close KAB;

	return $retval;
}

# find_kab_entry
# Given a PDB record, try to find the corresponding entry in the kab
# hash. If it doesn't exist, create a blank one and return it.
sub find_kab_entry
{
	my $kab = shift;		# The kab hash
	my $record = shift;		# The PDB record to look for
	my $fields = $record->{"fields"};
	my $entry;

	foreach $entry (@{$kab->{"entries"}})
	{
		return $entry if $entry->{"X-PilotID"} eq $record->{"id"};
				# This must be the one we're looking for
				# XXX - Or is it? The ID changes when
				# you upload a new record. Or maybe
				# that's just for brand-new records,
				# not when you upload a modified
				# existing record.

		next if $entry->{"name"} ne $fields->{"name"};
		next if $entry->{"firstname"} ne $filds->{"firstName"};

		# XXX - I have a few entries with no first or last
		# name, just a company name. Ought to handle these
		# entries as well.

		# Found it
		return $entry;
	}

	# The entry doesn't exist. Create a new, blank one
	my $retval;			# Reference to kab entry

	$retval = {
		"X-PilotID"	=> undef,
		URL		=> undef,
		additionalName	=> undef,
		address		=> undef,
		birthday	=> undef,
		comment		=> undef,
		country		=> undef,
		deliveryLabel	=> undef,
		email		=> undef,
		email2		=> undef,
		email3		=> undef,
		emails		=> undef,
		fax		=> undef,
		firstname	=> undef,
		fn		=> undef,
		keywords	=> undef,
		modem		=> undef,
		name		=> undef,
		namePrefix	=> undef,
		org		=> undef,
		orgSubUnit	=> undef,
		orgUnit		=> undef,
		role		=> undef,
		state		=> undef,
		talk		=> undef,
		telephone	=> undef,
		title		=> undef,
		town		=> undef,
		zip		=> undef
	};
	push @{$kab->{"entries"}}, $retval;
	return $retval;
}

# Die
# Hook for die(). Intercepts the message and prepends an error code if
# there wasn't already one.
sub Die
{
	my $msg = shift;

	# XXX - Deal with multi-line warning messages.
	print STDOUT "501 " unless $msg =~ /^\d{3}[- ]/;
	print STDOUT $msg;

	return;
}

# Warn
# Hook for warn(): when a conduit prints a warning, it should go to
# STDOUT, and be preceded by an error code.
sub Warn
{
	my $msg = shift;

	# XXX - Deal with multi-line warning messages.
	print STDOUT "301 " unless $msg =~ /^\d{3}[- ]/;
	print STDOUT $msg;

	return;
}