#!/usr/bin/perl
# $Id: fixpdb,v 1.3 2010-02-02 02:03:11 adye Exp $
# db2ical requires CPAN packages p5-Palm, Data-ICal, DateTime-Format-ICal,
# Data-ICal-TimeZone, and their dependencies.
#
# Copyright (C) 2009-2010, Tim Adye.
# This program is free software; you may redistribute it under the terms of the
# Artistic License, as specified at http://dev.perl.org/licenses/artistic.html

use warnings;
use strict;

use File::Basename ();
use Getopt::Std ();

my $VERSION= do { my @r= (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d.".("%02d" x $#r), @r };
my $prog= File::Basename::basename ($0, '.exe');

sub help {
#=============================================================================
  print <<EOHELP;
$prog $VERSION - Fix Palm database type and/or creator fields

USAGE:
  $prog [OPTIONS] FILENAME

OPTIONS:
  -h -?    display this help and exit
  -n NAME  database name
  -t TYPE  database type
  -c CRE   database creator

If -n, -t, or -c are not specified, then the current values are displayed.

EXAMPLE:

  $prog -n CalendarDB-PDat -t DATA -c PDat CalendarDB-PDat.pdb

AUTHOR:
  Tim Adye <T.J.Adye\@rl.ac.uk>

LICENSE:
  This program is free software; you may redistribute it under the terms of the
  Artistic License, as specified at http://dev.perl.org/licenses/artistic.html
EOHELP
#=============================================================================
  return 0;
}

exit fixpdb();

sub fixpdb {
  my $opt= {};
  Getopt::Std::getopts ('h?n:t:c:', $opt);
  return help() if $opt->{h} || $opt->{'?'} || @ARGV != 1;
  my $file= $ARGV[0];
  my $upd= (defined $opt->{n} || defined $opt->{t} || defined $opt->{c});
  my $mode= $upd ? '+<:raw' : '<:raw';
  open (my $f, $mode, $file) or die "Could not open file $file: $!\n";
  unless ($upd) {
    seek ($f,  0, 0)          or die "seek 0 failed: $!\n";
    read ($f, my $name,   32) or die "read name failed: $!\n";
    seek ($f, 60, 0)          or die "seek 60 failed: $!\n";
    read ($f, my $type,    4) or die "read type failed: $!\n";
    read ($f, my $creator, 4) or die "read creator failed: $!\n";
    s/\0.*$// for ($name, $type, $creator);
    print "name '$name', type '$type', creator '$creator'\n";
  } else {
    upd ($f,  0, 32, $opt->{n}, 'name');
    upd ($f, 60,  4, $opt->{t}, 'type');
    upd ($f, 64,  4, $opt->{c}, 'creator');
  }
  close ($f);
}

sub upd {
  my ($f, $pos, $len, $s, $ent)= @_;
  return unless defined $s;
  seek ($f, $pos, 0)          or die "seek $pos failed: $!\n";
  if      (length ($s) > $len) {
    $s= substr ($s, 0, $len);
  } elsif (length ($s) < $len) {
    $s .= "\0"x($len-length($s));
  }
  print $f $s                 or die "write $ent failed: $!\n";
  $s =~ s/\0.*$//;
  print "set $ent to '$s'\n";
}
