package UML::MetaMetaModel;

use 5.6.1;
use strict;
#use warnings; # no warnings, too much hassle to make them go away.


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

=head1 NAME

UML::MetaMetaModel - An implementation of the UML Meta-Meta-Model (M3).

=head1 SYNOPSIS

  use UML::MetaMetaModel;
  my $factory = UML::MetaMetaModel->factory;
  my $model = $factory->create('Model');
  $factory->create('Class', 'name' => 'Foo', 'namespace' => $model);
  ...

=head1 DESCRIPTION

This package implements a meta-meta-model for generating the UML metamodel.

It is actually a subset of the 1.5 Meta-model, as described in UML Spec. 1.5.,
p.2-13.  It is the "Backbone" for generating the meta-model.

The UML 1.5 Meta-model is described in UML::MetaModel package, in the ad-hoc language
imported by UML::Import::MetaMetaModel.

This meta-model is then used to generate the Perl (or Java) code for the classes in
UML::MetaModel::*.

The same exporters can be used to process UML models.

Thus, one description of the meta-model can generate multiple implementations.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

L<UML::MetaModel|UML::MetaModel>

=head1 VERSION

$Revision: 1.6 $

=head1 METHODS

=cut

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

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

####################################################################################
# Support for UML::MetaMetaModel::Factory
#

   # These are only the instantiable classes.
my @factory_class =
qw(
   Foundation::Model_Management::Model
   Foundation::Model_Management::Package
   Foundation::Core::Class
   Foundation::Core::Attribute
   Foundation::Core::Generalization
   Foundation::Core::Association
   Foundation::Core::AssociationEnd
   Foundation::Core::AssociationClass
   Foundation::Core::Enumeration
   Foundation::Core::EnumerationLiteral
   Foundation::Data_Types::Multiplicity
   Foundation::Data_Types::MultiplicityRange
   );

my @factory_map;
sub factory_map
{
  unless ( @factory_map ) {
    for my $x ( @factory_class ) {
      local $1;
      $x =~ m/([^:]+)$/;
      my $name = $1;
      my $cls = __PACKAGE__ . '::' . $name;

      push(@factory_map, 
	   $name => $cls,
	   $x => $cls,
	   );
      
    }
  }

  #local $" = ', '; print STDERR "@factory_map\n";

  \@factory_map;
}


####################################################################################
# Ok, here's a bit of trickery.
# We want the meta-meta-model to reflect on itself, mostly to support
# generating a XMI representation of the meta-model.
#
# When an meta-meta-model object is asked for its Class, it diverts to the
# meta-model's meta-data.  This works because the meta-model is a superset of
# the meta-meta-model.
#
my $model;
sub model {
  unless ( $model ) {
    $model = eval q{
      use UML::MetaModel;
      UML::MetaModel->model;
    }; 
    die $@ if $@;
  }
  $model;
}


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

  unless ( $factory ) {
    # $DB::single = 1;
    use UML::MetaMetaModel::Factory;
    $factory = UML::MetaMetaModel::Factory->new('classMap' => $self->factory_map);
  }

  $factory;
}


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

package UML::MetaMetaModel::Element;
use base qw(UML::MetaMetaModel::Object);
__PACKAGE__->__define_class;


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

package UML::MetaMetaModel::ModelElement;
use base qw(UML::MetaMetaModel::Element);
__PACKAGE__->__define_class;


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

  "$self('name_qualified'=>'" . $self->name_qualified . "')";
}


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

  my $name = $self->{'name'};
  if ( length $name ) {
    die("Invalid ModelElement name '$name'") unless $name =~ /^[a-z_][a-z_0-9]*$/i;
  }

  $self->SUPER::initialize;
}


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

  use Carp qw(confess);

  # Cannot rename.
  confess("$self already named") if ( $self->{'name'} );

  # Cannot be qualified name.
  confess("Name '$name' is qualified") if $name =~ /::/;

  # Must be reasonable.
  if ( length($name) ) {
    confess("Name '$name' is invalid") unless $name =~ /^[a-z_][a-z_0-9]+$/i;
  }

  if ( $self->{'name'} ne $name ) { # Recursion lock
    my $old = $self->{'name'};
    $self->{'name'} = $name; # Recursion lock

    # Force name collision check.
    my $ns = $self->{'namespace'};
    if ( $ns ) {
      my $x;
      if ( ($x = (grep($_->name eq $name, $ns->ownedElement))[0]) 
	   && $x ne $self ) {
	confess("Namespace already has element '$x' named '$name'");
      }
    }
  }

  $self;
}


sub __self_name
{
  my ($self) = @_;
  
  my $x = "$self";

  local $1;
  $x =~ /[(](.*)[)]/;

  '_' . $1;
}


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

  join('::', grep(length, 
		  $self->{'namespace'} && $self->{'namespace'}->name_qualified, 
		  $self->{'name'} # || $self->__self_name
		  )
       );
}

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

package UML::MetaMetaModel::Namespace;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


__PACKAGE__->__one_to_many('namespace', 'UML::MetaMetaModel::ModelElement', 'ownedElement');

sub ownedElement_name
{
  my ($self, $name) = @_;
      
  my $q = $self->{'ownedElement'} ||= [ ];
  
  (grep($_->name eq $name, @$q))[0];
}


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


package UML::MetaMetaModel::Package;
use base qw(UML::MetaMetaModel::Namespace);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_many('', 'UML::MetaMetaModel::ModelElement', 'importedElement');

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


package UML::MetaMetaModel::Model;
use base qw(UML::MetaMetaModel::Package);
__PACKAGE__->__define_class;



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


package UML::MetaMetaModel::GeneralizableElement;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


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


package UML::MetaMetaModel::Relationship;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


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


package UML::MetaMetaModel::Generalization;
use base qw(UML::MetaMetaModel::Relationship);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_one('generalization', 
			   'UML::MetaMetaModel::GeneralizableElement', 'child');
__PACKAGE__->__many_to_one('specialization', 
			   'UML::MetaMetaModel::GeneralizableElement', 'parent');


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


package UML::MetaMetaModel::Classifier;
use base qw(UML::MetaMetaModel::Namespace UML::MetaMetaModel::GeneralizableElement);
__PACKAGE__->__define_class;

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

package UML::MetaMetaModel::Class;
use base qw(UML::MetaMetaModel::Classifier);
__PACKAGE__->__define_class;


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


package UML::MetaMetaModel::Feature;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_one('feature',
			   'UML::MetaMetaModel::Classifier', 'owner'
			   );


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

  join('.',
       grep(length,
	    $self->{'owner'} && $self->{'owner'}->name_qualified,
	    $self->{'name'}
	    )
       );
}


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


package UML::MetaMetaModel::StructuralFeature;
use base qw(UML::MetaMetaModel::Feature);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_one('typedFeature',
			   'UML::MetaMetaModel::Classifier', 'type'
			   );


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


package UML::MetaMetaModel::Attribute;
use base qw(UML::MetaMetaModel::StructuralFeature);
__PACKAGE__->__define_class;


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

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

  # IMPLEMENT: Is this a UML 1.5 constraint??
  $self->{'namespace'} = $self->owner;

  # $DB::single = 1 unless defined $self->{'multiplicity'};
  # $DB::single = 1 unless defined $self->{'multiplicity'};
  $self->{'multiplicity'} ||= 1;
  Multiplicity_fromString(\$self->{'multiplicity'}, UML::MetaMetaModel->factory);

  die("Invalid type: $self->{type}") unless $self->{'type'};
  die("Invalid name: $self->{name}") unless $self->{'name'} =~ /^[A-Za-z0-9_]+$/;

  # $DB::single = 1;
  $self->SUPER::initialize;
}


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


package UML::MetaMetaModel::Association;
use base qw(UML::MetaMetaModel::GeneralizableElement UML::MetaMetaModel::Relationship);
__PACKAGE__->__define_class;


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

  my @x = grep($_ ne $x, $self->connection);

  wantarray ? @x : \@x;
}


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

package UML::MetaMetaModel::AssociationClass;
use base qw(UML::MetaMetaModel::Association UML::MetaMetaModel::Class);
__PACKAGE__->__define_class;


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


package UML::MetaMetaModel::AssociationEnd;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


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

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

  # IMPLEMENT: Is this a UML 1.5 constraint??
  $self->{'namespace'} ||= $self->participant->namespace;

  # $DB::single = 1 unless defined $self->{'multiplicity'};
  $self->{'multiplicity'} ||= 1;
  Multiplicity_fromString(\$self->{'multiplicity'}, UML::MetaMetaModel->factory);

  $self->SUPER::initialize;
}

__PACKAGE__->__many_to_one('association',
			   'UML::MetaMetaModel::Classifier', 'participant',
			   );

__PACKAGE__->__many_to_many('specifiedEnd',
			   'UML::MetaMetaModel::Classifier', 'specificiation',
			   );

__PACKAGE__->__many_to_one('connection',
			   'UML::MetaMetaModel::Association', '', # unnamed ???
			   );


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


package UML::MetaMetaModel::DataType;
use base qw(UML::MetaMetaModel::Classifier);
__PACKAGE__->__define_class;


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

package UML::MetaMetaModel::Enumeration;
use base qw(UML::MetaMetaModel::DataType);
__PACKAGE__->__define_class;


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


package UML::MetaMetaModel::EnumerationLiteral;
use base qw(UML::MetaMetaModel::ModelElement);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_one('literal',
			   'UML::MetaMetaModel::Enumeration', 'enumeration'
			   );

sub toString
{
  shift->{'name'};
}


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

  join('.',
       grep(length,
	    $self->{'enumeration'} && $self->{'enumeration'}->name_qualified,
	    $self->{'name'}
	    )
       );
}


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


package UML::MetaMetaModel::Multiplicity;
use base qw(UML::MetaMetaModel::Object);
__PACKAGE__->__define_class;



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


package UML::MetaMetaModel::MultiplicityRange;
use base qw(UML::MetaMetaModel::Object);
__PACKAGE__->__define_class;


__PACKAGE__->__many_to_one('range',
			   'UML::MetaMetaModel::Multiplicity', '', # Unnamed?
			   );


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

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

