package ATR::Report::XML;
use base 'ATR::Report';

use strict;
use warnings;

use XML::DOM;
our ($VERSION) = (qw$Revision: 1.5 $)[1];


=head1 NAME

ATR::Report::XML - XML generator subclass for ATR::Report

=cut

# $Id: XML.pm,v 1.5 2005/03/01 19:40:20 mca Exp $

#----------------------------------------------------------------------------

sub _init {
    my ($self, @args) = @_;
    my @left = $self->SUPER::_init(@args);

    $self->{dom} = new XML::DOM::Document;

    return @left;
}

sub getCodeVersionInfo {
    my $self = shift;
    return ($self->SUPER::getCodeVersionInfo,
	   xmlgen => "v$VERSION");
}

sub finish {
    my $self = shift;
    $self->doc->printToFileHandle( $self->{fileHandle} );
}

sub doc { $_[0]->{dom} }

sub DESTROY {
    my $self = shift;
    my $doc = $self->doc;
    $doc->dispose if defined $doc;
    foreach my $selfkey (keys %$self) {
	delete $self->{$selfkey} if $selfkey =~ /^dom$|^dom_|^docTop$/;
    }
    # $self->SUPER::DESTROY; # does not exist
}

sub getDO {
    my ($self, $type, $name) = @_;
    return undef if !$self->{"dom_$type"};
    return $self->{"dom_$type"}->{$name};
}

sub putDO {
    my ($self, $type, $name, $obj) = @_;
    $self->{"dom_$type"}->{$name} = $obj;
}

# Return create-on-demand outer document element
# Also initialises XML header giblets
sub docTop {
    my $self = shift;
    if (!defined $self->{docTop}) {
	$self->{docTop} = 0; # avoid bottomless mess if we get recursed into
	my $D = $self->doc;
#	$D->setDoctype($D->createDocumentType("report", "sysid", "http://www.sanger.ac.uk/PSG/ATR/report.dtd", "int"));
# I don't really have one...
	$D->setXMLDecl($D->createXMLDecl("1.0", "utf-8"));

	my $gtx = ATR::GTx->singleton;
	my %dbinfo = $gtx->getDatabaseInfo;
	my $dbuser = $gtx->currentUser;

	$self->{docTop} = $self->makeElement($D, "report");
	$self->makeElement
	  (undef, "application",
	   $self->getCodeVersionInfo,
	   host => Sys::Hostname::hostname(),
	   display => $ENV{DISPLAY},
	   ssh => $ENV{SSH_CONNECTION},
	   euid => $>,
	   script => $0,
	  );
	$self->makeElement
	  (undef, "data",
	   extracted => scalar localtime,
	   %dbinfo,
	   user => $dbuser->getEmail,
	   team => $gtx->currentTeam,
	  );
    }
    return $self->{docTop};
}

sub makeElement {
    my ($self, $parentNode, $tag, @attr) = @_;
    my $doc = $self->doc;

    # Create DOM Element with attributes
    my $node = $doc->createElement($tag);
    for (my $i=0; $i<@attr; $i+=2) {
	my ($key, $val) = @attr[$i, $i+1];
	if (!defined $val) {
	    $node->setAttribute("no-$key", 1);
	} else {
	    $node->setAttribute($key, $val);
	}
    }

    if (defined $parentNode && $parentNode == $doc) {
	# Insert the top level node without indentation (else DOM barfs)
	$parentNode->appendChild($node);
	return $node;
    }

    # Insert, with some white space
    my $indent = (!defined $parentNode) ? "  " : "    ";
    $parentNode ||= $self->docTop;
    my @kids = $parentNode->getChildNodes;
    if (@kids == 0) {
	$parentNode->appendChild($doc->createTextNode("\n"));
    }
    foreach my $item ($indent, $node, "\n") {
	$parentNode->appendChild(ref($item)
				 ? $item
				 : $doc->createTextNode($item) # convert text
				);
    }
    return $node;
}


sub addMouse {
    my ($self, $mouse) = @_;
    my $mname = $mouse->getMouseName;
    return if $self->getDO('mouse', $mname);

    my $mnode = $self->makeElement(undef, "mouse",
				   peId => $mouse->getPeID,
				   name => $mname,
				   genotype => $mouse->getGenotype,
				   sex => scalar $mouse->getSex,
				   datePairs(dob => $mouse->getDateBirth),
				  );
    $self->putDO('mouse', $mname, $mnode);
}

# utility function
sub datePairs {
    my ($type, $date) = @_;
    return (defined $date
	    ? ($type => $date->getUI, $type.'Full' => $date->getGT)
	    : ($type => 'UNKNOWN')
	   );
}

sub addMatingLitter {
    my ($self, $mating, $litter) = @_;
    my $matename = $mating->getMatingName;
    my $matenode = $self->getDO('matingpair', $matename)
      or die "Can't find mating $matename";

### XXX:DUP ATR::Tk::MatingCard
#    my @dates = sort { $a->cmp($b) } $litter->getWeanedDates;
#    my (%count, %date);
#    foreach my $d (@dates) {
#	my $u = $d->getUI;
#	$count{$u} ++;
#	$date{$u} = $d;
#    }
#    @dates = keys %date;
#    my $dow = join "; ", map {"$_ ($count{$_})"} @dates;
    my $dow = '?'; # broken? show DOW per mouse instead? summarise in XSL?

    my $littname = $litter->getLitterName;
    my $littnode = $self->makeElement($matenode, "litter",
				      name => $littname,
				      datePairs(dob => $litter->getLitterDateBirth), # XXX: obsolescent?
				      dow => $dow,
				      pups => $litter->getPupCount, #  XXX: obsolescent?
				     );
    $self->putDO('litter', $littname, $littnode);
}

sub addMatingPair {
    my ($self, $pair) = @_;
    my $pname = $pair->getMatingName;
    return if $self->getDO('matingpair', $pname);

    my $node = $self->makeElement(undef, "matingPair",
				  peId => $pair->getPeID,
				  colony => $pair->getColonyName,
				  name => $pname,
				  barcode => $pair->getBarcodeString,
				  );
    # Don't need to set parents or litter info, this comes later
    foreach my $licname (qw(PIL PPL 19b User)) {
	my $method = "getLicence$licname";
	$self->makeElement($node, "licenceField",
			   name => $licname,
			   value => $pair->$method);
    }
    $self->putDO('matingpair', $pname, $node);
}

sub addMatingParent {
    my ($self, $mating, $parent) = @_;
    my $matename = $mating->getMatingName;
    my $matenode = $self->getDO('matingpair', $matename)
      or die "Can't find mating pair $matename";
    $self->makeElement($matenode, "parent",
		       mouseName => $parent->getMouseName);
}

sub addLitterMouse {
    my ($self, $litter, $mouse) = @_;
    my $littname = $litter->getLitterName;
    my $littnode = $self->getDO('litter', $littname)
      or die "Can't find litter $littname";
    $self->makeElement($littnode, "pup",
		       mouseName => $mouse->getMouseName);
}


1;
