#!/usr/bin/perl
# Filename:	ahne2gedcom
# Author:	Thorsten Riemer
  my $VERSION=  1.00;
# See License:	Freeware
# Description:	converts a gedcom file to @hne
use strict;

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0;
$PROGNAME =~ s|.*/||;

##################################################
# Usage
##################################################
sub usage {
  foreach my $msg (@_) { print STDERR "ERROR:  $msg\n"; }

print STDERR <<USAGE;

Usage:	
converts a ahne xml file ta a GEDCOM file

$PROGNAME <ahnefile>

Examples:
% $PROGNAME ahne.xml		

Author:      
Thorsten Riemer, http://www.riemerundco.de


USAGE

  exit -1;
}

sub version {
  print "\n";
  printf "This is $PROGNAME version %4.2f\n",$VERSION;
  print "\n";
  print "Copyright (c) 2004 Thorsten Riemer <riemerundco.de>\n";
  print "\n";
  exit -1;
}

sub parse_args {
  my $file;
  while (my $arg=shift(@ARGV)) {
    if ($arg =~ /^-h$/) { usage(); }
    if ($arg =~ /^-v$/) { version(); }
    if ($arg =~ /^-d$/) { $MAIN::DEBUG=1; next; }
    if ($arg =~ /^-.+/) { usage("Unknown option: $arg"); }
    usage("Too many files specified [$arg and $file]") if defined $file;
    $file=$arg;
  }
  usage("No file specified!") unless $file;

  ($file);
}

sub debug {
  return unless $MAIN::DEBUG;
  foreach my $msg (@_) { print STDERR "[$PROGNAME] $msg\n"; }
}

##################################################
# Main code
##################################################
sub load {
  my ($file) = @_;
  debug($file);
  open(FH, $file) || die "file not found: $file, ";;
  my @lines = <FH>;
  close(FH);
  
  my $id;
  my $fid = 1;
  my $a;
  my %ahnen;
  my %famh;
  my @idlist;
  my %moth = ("01" => "JAN", "02" => "FEB", "03" => "MAR", "04" => "APR", "05" => "MAY", "06" => "JUN", "07" => "JUL", "08" => "AUG", "09" => "SEP", "10" => "OCT", "11" => "NOV", "12" => "DEC");
  
  # build hash
  foreach(@lines) 
  {
    my $line = $_;
    # parse line
    $line =~ /<(\w*)>(.*)<\/(\w*)>|<(\w*)>|<(\/\w*)>/;
    my $strt = $1;
    my $data = $2;
    my $fin = $3;
    
    if (! defined $strt || ! defined $data) {next;}
      
    if ($strt =~ /ID/) {
    	$id = $data;
	push(@idlist,$id);
    	next;
    }
    
    if ($strt =~ /Mutter/) {
	my $assoc = "$data.child__";
	$ahnen{$assoc} = $id;
    }
    
    if ($strt =~ /Vater/) {
	my $assoc = "$data.child__";
	$ahnen{$assoc} = $id;
    }
    
    my $assoc = "$id.$strt";
    $ahnen{$assoc} = $data;
    debug("$assoc = $data\n");
    
    undef $strt;
    undef $data;
  }

  print <<"Header";
0 HEAD
1 SOUR 
2 VERS 1.0
2 NAME Perl Ahne to GEDCOM transformer 
2 CORP www.riemerundco.de
1 DEST 
1 DATE 25 APR 2004
1 SUBM \@S001\@ 
1 CHAR ANSEL
1 GEDC
2 VERS 5.5
2 FORM LINEAGE-LINKED
Header

  # build GEDCOM
  foreach(@idlist) 
  {
    	my $d = $_;
	# INDI
       	print "0 \@$d\@ INDI\n";
    	$a = "$d.Vorname";
    	my $f = $ahnen{$a};
    	$a = "$d.Nachname";
    	my $l = $ahnen{$a};
    	
    	# NAME
    	print "1 NAME ";
    	print "$f " if defined $f;
    	$a = "$d.Vornamen2";
    	$f = $ahnen{$a};
    	print "$f " if defined $f;
    	print "\/$l\/" if defined $l;
    	print "\n";
    	
    	# SEX
    	$a = "$d.Geschlecht";
    	$l = $ahnen{$a};
    	my $fams = 0;
    	my $famc = 0;
    	my $fam;
    	my $famv;
    	my $famm;
    	if (defined $l) {
    		# set SEX and build family hash
    		my $ep = "$d.Ehepartner";
    		$ep = $ahnen{$ep};
    		my $mu = "$d.Mutter";
    		$mu = $ahnen{$mu};
    		my $va = "$d.Vater";
    		$va = $ahnen{$va};
    		if (defined $mu || defined $va) {
			$famm = $famh{"W.$mu"} if defined $mu;
			$famv = $famh{"H.$va"} if defined $va;
			if (! defined $famm && ! defined $famv) {
				$famm = "F0$fid"; 
				$fid++;
			}
			else { if (! defined $famm) { $famm = $famv; }}
			$famh{"C.$d"} = $famm;
			$famc = 1;
		}
	    	$a = "$d.child__";
	    	if (defined $ahnen{$a}) {
	     		if ($l eq "m") {
	    			$l = "M";
	    			if (defined $ep) {
		    			$fam = $famh{"W.$ep"};
		    			if (defined $fam) { $famh{"H.$d"} = $fam;}
		    			else { 
		    				$fam = "F0$fid";
		    				$famh{"H.$d"} = $fam; 
		    				$fid++; 
		    			}
		    			$fams = 1;
	    			}
	   		}
	    		if ($l eq "w") {
	    			$l = "F";
	    			if (defined $ep) {
		    			$fam = $famh{"H.$ep"} if defined $ep;
		    			if (defined $fam) { $famh{"W.$d"} = $fam;}
		    			else { 
		    				$fam = "F0$fid";
		    				$famh{"W.$d"} = $fam; 
		    				$fid++; 
		    			}
		    			$fams = 1;
	    			}
	    		}
	    	}
    		print "1 SEX $l\n";
    	}
    	
    	# BIRT
    	$a = "$d.Geburtsdatum";
    	$f = $ahnen{$a};
    	$a = "$d.Geburtsort";
    	$l = $ahnen{$a};
    	if (defined $f || defined $l) {
    		print "1 BIRT\n";
    		if (defined $f) {
    			$f =~ /(....)-(..)-(..)T00:00:00/;
    			print "2 DATE $3 $moth{$2} $1\n";
    		}
    		print "2 PLAC $l\n" if defined $l;
       	}
       	
       	# DEAT
    	$a = "$d.Todesdatum";
    	$f = $ahnen{$a};
    	$a = "$d.Todesort";
    	$l = $ahnen{$a};
    	if (defined $f || defined $l) {
    		print "1 DEAT\n";
    		if (defined $f) {
    			$f =~ /(....)-(..)-(..)T00:00:00/;
    			print "2 DATE $3 $moth{$2} $1\n";
    		}
    		print "2 PLAC $l\n" if defined $l;
       	}
       	
       	# OCCU
    	$a = "$d.Beruf";
    	$l = $ahnen{$a};
    	print "1 OCCU\n2 PLAC $l\n" if defined $l;

       	# FAMS
    	print "1 FAMS \@$fam\@\n" if $fams > 0;

       	# FAMC
    	print "1 FAMC \@$famm\@\n" if $famc > 0;
  }
  
  # FAM
  foreach(@idlist) 
  {
    	my $d = $_;
	next if ! defined $d;

	# lookup for family id
	my $fam1 = $famh{"W.$d"};
	my $fam2 = $famh{"H.$d"};
	next if ! defined $fam1 && ! defined $fam2;
	
	if (defined $fam1) {
		print "0 \@$fam1\@ FAM\n";
		$famh{"W.$d"} = undef;
		print "1 WIFE \@$d\@\n";
	}
	if (defined $fam2) {
		print "0 \@$fam2\@ FAM\n";
		$famh{"H.$d"} = undef;
		print "1 HUSB \@$d\@\n";
	}
	$fam1 = $fam2 if ! defined $fam1;
	my $key;
	my $val;
	while (($key, $val) = each(%famh)) {
	  if (defined $val && $val eq $fam1) {
	  	$key =~ /([HWC])\.(.*)/;
	  	print "1 HUSB \@$2\@\n" if $1 eq "H"; 
	  	print "1 WIFE \@$2\@\n" if $1 eq "W"; 
	  	print "1 CHIL \@$2\@\n" if $1 eq "C"; 
		$famh{$key} = undef;
	  }
	}
    	$a = "$d.Hochzeitsdatum";
    	my $f = $ahnen{$a};
    	$a = "$d.Hochzeitsort";
    	my $l = $ahnen{$a};
    	
    	# MARR
	if (defined $f) {
    		print "1 MARR\n";
		$f =~ /(....)-(..)-(..)T00:00:00/;
		print "2 DATE $3 $moth{$2} $1\n";
    		print "2 PLAC $l\n" if defined $l;
	}
   }
   print "0 TRLR\n";
}


sub main {
  my $file = parse_args();
  load($file);
}

main();