package InterMine::Model;

use strict;
use warnings;

use Carp qw/confess/;
use Moose::Util::TypeConstraints;
use XML::Parser::PerlSAX;
use InterMine::Model::Handler;

use constant TYPE_PREFIX => "InterMine";

our $VERSION = '0.9607';

=head1 NAME

InterMine::Model - the representation of an InterMine model

=head1 SYNOPSIS

  use InterMine::Model;

  my $model_file = 'flymine/dbmodel/build/model/genomic_model.xml';
  my $model = InterMine::Model->new(file => $model_file);
  my $gene = $model->make_new(
    Gene => {
        primaryIdentifier => "FBgn0004053",
        secondaryIdentifier => "CG1046",
        symbol              => "zen",
        name                => "zerknullt",
        length              => "3474",
        organism            => {
            shortName => "D. melanogaster",
        }
        ncbiGeneNumber      => 40828,
    });

  $gene->getName(); # "zerknullt"

  ...

=head1 DESCRIPTION

The class is the Perl representation of an InterMine data model.  The
C<new()> method can parse the model file.  The
C<get_classdescriptor_by_name()> method will return an
InterMine::Model::ClassDescriptor object for the class with the given
name, and the C<make_new()> method will return an instantiated object
of the given class.

For an example model see:
L<http://trac.flymine.org/browser/trunk/intermine/objectstore/model/testmodel/testmodel_model.xml>

=head1 CLASS METHODS

=cut

=head2 new( %options )

Standard constructor - accepts key/value pairs. Possible options are:

=over 4

=item * source: the source of the xml 

can be a ScalarRef, filehandle, filename, or string (or anything that overloads "")
(tested in that order)

=item * file: The file to load the model from 

[deprecated - use source instead] 

=item * string: A string containing the xml to load the model from 

[deprecated - use source instead]

=item * origin: Where this model comes from 

usually a mine name - optional

=back

=cut

sub new {
    my $class = shift;
    my %opts  = @_;

    print join('=>', @_) if $ENV{DEBUG};

    my $source = $opts{source} || $opts{file} || $opts{string}
        or confess "No source passed to $class constructor";

    my $self  = {%opts};

    $self->{class_hash}   = {};
    $self->{object_cache} = {};

    bless $self, $class;

    { 
        no warnings 'newline';

        if      (ref $source eq 'SCALAR') {
            $self->_process_string($$source);
        } elsif (ref $source eq 'GLOB') {
            $self->_process_string(join('', <$source>));
        } elsif (-r $source || $opts{file}) {
            $self->_process_file($source);
        } else {
            $self->_process_string("$source");
        }
    }

    $self->_fix_class_descriptors();

    return $self;
}

sub _process_string {
    my ($self, $string) =  @_;
    return $self->_process($string, 1);
}

sub _process_file {
    my ($self, $filename) = @_;
    -r $filename || confess "Cannot read model source file $filename. Aborting";
    return $self->_process($filename, 0);
}

sub _process {
    my $self             = shift;
    my $source_arg       = shift;
    my $source_is_string = shift;

    my $handler = new InterMine::Model::Handler( model => $self );
    my $parser = XML::Parser::PerlSAX->new( Handler => $handler );

    my $source;

    if ($source_is_string) {
        $source = { String => $source_arg };
    }
    else {
        $source = { SystemId => $source_arg };
    }

    $parser->parse( Source => $source );

}

sub _add_type_constraint_and_coercion {
    my $self = shift;
    my $class_name = shift;

    subtype $class_name, as "Object", where {$_->isa($self->{perl_package} . $class_name)};
    subtype "ArrayOf" . $class_name, as "ArrayRef[$class_name]";
    coerce $class_name, from 'HashRef', via {
        $self->make_new(($_->{class} || $class_name), $_);
    };
    subtype "ArrayOfHashes", as "ArrayRef[HashRef]";

    coerce "ArrayOf$class_name", from "ArrayOfHashes", 
        via { [map {$self->make_new(($_->{class} || $class_name), $_)} @$_] };
}

use Moose::Meta::Class;

# add fields from base classes to sub-classes so that $class_descriptor->fields()
# returns fields from base classes too
sub _fix_class_descriptors {
    my $self = shift;

    for my $class_name (keys %{ $self->{class_hash} } ) {
        $self->_add_type_constraint_and_coercion($class_name);
    }

    while ( my ( $class_name, $cd ) = each %{ $self->{class_hash} } ) {
        my @fields = $self->_get_fields($cd);
        for my $field (@fields) {
            $cd->add_field($field);
        }
        $cd->_make_fields_into_attributes();
        $cd->make_immutable;
    }
}

sub _get_fields {
    my $self = shift;
    my $cd   = shift;

    my @fields = ();

    for my $field ( $cd->fields() ) {
        my $field_name = $field->name();
        push @fields, $field;
    }

    for my $parent ( $cd->parental_class_descriptors ) {
        push @fields, $self->_get_fields($parent);
    }

    return @fields;
}

=head2 get_classdescriptor_by_name

 Title   : get_classdescriptor_by_name
 Usage   : $cd = $model->get_classdescriptor_by_name("Gene");
 Function: return the InterMine::Model::ClassDescriptor for the given class or
           undef if the class isn't in the model
 Args    : the classname

=cut

sub get_classdescriptor_by_name {
    my $self      = shift;
    my $classname = shift;

    if ( !defined $classname ) {
        confess "no classname passed to get_classdescriptor_by_name()\n";
    }

    $classname =~ s/.*:://;

    # These are always valid
    if ( $classname eq 'Integer' ) {
        return InterMine::Model::ClassDescriptor->new(
            model   => $self,
            name    => $classname,
            extends => ['id'],
        );
    }

    my $class = $self->{class_hash}{$classname}
      || $self->{class_hash}{ $self->{package_name} . $classname };
    confess "$classname not in the model" unless $class;
    return $class;
}

=head2 make_new($class_name, [%attributes|$attributes])

Return an object of the desired class, with the attributes 
given

 my $gene = $model->make_new(Gene => {symbol => "zen", organism => {name => 'D. melanogaster}});

 say $gene->get_symbol             # "zen"
 say $gene->get_organism->get_name # "D. melanogaster"

=cut

sub make_new {
    my $self = shift;
    my $name = (ref $_[0] eq 'HASH') ? $_[0]->{class} : shift;
    my $params = (@_ == 1) ? $_[0] : {@_};

    my $obj = $self->get_classdescriptor_by_name($name)->new_object($params);

    if ($obj->hasObjectId) {
        if (my $existing = $self->{object_cache}{$obj->getObjectId}) {
            $existing->merge($obj);
            return $existing;
        } else {
            $self->{object_cache}{$obj->getObjectId} = $obj;
        }
    } else {
        return $obj;
    }
}

=head2 get_all_classdescriptors

 Title   : get_all_classdescriptors
 Usage   : @cds = $model->get_all_classdescriptors();
 Function: return all the InterMine::Model::ClassDescriptor objects for this
           model
 Args    : none

=cut

sub get_all_classdescriptors {
    my $self = shift;
    return values %{ $self->{class_hash} };
}

=head2 get_referenced_classdescriptor

 Usage    : my $cd = $model->get_referenced_classdescriptor($ref);
 Function : get the class descriptor at the other end of a reference
 Args     : The reference

=cut

sub get_referenced_classdescriptor {
    my $self      = shift;
    my $reference = shift;
    for my $cd ( $self->get_all_classdescriptors ) {
        for my $ref ( $cd->references ) {
            if ( $ref->has_reverse_reference ) {
                if ( $ref->reverse_reference->name eq $reference ) {
                    return $cd;
                }
            }
        }
    }
    return undef;
}

=head2 find_classes_declaring_field( $name )

 Usage    : my @classes = $model->find_classes_declaring_field($str);
 Function : get the class descriptors that declare fields of a certain name  
 Args     : The field's name

=cut

sub find_classes_declaring_field {
    my $self       = shift;
    my $field_name = shift;
    my @returners;
    for my $cd ( $self->get_all_classdescriptors ) {
        for my $field ( $cd->get_own_fields ) {
            push @returners, $cd if ( $field->name eq $field_name );
        }
    }
    return @returners;
}

=head2 package_name

 Title   : package_name
 Usage   : $package_name = $model->package_name();
 Function: return the package name derived from the name space
           eg. "org.intermine.model"
 Args    : none

=cut

sub package_name {
    my $self = shift;
    return $self->{package_name};
}

=head2 model_name

 Title   : model_name
 Usage   : $model_name = $model->model_name();
 Function: return the model name from the model file eg. "testmodel"
 Args    : none

=cut

sub model_name {
    my $self = shift;
    return $self->{model_name};
}

=head2 to_xml

Returns a string containing an XML representation of the model.

=cut

sub to_xml {
    my $self = shift;
    my $xml = sprintf(qq{<model name="%s" package="%s">\n}, 
        $self->model_name, $self->package_name);

    for my $cd (sort($self->get_all_classdescriptors())) {
        $xml .= q[ ] x 2 . $cd->to_xml . "\n";
    }

    $xml .= "</model>";
    return $xml;
}

1;

=head1 AUTHOR

FlyMine C<< <support@flymine.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<support@flymine.org>.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc InterMine::Model

You can also look for information at:

=over 4

=item * FlyMine

L<http://www.flymine.org>

=back

=head1 COPYRIGHT & LICENSE

Copyright 2006,2007,2008,2009, 2010, 2011 FlyMine, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

