package UML::XForm::AssocClassLinks;

use 5.6.1;
use strict;
use warnings;

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

=head1 NAME

UML::XForm::AssocClassLinks - Create Assoociations for each AssociationEnd of each AssociationClass.

=head1 SYNOPSIS

  use UML::XForm::AssocClassLinks;

  my $xform = UML::XForm::AssocClassLinks->new();
  $model = $xform->apply_Model($model);

=head1 DESCRIPTION

This UML transform greatly simplifes and standardizes code generation for AssociationClasses.

=head1 USAGE

=head1 PATTERNS

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

L<UML::MetaMetaModel|UML::MetaMetaModel>

=head1 VERSION

$Revision: 1.1 $

=head1 METHODS

=cut

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

use base qw(UML::XForm);

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

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

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

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

  $self->SUPER::initialize;

  $self->{'assoc_name_template'} ||= '%s_AC';

  $self;
}


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

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


    #  __________                                 __________
    # |  XClass  |                               |  YClass  |
    # |__________|                               |__________|
    # |          |                               |          |
    # |__________|---x-----------------------y---|__________|
    #      |                   |                    |
    #      x                   .                    y
    #      |                   |                    |
    #      |                   .                    |
    #      |                   |                    |
    #      |        __________________              |
    #      |       | AssocClass       |             |
    #      x_Assoc-|__________________|-y_Assoc-----+
    #              |                  |
    #              |__________________|
    #
    # The x_Assoc and y_Assoc AssociationEnds are generated.
    #

  print STDERR "* Pass 1:\n" if $self->{'verbose'} > 0;
  my $factory = $model->__factory;

  for my $cls ( Namespace_ownedElement_match($model, 'isaAssociationClass', 1) ) {
    for my $end ( $cls->connection ) {
      my $assoc = AssociationEnd_association($end);

      my $end_x = $factory
      ->create('AssociationEnd',
	       'name' => $end->name,

	       'isNavigable' => 'true',
	       'ordering' => 'unordered',
	       'aggregation' => 'none',
	       'targetScope' => $end->targetScope,
	       'multiplicity' => Multiplicity_fromString('1', $factory),
	       'changeablity' => 'changeable',
	       
	       'participant' => $end->participant,
 
	       '_trace' => $cls,
	       );

      my $name = join(
		      grep(length,
			   $assoc->name, $end->name, $cls->name,
			   )
		      );

      my $end_a = $factory
      ->create('AssociationEnd',
	       'name' => $name,

	       'isNavigable' => 'true',
	       'ordering' => 'unordered',
	       'aggregation' => 'none',
	       'targetScope' => $end->targetScope,
	       'multiplicity' => Multiplicity_fromString('1', $factory),
	       'changeablity' => 'changeable',
	       
	       'participant' => $cls,
 
	       
	       '_trace' => $cls,
	       );

      # Create an Association.
      my $ac_assoc = $factory
      ->create('Association',
	       'name' => sprintf($self->{'assoc_name_template'}, $name),
	       
	       'connection' => [ $end_x, $end_a ],
	       
	       '_trace' => $cls,
	       );
    }
  }

  $model;
}


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

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

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

  print STDERR "* Pass 4:\n" if $self->{'verbose'} > 0; 
  # Replace all Class type usages with Interfaces.
  for my $cls ( Namespace_classifier($model) ) {
    for my $attr ( Classifier_attribute($cls) ) {
      my $t = $attr->type;
      $t = $iface->{$t} || $t;
      if ( $attr->type ne $t ) {
	print STDERR "  Changing ", $cls->name, " Attribute '", $attr->name, "' type from ", $attr->type->name, " to ", $t->name, "\n" if $self->{'verbose'} > 0;
	# $DB::single = 1;
	$attr->set_type($t);
      }
    }
    for my $op ( Classifier_operation($cls) ) {
      for my $param ( $op->parameter ) {
	$param->set_type($iface->{$op->type} || $op->type);
      }
    }
  }

  $model;
}

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


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

