package UML::MetaMetaModel::Builder;

use 5.6.1;
use strict;
#use warnings;

our $AUTHOR = q{ ks.perl@kurtstephens.com 2004/04/14 };
our $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

=head1 NAME

UML::MetaModel::Builder - Class for constructing a Model from an input stream.

=head1 SYNOPSIS

  use UML::MetaMetaModel::Factory;
  use UML::MetaMetaModel::Builder;
  my $builder = UML::MetaMetaModel::Builder('factory' => $factory);
  $parser->parse($builder);


=head1 DESCRIPTION

Typically a model parser constructs one of these for handling parsing events.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

Kurt Stephens, ks.perl@kurtstephens.com 2003/04/14

=head1 SEE ALSO

L<UML::XMI|UML::XMI>

=head1 VERSION

$Revision: 1.3 $

=head1 METHODS

=cut


####################################################################################

use base qw(UML::MetaMetaModel::Object);

use UML::MetaMetaModel::Util qw(:all);

use Carp qw(confess);

####################################################################################

sub initialize
{
  my ($self) = @_;

  $self->SUPER::initialize;

  # Current Namespace.
  $self->{'namespace'} ||= undef;
  $self->{'namespaceSaved'} ||= [ ];

  # Current Generalization parents.
  $self->{'generalization_parent'} ||= [ ];
  $self->{'generalization_parentSaved'} ||= [ ];

  # Collection of top-level meta objects.
  # Which are later vivified after all Classifiers have been created.
  $self->{'.attribute'} ||= [ ];
  $self->{'.association'} ||= [ ];
  $self->{'.usage'} ||= [ ];
  $self->{'.generalization'} ||= [ ];

  $self->{'.loaded'} ||= { };

  $self->{'debugInput'} ||= 0;
  $self->{'debugCreate'} ||= 0;

  $self;
}


#######################################################################

sub create
{
  my ($self, $name, @args) = @_;

  local $self->{'factory'}{'debugCreate'} = $self->{'debugCreate'};

  $self->{'factory'}->create($name, @args);
}


#######################################################################
# Support 
#
# Glued to MetaMetaModel functions.
# 

sub name_qualified
{
  my ($self, $obj) = @_;

  ModelElement_name_qualified($obj);
}


sub namespace_root
{
  my ($self, $ns) = @_;

  ModelElement_namespace_root($ns);
}


sub ownedElement_name_safe
{
  my ($self, $name, $ns) = @_;

  Namespace_ownedElement_name($ns, $name);
}


sub ownedElement_name
{
  my ($self, $name, $ns) = @_;

  $ns ||= $self->model;

  Namespace_ownedElement_name($ns, $name);
}


sub ownedElement_name_
{
  my ($self, $name, $ns) = @_;

  $ns ||= $self->model;

  Namespace_ownedElement_name_($ns, $name);
}


#
# This is a lexical convention, not a UML convention.
#
# If looking up a name in from the context of a Classifier
# fallback on the Classifier's namespace.
# 
# This may not be typical of most languages but we are
# parsing a specification, and we dont need a bunch of Usage
# when most Classifiers in a Package colaborate with each other.
#
sub lookupType
{
  my ($self, $name, $ns) = @_;

  $ns ||= $self->model;

  Namespace_lookup($ns, $name);
}



#######################################################################
# Model Managment:
#
# A model has classifiers.
# We cannot create all the elements until all the classifiers 
# have been created, because some elements may reference
# Classifiers that have not been created yet.
#
# Once we have created all the classifiers, we
# can back-patch the type name references
# and construct the Attributes and AssociationEnds.
#
# This code also assumes that setting (or adding) one end of an 
# AssociationEnd link in an Element will cause the opposite
# AssociationEnd link to be updated appropriately.
#
# The UML::MetaMetaModel classes implment this protocol. 
# The generated UML::MetaModel will implement this protocol by 
# definition.
#

sub begin_Model
{
  my ($self, $model) = @_;

  # $DB::single = 1;
  $model ||= $self->{'model'};
  $model ||= $self->create('Model');
  $self->{'model'} = $model;

  print STDERR "Model ", $model->toString, " {\n" if $self->{'debugInput'};

  # A Model is a Namespace.
  $self->begin_Namespace($model);

  $model;
}


sub model
{
  my ($self) = @_;
  
  # $DB::single = 1;
  
  # Return the updated model.
  $self->{'model'};
}



sub end_Model
{
  my ($self) = @_;

  die("Not enough end_Namespace") if $self->namespace ne $self->model;

  # A Model is a Namespace.
  $self->end_Namespace();

  # Add Usages to Namespaces
  eval {
    for my $x ( @{$self->{'.usage'}} ) {
      $self->_add_Usage($x);
    }
    @{$self->{'.usage'}} = ();
  };
  if ( $@ ) {
    die("While adding Usages: \n$@");
  }
  
  # Add Generalizations to Classifiers
  eval {
    for my $x ( @{$self->{'.generalization'}} ) {
      my $cls = $x->[0];
      my @gen = @{$x->[1]};

      eval {
	# $DB::single = 1;
	# Look up Generalization parent in the namespace (i.e. Package)
	# of the Class.
	#$DB::single = 1 if grep($_ eq 'Expression', @gen);
	@gen = map($self->lookupType($_, $cls->namespace), @gen);
	
	@gen = map($self->create('Generalization',
				 'parent' => $_,
				 'child' => $cls,
				 ),
		   @gen);

	# $cls->add_generalization_parent(@gen);
      };
      if ( $@ ) {
	$cls = $cls->name;
	die("in Classifier $cls: \n$@");
      }
    }
    @{$self->{'.generalization'}} = ();
  };
  if ( $@ ) {
    die("While adding Generalizations: \n$@");
  }
  
  # Add Attributes to Classifiers
  eval {
    for my $x ( @{$self->{'.attribute'}} ) {
      $self->_add_Attribute($x);
    }
    @{$self->{'.attribute'}} = ();
  };
  if ( $@ ) {
    die("While adding Attributes: \n$@");
  }
  
  # Add Associations to Classifiers
  eval {      
    for my $assoc ( @{$self->{'.association'}} ) {
      # $DB::single = 1;
      $self->_add_Association($assoc);
    }
    @{$self->{'.association'}} = ();
  };
  if ( $@ ) {
    die("While adding Associations: \n$@");
  }

  print STDERR "} // Model\n" if $self->{'debugInput'};

  # Return the updated model.
  $self->{'model'};
}


#######################################################################

# Namespace mgmt.

sub begin_Namespace
{
  my ($self, $ns) = @_;

  # $DB::single = 1;

  print STDERR "Namespace ", $ns->name, " {\n" if $self->{'debugInput'};

  push(@{$self->{'namespaceSaved'}}, $self->{'namespace'});
  $self->{'namespace'} = $ns;

  $ns;
}


sub end_Namespace
{
  my ($self) = @_;
  
  my $ns = $self->{'namespace'};

  $self->{'namespace'} = pop(@{$self->{'namespaceSaved'}});

  print STDERR "} // Namespace\n" if $self->{'debugInput'};

  $ns;
}



#######################################################################

sub begin_Package
{
  my ($self, $name) = @_;

  print STDERR "Package $name {\n" if $self->{'debugInput'};

  my $ns # = $self->ownedElement_name_safe($self->{'namespace'}, $name)
  ;

  if ( ! $ns ) {
    $ns = $self->create('Package',
			'name' => $name,
			'namespace' => $self->{'namespace'},
			);
  }

  # Package is a Namespace.
  $self->begin_Namespace($ns);

  $ns;
}


sub end_Package
{
  my ($self) = @_;

  # Package is a Namespace.
  $self->end_Namespace;

  print STDERR "} // Package\n" if $self->{'debugInput'};

  $self;
}


#######################################################################
#

sub add_Usage
{
  my ($self, @ns) = @_;

  # $DB::single = 1 if $self->{'namespace'} =~ /Package/;

  push(@{$self->{'.usage'}}, [ $self->{'namespace'}, \@ns ]);

  $self;
}


sub _add_Usage
{
  my ($self, $x) = @_;

  my @ns = @{$x->[1]};

  # $DB::single = 1;

  my @all;
  for my $ns ( @ns ) {
    my @name = split('::', $ns);
    if ( $name[-1] eq '*' ) {
      pop @name;
      my $name = join('::', @name);
      $ns = $self->ownedElement_name_($name);
      push(@all, $ns->ownedElement);
    } else {
      $ns = $self->ownedElement_name_($ns);
      push(@all, $ns);
    }
  }

  confess("importedElement is not ref") if grep(! ref($_), @all);

  $x->[0]->add_importedElement(@all);

  $self;
}


#######################################################################
# Manage a block of default Generalizations.

sub begin_Generalization_parent
{
  my ($self, $x) = @_;

  my $name = join(', ', @$x);
  print STDERR "Generalization $name { \n" if ( $self->{'debugInput'} );

  push(@{$self->{'generalization_parentSave'} ||= [ ]}, $self->{'generalization_parent'});
  $self->{'generalization_parent'} = [ @$x ];

  $self;
}


sub end_Generalization_parent
{
  my ($self) = @_;
  
  $self->{'generalization_parent'} = pop(@{$self->{'generalization_parentSaved'}});

  print STDERR "} // Generalization\n" if ( $self->{'debugInput'} );

  $self;
}


#######################################################################

sub begin_Classifier
{
  my ($self, $name, $meta, $gens) = @_;

  # Generalize the classifier.

  $gens ||= $self->{'generalization_parent'};

  $meta ||= 'Class';
  print STDERR "Classifier ($meta) $name { \n" if ( $self->{'debugInput'} );

  # Create a new Classifier object.
  my $cls = $self->create($meta,
			  'name' => $name,
			  'namespace' => $self->{'namespace'},
			 );


  # Remember generalizations for later because
  # We could be importing from another package.
  if ( $gens && @$gens ) {
    push(@{$self->{'.generalization'}}, [ $cls, [ @$gens ] ]);
  }

  # A Classifier is a Namespace.
  $self->begin_Namespace($cls);
 
  $cls;
}


sub end_Classifier
{
  my ($self, @opts) = @_;

  # A quicky!!
  if ( $opts[0] ) {
      $self->begin_Classifier(@opts);
  }

  # A Classifier is a Namespace.
  my $cls = $self->end_Namespace;

  print STDERR "} // Classifier\n" if ( $self->{'debugInput'} );

  $self;
}


#######################################################################
# Add a attribute.
# Type resolution is elided untill _add_Attribute.
#

sub add_Attribute
{
  my ($self, $x) = @_;

  confess("Attribute name") unless $x->{'name'};
  confess("Attribute type") unless $x->{'type'};

  $x->{'owner'} ||= $self->namespace;
  $x->{'namespace'} ||= $x->{'owner'};

  if ( $self->{'debugInput'} ) {
    my @x = %$x;
    local $" = ", ";
    print STDERR "Attribute = @x\n";
  }

  push(@{$self->{'.attribute'}}, $x);
  
  $x;
}


sub _add_Attribute
{
  my ($self, $x) = @_;

  confess("Attribute name") unless $x->{'name'};
  confess("Attribute type") unless $x->{'type'};

  # $DB::single = 1;

  Multiplicity_fromString(\$x->{'multiplicity'}, $self);

  # Lookup Attribute types in the Class namespace (i.e. Package).
  $self->lookupType(\$x->{'type'}, $x->{'namespace'}->namespace);

  my $attr = $self->create('Attribute', %$x);
  
  $attr;
}


#######################################################################
# Literals are primitive so they can be added now.
#

sub add_EnumerationLiteral
{
  my ($self, $name) = @_;

  print STDERR "  $name; // EnumerationLiteral\n" if ( $self->{'debugInput'} );

  my $e = $self->namespace;
  my $l = $self->create('EnumerationLiteral',
			'name' => $name,
			'enumeration' => $e,
			'namespace' => $e,
			);

  $e->add_literal($l);

  $self;
}


#######################################################################
# Add an Association.
# Type resolution is elided untill _add_Attribute.

sub add_Association
{
  my ($self, $x) = @_;

  $x->{'namespace'} ||= $self->{'namespace'};

  # If associationClass is '.' then this Association
  # is the AssocationClass's connection data.
  if ( $x->{'associationClass'} eq '.' ) {
    $x->{'associationClass'} = $self->{'namespace'};
  }
  
  for my $end ( @{$x->{'connection'}} ) {
    Multiplicity_fromString(\$end->{'multiplicity'}, $self);
 
    $end->{'namespace'} ||= $x->{'namespace'}; 
    confess("Same AssociationEnd specified more than once") if grep($_ eq $end, @{$x->{'connection'}}) > 1;

    $end->{'participant'} = $x->{'namespace'}
    if ( $end->{'participant'} eq '.' );
  }

  UML::MetaMetaModel::Object::__fix_association_end_names
  (
   $x->{'connection'}[0]{'name'},
   $x->{'connection'}[1]{'name'},
   );

  # confess('Too many AssociationEnds') if @{$x->{'connection'}} > 2;


  if ( $self->{'debugInput'} ) {
    my @x = %$x;
    local $" = ", ";
    print STDERR "Association = @x\n";
    for my $end ( @{$x->{'connection'}} ) {
      @x = %$end;
      print STDERR "  AssociationEnd @x\n";
    }
  }

  push(@{$self->{'.association'}}, $x);

  $x;
}


sub _add_Association
{
  my ($self, $x) = @_;

  # $DB::single = 1;

  for my $end ( @{$x->{'connection'}} ) {
    #use Data::Dumper;
    #print STDERR Data::Dumper->new([$end])->Maxdepth(2)->Dump, "\n";

    #
    # If the namespace of the AssocationEnd is a Classifier,
    # then use the Classifier's namespace (i.e. Package|Model)
    # to lookup the participant by name.
    #
    my $ns = $x->{'namespace'};
    #$DB::single = 1 if $end->{'participant'} eq 'MultiplicityRange';
    if ( $ns->isaClassifier ) {
      $ns = $ns->namespace;
    }

    $self->lookupType(\$end->{'participant'}, $ns);

    #$DB::single = 1;
    $end = $self->create('AssociationEnd', %$end);
  }

  my $assoc;
  if ( $assoc = $x->{'associationClass'} ) {
    # $DB::single = 1;
    # Set the AssociationClass's connection(s).
    $assoc->add_connection(@{$x->{'connection'}});
  } else {
    $assoc = $self->create('Association', %$x);
  }

  $assoc;
}


####################################################################################

1;

####################################################################################


### Keep these comments at end of file: ks.perl@kurtstephens.com 2003/04/06 ###
### Local Variables: ###
### mode:perl ###
### perl-indent-level:2 ###
### perl-continued-statement-offset:0 ###
### perl-brace-offset:0 ###
### perl-label-offset:0 ###
### End: ###

