#!/usr/local/bin/perl -w

require 5.003;

use strict;
use Fcntl;
use Getopt::Std;
use File::Copy;
use XML::Parser;

my($version) = q$Revision: 1.8 $ =~ /(\d+\.\d+)/;
my($basename) = $0 =~ m-/([^/]*)$-;

my $usage = "Usage: $basename [-p] <program>\n";

use vars qw($opt_p);
getopts('p') or die $usage;

my @pwpath = (
	".",
	"$ENV{HOME}/lib/$basename",
	"/usr/local/lib/$basename",
	"/usr/lib/$basename",
	"/lib/$basename",
);

if (defined $ENV{PALMPASSPATH}) {
	unshift @pwpath, split(/:/, $ENV{PALMPASSPATH});
}
my $xmlfile;
for my $path (@pwpath) {
	if ( -e "$path/palmpass.xml") {
		$xmlfile = "$path/palmpass.xml";
		last;
	}
}
die "Cannot find the file palmpass.xml.\n" unless defined $xmlfile;

my $uudecode;
if (defined $opt_p) {
	($uudecode) = grep { -x } (
		"/usr/local/bin/uudecode",
		"/usr/contrib/bin/uudecode",
		"/usr/bin/uudecode",
		"/bin/uudecode",
		"$ENV{HOME}/bin/uudecode",
	);
	die "Cannot find the program uudecode.\n" unless defined $uudecode;
}

my %prog;
my $re = shift or die $usage;

my $p = new XML::Parser(
		ParseParamEnt => 1,
		Handlers => {	Start		=> \&handle_Start,
				End		=> \&handle_End,
				Char		=> \&handle_Char,
		},
	);
$p->parsefile($xmlfile);

sub handle_Start {
	my($p,$element,%attr) = @_;
	if ($element eq "PW_DATA") {
		print ucfirst($basename), " v$version for Perl\n";
		print "Using:\t$xmlfile\n";
		if (exists $attr{'DATE'}) {
			print "Date:\t$attr{'DATE'}\n";
		}
		print "\n";
	}
	if ($element eq "TARGET") {
		if ($attr{'LONGNAME'} =~ /$re/io) {
			print "Name:\t$attr{'LONGNAME'}\n";
			if (exists $attr{'URL'}) {
				print "URL:\t$attr{'URL'}\n";
			}
			if (exists $attr{'TEXT'}) {
				print "Text:\t$attr{'TEXT'}\n";
			}
			$prog{'name'} = $attr{'LONGNAME'};
		}
	}
	if ($element eq "FILE" and exists $prog{'name'}) {
		$prog{'patchfile'} = $attr{'NAME'};
		$prog{'patchname'} = $attr{'LONGNAME'};
	}
	if ($element eq "ATTACH" and exists $prog{'name'}) {
		$prog{'attachfile'} = $attr{'NAME'};
		$prog{'attachname'} = $attr{'LONGNAME'};
	}
}

sub handle_End {
	my($p,$element,%attr) = @_;
	if ($element eq "TARGET" and %prog) {
		undef %prog;
		print "\n";
	}
	if ($element eq "FILE" and exists $prog{'patchfile'}) {
		if (exists $prog{'data'}) {
			print "Patch:\t", $prog{'patchname'} || "available", "\n";
			print "File:\t", $prog{'patchfile'} || "unknown", "\n";
			if (defined $opt_p) {
				askpatch(\%prog);
			}
		}
		delete $prog{'data'};
	}
	if ($element eq "ATTACH" and exists $prog{'attachfile'}) {
		print "Extra:\t", $prog{'attachname'} || "available", "\n";
		print "File:\t", $prog{'attachfile'} || "unknown", "\n";
		if (exists $prog{'data'}) {
			if (defined $opt_p) {
				askcreate(\%prog);
			}
		}
		delete $prog{'data'};
	}
}

sub handle_Char {
	my($p,$data) = @_;
	if (exists $prog{'patchfile'} or exists $prog{'attachfile'}) {
		push @{$prog{'data'}}, $data;
	}

}

sub ask {
	my($action,$file) = @_;
	print "$action file? (y/N) ";
	my $answer = <STDIN>;
	if ($answer =~ /^y/i) {
		unless ($file) {
			print "What file? ";
			chomp($answer = <STDIN>);
			$file = $answer;
		}
		return $file;
	}
	return undef;
}

sub askpatch {
	my($prog) = @_;
	if ($prog->{'patchfile'} = ask("Patch",$prog->{'patchfile'})) {
		if (patch($prog->{'patchfile'}, @{$prog->{'data'}})) {
			print "Done.\n";
		} else {
			print "Skipped.\n";
		}
	}
}

sub askcreate {
	my($prog) = @_;
	if ($prog->{'attachfile'} = ask("Create",$prog->{'attachfile'})) {
		if (create($prog->{'attachfile'}, @{$prog->{'data'}})) {
			print "Done.\n";
		} else {
			print "Skipped.\n";
		}
	}
}

sub patch {
	my($file,@data) = @_;
	my $mode = O_RDONLY;
	my $ext  = ".orig";
	my $error;
	RUN: {
		unless(sysopen(FILE,$file,$mode)) {
			warn "sysopen: $!\n";
			$error++;
			last RUN;
		}
		CHANGE: foreach my $data (@data) {
			$data =~ s/^\s+//; $data =~ s/\s+$//;
			next CHANGE unless $data;
			my($hexpos,$hexout,$hexin) = split(/\s+/,$data);
			my $decpos  = hex($hexpos);
			my($binout) = pack("H".length($hexout),$hexout);
			unless (seek(FILE,$decpos,0)) {
				warn "seek: $!\n";
				$error++;
				last CHANGE;
			}
			my $buffer;
			unless (read(FILE,$buffer,length($binout)) == length($binout)) {
				if ($!) {
					warn "read: $!\n";
				} else {
					warn "read: error\n";
				}
				$error++;
				last CHANGE;
			}
			if ($buffer ne $binout) {
				warn "read: inconsistency found\n";
				$error++;
				last RUN;
			}
			if ($mode eq O_RDWR) {
				my($binin) = pack("H".length($hexin),$hexin);
				unless (seek(FILE,-length($binin),1)) {
					warn "seek: $!\n";
					$error++;
					last CHANGE;
				}
				print FILE $binin;
			}
		}
		unless (close(FILE)) {
			warn "close: $!\n";
			last RUN;
		}
		last RUN if $error;
		if ($mode eq O_RDONLY) {
			unless (rename($file,$file.$ext)) {
				$error++;
				last RUN;
			}
			unless (copy($file.$ext,$file)) {
				$error++;
				last RUN;
			}
			$mode = O_RDWR;
			redo RUN;
		}
		last RUN;
	}
	return not $error;
}

sub create {
	my($file,@data) = @_;
	for (@data) {
		s/^[ \t]*//;
	}
	$file .= ".uu";
	unless (open(FILE,">$file")) {
		warn "open: $!\n";
		return;
	}
	print FILE @data, "\n";
	unless (close(FILE)) {
		warn "close: $!\n";
		return;
	}
	if (system($uudecode,$file)) {
		return;
	}
	unless (unlink($file)) {
		warn "unlink: $!\n";
	}
	return 1;
}