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.13 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

=head1 NAME

UML::MetaMetaModel::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.13 $

=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;

  # Top-level model.
  $self->{'model_top_level'} ||= undef;

  # Current Model.
  $self->{'model'} ||= undef;
  $self->{'modelSaved'} ||= [ ];

  # 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->{'debugInput'}  ||= $ENV{UML2CODE_BUILDER_DEBUG};
  $self->{'debugCreate'} ||= 0;

  $self;
}


#######################################################################
# Model Managment:
#
# A model has Classifiers.
# We cannot create all the Features (and Associations) until all the Classifiers 
# have been created, because some Features 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 Features and Associations.
#
# This code also assumes that setting (or adding) one end of an 
# AssociationEnd link will cause the opposite
# AssociationEnd links to be updated appropriately.
#
# The UML::MetaMetaModel classes implement this protocol. 
# The generated UML::MetaModel will implement this protocol by 
# definition.
#

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

  #$DB::single = 1;
  my $model = $self->create('Model', 
			    'namespace' => $self->{'namespace'},
			    %opts,
			    );
  
  # Remember last Model.
  push(@{$self->{'modelSave'}}, $self->{'model'});
  $self->{'model'} = $model;

  # Remember the top-level Model.
  $self->{'model_top_level'} ||= $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 current model.
  $self->{'model'};
}


sub model_top_level
{
  my ($self) = @_;
  
  # $DB::single = 1;
  
  # Return the top-level Model.
  $self->{'model_top_level'};
}



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

  my $model = $self->{'model'};

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

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

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

  # Finish the model.
  $model = $self->finish_Model($model);

  # Restore previous Model scope.
  $self->{'model'} = pop(@{$self->{'modelSave'}});
  
  # Return the finished model.
  $model;
}


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

# Namespace mgmt.

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

  # $DB::single = 1;

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

  if ( $self->{'namespace'} ) {
    my $x = Namespace_ownedElement_name($self->{'namespace'}, $ns->{'name'});
    if ( $x && $x ne $ns ) {
      confess("Namespace '" . $self->{'namespace'}->{'name'} . "' already has '$x' named '" . $ns->{'name'} . "'");
    }
  }

  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 $ns->{name}\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) = @_;

  my $ns = $self->{'namespace'};

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

  print STDERR "} // Package $ns->{name}\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;
}


#######################################################################
# 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.

  my %opts;
  $opts{'isAbstract'} = 'true' if ( $name =~ s@/@@sg );
  $opts{'isAbstract'} ||= 'false';

  $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'},
			  %opts,
			 );

  # 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 $cls->{name}\n" if ( $self->{'debugInput'} );

  $cls;
}


#######################################################################
# 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->{'multiplicity'} ||= '1';

  if ( $self->{'debugInput'} ) {
    print STDERR Attribute_asString($x), "\n";
  }

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


#######################################################################
# 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;
  $DB::single == 1 && confess("Not a Enumeration") unless $e->isaEnumeration;

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

  $self;
}


#######################################################################
# Add an Association.
# Type resolution is elided until finish_Association.
#

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

  confess("Not enough AssociationEnds") 
  unless @{$x->{'connection'}} > 1;

  # '/name' refers to Generlization parent implementation of Association
  return '' if grep($_->{'name'} =~ /^\//, @{$x->{'connection'}});

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

  # If associationClass is '.' then this Association
  # is the AssociationClass's connection data.
  if ( $x->{'associationClass'} eq '.' ) {
    $x->{'associationClass'} = $self->{'namespace'};
    $DB::single = 1 unless $x->{'associationClass'}->isaAssociationClass;
    confess("Not an AssociationClass") unless $x->{'associationClass'}->isaAssociationClass;
  }
  
  for my $end ( @{$x->{'connection'}} ) {
    # If participant is '.' use the enclosing Namespace
    # (i.e.) Classifier!!.
    $end->{'participant'} = $self->{'namespace'}
    if ( $end->{'participant'} eq '.' );

    $end->{'targetScope'} ||= 'instance',

    #confess("Same AssociationEnd specified more than once") 
    #if grep($_ eq $end, @{$x->{'connection'}}) > 1;
  }

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


  if ( $self->{'debugInput'} ) {
    print STDERR Association_asString($x), "\n";
  }

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

  $x;
}


#######################################################################
# Subclasses can intercept all object creation here.
#

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

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

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


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

  $self->{'factory'}->flush(@args);

  $self;
}


####################################################################################
# Finish model.
# 

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

  # Flush Classifiers.
  $self->flush('Classifier');

  # Add Usages to Namespaces.
  # Do this first so name => Classifier lookups will work.
  eval {
    for my $x ( @{$self->{'.usage'}} ) {
      $self->finish_Usage($x);
    }
    @{$self->{'.usage'}} = ();
  };
  if ( $@ ) {
    die("While adding Usages: \n$@");
  }
  $self->flush('Usage');


  # Add Generalizations to Classifiers.
  eval {
    for my $x ( @{$self->{'.generalization'}} ) {
      $self->finish_Generalization($x);
    }
    @{$self->{'.generalization'}} = ();
  };
  if ( $@ ) {
    die("While adding Generalizations: \n$@");
  }
  $self->flush('Generalization');

  
  # Add Attributes to Classifiers.
  eval {
    for my $x ( @{$self->{'.attribute'}} ) {
      $self->finish_Attribute($x);
    }
    @{$self->{'.attribute'}} = ();
  };
  if ( $@ ) {
    die("While adding Attributes: \n$@");
  }
  $self->flush('Attribute');
  

  # Add Associations to Classifiers.
  eval {      
    for my $assoc ( @{$self->{'.association'}} ) {
      # $DB::single = 1;
      $self->finish_Association($assoc);
    }
    @{$self->{'.association'}} = ();
  };
  if ( $@ ) {
    die("While adding Associations: \n$@");
  }
  $self->flush('Association');


  $self->flush('Model');


  $model;
}


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

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

  # $DB::single = 1;

  eval {
    my @all;
    for my $ns ( @ns ) {
      my @name = split('::', $ns);

      # print STDERR "$x->[0]{name} <=== $ns\n";
      # $DB::single = 1;

      # Was it a wildcarded Usage?
      if ( $name[-1] eq '*' ) {
	# Get the Package.
	pop @name;
	my $name = join('::', @name);
	$ns = $self->ownedElement_name_($name);

	# Import everything from that package.
	push(@all, $ns->ownedElement);
      } else {
	# Get the item.
	$ns = $self->ownedElement_name_($ns);

	# Import only the item.
	push(@all, $ns);
      }
    }
    
    confess("importedElement is not ref") if grep(! ref($_), @all);
    
    $x->[0]->add_importedElement(@all);
  };
  if ( $@ ) {
    die("To " . ModelElement_name_qualified($x->[0]) . ":\n$@");
  }

  $self;
}


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

  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);    
  };
  if ( $@ ) {
    $cls = $cls->{'name'};
    die("in Classifier $cls: \n$@");
  }


  $self;  
}


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

  my $attr;

  eval {
    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->{'owner'}->{'namespace'});
    
    $attr = $self->create('Attribute', %$x);
  };
  if ( $@ ) {
    my $n = $x->{'owner'}{'name'};
    die("  to Classifier $n:\n$@");
  }

  $attr;
}


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

  # $DB::single = 1;

  # If the namespace of the AssociationEnd is a Classifier 
  # (which it most likely is)
  # defer participant lookup to the Classifier's namespace
  # (usu. a Package)
  #
  my $ns = $x->{'namespace'};
  delete $x->{'namespace'};
  while ( $ns->isaClassifier ) {
    $ns = $ns->{'namespace'};
  }

  # Resolve AssociationEnd participants
  for my $end ( @{$x->{'connection'}} ) {
    eval {
      $self->lookupType(\$end->{'participant'}, $ns);
    };
    if ( $@ ) {
      print "ns = $ns\n";
      die($@);
    }
  }

  my $assoc = $x->{'associationClass'};
  delete $x->{'associationClass'};

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

    # Turn parsed multiplicity string into a Multiplicity object.
    Multiplicity_fromString(\$end->{'multiplicity'}, $self);
    confess("multiplicity is not ref") unless ref($end->{'multiplicity'});

    # Default to navigable.
    $end->{'isNavigable'} = 'true'
    unless defined $end->{'isNavigable'};

    #$DB::single = 1;
    # Create actual AssociationEnd object.
    $end = $self->create('AssociationEnd',
			 '_association' => $assoc,
			 %$end,
			 );

    # If the Association is a AssociationClass,
    # the Ends were added to the AssocationClass,
    # beacuse '_assocation' was specified.
  }

  # Otherwise, create a new Association object.
  if ( ! $assoc ) {
    # $DB::single = 1 if grep($_->{'name'} eq 'range', @{$x->{'connection'}});
    $assoc = $self->create('Association', %$x);
  }

  # $DB::single = 1 if grep(! $_->{'connection_'}, $assoc->connection);

  $assoc;
}


#######################################################################
# Support 
#
# Glued to UML::MetaMetaModel::Util 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);
}


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


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: ###

