package UML::XMI;

use 5.6.1;
use strict;

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

=head1 NAME

UML::XMI - A framework for processing UML XMI documents.

=head1 SYNOPSIS

  use base qw(UML::XMI);

=head1 DESCRIPTION

This package allow XMI documents (XML standard for interchange of UML systems) to be processed.

XMI nodes are subclasses of L<XML::DOM|XML::DOM> nodes.

=head1 USAGE

=head1 PATTERNS

=over 4

=item * a design pattern


=back

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

L<XML::DOM|XML::DOM>

=head1 VERSION

$Revision: 1.5 $

=head1 METHODS

=cut

=head2 new

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

  $self = bless(\%opts, $self);

  $self->prepare_xml_dom($self->{'xml'});
}


=head2 prepare_xml_dom

  my $parser = new XML::DOM::Parser;
  my $doc = $parser->parseFile($xml_file);
  my $xmi = prepare_xml_dom($doc);

Prepares an XML::DOM::Document object as an UML::XMI::Document.

=cut
sub prepare_xml_dom
{
  my ($self, $doc) = @_;
  
  # $DB::single = 1;

  $doc = bless($doc, 'UML::XMI::Document');
  
  my $root = $doc->getDocumentElement;

  # Verify that XMI document is version 1.0.
  my $xmi_version = $root->getAttribute('xmi.version');
  die("Error: XMI version = \"$xmi_version\": expected XMI version 1.0");

  # Keep a reference back to the UML::XMI object.
  $doc->set_xmi_data('xmi' => $self);

  # Normalize the document.
  $root->normalize;

  # Remove unnessary whitespace text.
  $self->remove_whitespace_text($root);

  # Rebless XML::DOM nodes as UML::XMI objects.
  $self->rebless_xml_as_xmi($root);

  # Generate map for 'xmi.idref' value => node.
  my $id_map = { };
  my $id_last;
  $doc->set_xmi_data('id_map' => $id_map);
  $self->gen_id_map($root, $id_map, \$id_last);
  $doc->set_xmi_data('id_last' => $id_last);

  # Generate attributes for assocation ends.
  $self->xmi_generate_association_attribute($doc);
  
  # Return the XML document as an XMI document.
  $doc;
}


sub remove_whitespace_text
{
  my $self = shift;

  for my $node ( @_ ) {
    if ( $node->isTextNode ) {
      my $x = $node->toString;
      my $y = UML::XMI::xmi_trimws($x);
      
      my $ps = $node->getPreviousSibling;
      my $ns = $node->getNextSibling;
      
      if ( 0 ) {
	no warnings;
	print STDERR $ps, '<', $node, '>', $ns, "\n";
      }
      
      if ( $ps || $ns ) {
	unless ( length($y) ) {
	  print STDERR "removed '$x' => '$y'\n" if ( 0 );
	  $node->getParentNode->removeChild($node);
	  $node->dispose;
	  next;
	}
      }
      elsif ( $x ne $y ) {
	print STDERR "replaced '$x' => '$y'\n" if ( 0 );
	$node->setData($y);
      }
    } else {
      $self->remove_whitespace_text($node->getChildNodes);
    }
  }
}


my %node_name_2_xmi_cls =
map((('UML::XMI::' . $_)->xmi_xml_tag, $_),
    'Model',
    'Package',
    'Namespace',
    'DataType',
    'Interface',
    'Class',
    'Attribute',
    'Operation',
    'Parameter',
    'Dependency',
      'Usage',
      'Binding',
      'Permission',
    'Association',
    'AssociationEnd',
    'Generalization',
    'Abstraction',
    'Multiplicity',
    'MultiplicityRange',
    'Stereotype',
    'Comment',
    'Expression',
    );

sub rebless_xml_as_xmi
{
  my $self = shift;

  for my $node ( @_ ) {
    my $node_name = $node->getNodeName;
    #print STDERR "$node => $node_name\n";
    #$DB::single = 1;
    if ( $node_name ne '#text' ) {
      my $xmi_cls = $node_name_2_xmi_cls{$node_name} || 'Element';
      $xmi_cls = 'UML::XMI::' . $xmi_cls;
      # print STDERR "$node_name => $xmi_cls \n";

      bless($node, $xmi_cls);
      $self->rebless_xml_as_xmi($node->getChildNodes);
    }
  }
}


sub gen_id_map
{
  my $self = shift;
  my $id_last = pop;
  my $id_map = pop;
  for my $node ( @_ ) {
    if ( my $id = $node->getAttribute('xmi.id') ) {
      $id_map->{$id} = $node;
      $$id_last = $id;
    }
    $self->gen_id_map($node->getChildNodes, $id_map, $id_last);
  }
}


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

=head2 xmi_generate_association_end_attribute

C<$cls> is the Classifer attached to C<$cls_end>
C<$cls_end> is the AssociationEnd attached to C<$cls>, defaults if not specified.
C<$assoc> is the Assocation of the C<$cls_end>, defaults if not specified.

=cut
sub xmi_generate_association_end_attribute
{
  my ($self, $cls_end, $cls, $assoc) = @_;

  $assoc ||= $cls_end->xmi_association;
  $cls ||= $cls_end->xmi_type;

  my $assoc_name = $assoc->xmi_name;

  return unless $assoc->xmi_taggedValue_inherited_true('uml2code');

  print STDERR "$assoc_name\n";

  # an association may have more than 2 ends.
  for my $end ( $cls_end->xmi_opposite ) {

    # $DB::single = 1;

    # Don't do it if it's not enabled.
    next unless $end->xmi_taggedValue_inherited_true('uml2code');
    next unless $end->xmi_taggedValue_inherited_true('uml2code.generate.association.attribute');

    # Don't do it if it's not navigable.
    next unless $end->xmi_isNavigable;

    # Generate an list of preferred attribute names.
    my $attr_name = $end->xmi_taggedValue_trace('uml2code.generate.association.attribute.name');

    # Generate an list of preferred attribute names.
    my @attr_name;
    push(@attr_name, $attr_name) if $attr_name;

    my $end_name = $end->xmi_name;

    my @name_prefs = split(/\s+|\s*,\s*/, $end->xmi_taggedValue_inherited('uml2code.generate.association.attribute.name.pref'));

    if ( grep(/assoc/, @name_prefs) && grep(/end/, @name_prefs) && $assoc_name && $end_name ) {
      push(@attr_name, join('', $assoc_name, ucfirst($end_name)))
    }
    elsif ( grep(/assoc/, @name_prefs) && $assoc_name && ! $end_name ) {
      push(@attr_name, $assoc_name)
    }
    else {
      push(@attr_name, $end_name);
    }

    $attr_name = $attr_name[0];

    if ( ! $attr_name ) {
      print STDERR "Error: Cannot determine attribute name for association\n";
      die(1);
    }

    # IMPLEMENT: check for name collisions.

    # Construct a new attribute representing the assocation end for $cls.
    my $attr = UML::XMI::Attribute->xmi_new
    (
     '.'                  => $end,
     'name'               => $attr_name,
     'visibility'         => $end->xmi_visibility,
     'isSpecification'    => $end->xmi_isSpecification,
     'ownerScope'         => $end->xmi_targetScope,
     'multiplicity'       => $end->xmi_multiplicity,
     'changeability'      => 'changeable',
     'targetScope'        => $end->xmi_targetScope,
     'initialValue_hash'  => { },
     'type'               => $end->xmi_type,
     'owner'              => $cls,
     );
    
    # Add a trace to the AssociationEnd that generated this attribute.
    $attr->xmi_set_taggedValue('uml2code.generated.trace' => $end->xmi_id);
    
    $cls->xmi_add_attribute($attr);
  }

  $self;
}


sub xmi_generate_association_attribute
{
  my ($self, $doc) = @_;

  my $model = $doc->xmi_model;

  for my $cls ( $model->xmi_classes ) {
    for my $end ( $cls->xmi_association_ends_attached_to ) {
      $self->xmi_generate_association_end_attribute($end, $cls);
    }
  }

  $self;
}


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

sub xmi_trimws
{
  my ($x) = @_;
  
  no warnings;
  
  $x =~ s/^[\s\n]+//s;
  $x =~ s/[\s\n]+$//s;
  
  $x;
}


sub xmi_true
{
  my ($x) = @_;
  
  $x = xmi_trimws($x);
  
  no warnings;
  $x ne '' && $x ne 'false' && $x ne 'no' && $x ne '0';
}


sub xmi_toString
{
  my ($node) = @_;
  
  # $node ? $node->toString : ''; # toString returns escaped XML entities like &quote;
  $node ? $node->getData : '';
}


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

package UML::XMI::Document;

use base qw(XML::DOM::Document);


my %xmi;

sub set_xmi_data
{
  my ($node, $name, $val) = @_;

  ($xmi{$node} ||= { })->{$name} = $val;
}

sub xmi_data
{
  my ($node, $name) = @_;

  ($xmi{$node} ||= { })->{$name};
}


sub DESTROY
{
  delete $xmi{shift};
}


sub xmi_doc { shift; }


sub xmi_model
{
  my ($doc) = @_;

  $doc->getDocumentElement->getTagged('XMI.content')->getTagged('Model_Management.Model');
}


sub xmi_idref_resolve
{
  my ($self, $idref) = @_;

  $self->xmi_data('id_map')->{$idref};
}


sub xmi_id_alloc
{
  my ($self, $node) = @_;

  my $id = $self->xmi_data('id_last');
  my $id_map = $self->xmi_data('id_map');

  do {
    ++ $id;
  } while ( $id_map->{$id} );

  $node->xmi_set_id($id);
  $id_map->{$id} = $node;

  $self->set_xmi_data('id_last' => $id);

  $id;
}


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


package XML::DOM::NodeList;

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

    my @list;
    for ( my $i = 0; $i < $self->getLength; ++ $i ) {
	push(@list, $self->item($i));
    }

    wantarray ? @list : \@list;
}


sub getElementsByTagName
{
    my ($self, $tag, $recur, $list) = @_;
    
    my @list;
    for my $node ( $self->toArray ) {
	if ( $tag eq '*' || $tag eq $node->getNodeName ) {
	    push(@list, $node);
	}
    }

    wantarray ? @list : \@list;
}


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


package XML::DOM::Text;

sub getAttribute
{
    undef;
}


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


package UML::XMI::Element;

use base qw(XML::DOM::Element);


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

use vars qw($AUTOLOAD);
use Carp qw(confess);

sub AUTOLOAD
{
    no strict 'refs';

    my ($self, @args) = @_;
    local ($1, $2);
    
    my ($package, $method) = $AUTOLOAD =~ m/^(?:(.+)::)([^:]+)$/;
    return if $method eq 'DESTROY';

    my $xml_name = $self->can('getNodeName') ? $self->getNodeName : '<unknown>';
    confess("Undefined method '$method' for $self node named '$xml_name'");
}


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


my %xmi;

sub set_xmi_data
{
  my ($node, $name, $val) = @_;

  ($xmi{$node} ||= { })->{$name} = $val;
}

sub xmi_data
{
  my ($node, $name) = @_;

  ($xmi{$node} ||= { })->{$name};
}


sub DESTROY
{
  delete $xmi{shift};
}


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

  delete $xmi{$self};
  $self->XML::DOM::Element::dispose;
}


sub xmi_doc
{
  my ($node) = @_;

  $node->getOwnerDocument;
}


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


sub xmi_new
{
  my ($cls, %opts) = @_;

  # $DB::single = 1;

  my $self = bless(\%opts, $cls);

  my $doc = $self->{'.'} || die("Must specify document context as '.'");
  delete $self->{'.'};
  $doc = $doc->xmi_doc;

  my $elem = $doc->createElement($cls->xmi_xml_tag);
  
  bless($elem, $cls);

  $elem->xmi_initialize($self);

  # Rebless all the subelements.
  $doc->xmi_data('xmi')->rebless_xml_as_xmi($elem);

  $elem;
}


sub xmi_initialize
{
  my ($self, $data) = @_;

  # $DB::single = 1;

  for my $key ( keys %$data ) {
    die("Bad key") unless $key;
    my $val = $data->{$key};
    my $meth = 'xmi_set_' . $key;
    # print STDERR "$self -> $meth ( $val )\n";
    # $DB::single = 1;
    $self->$meth($val);
  }

  $self;
}


######################################################################################
# Fixes problems when Attribute doesn't already exist


sub setAttribute
{
  my ($node, $name, $value) = @_;

  # $DB::single = 1;
  my $attr = $node->getOwnerDocument->createAttribute($name, $value, 1);
  $node->setAttributeNode($attr);

  #$node->XML::DOM::Element::setAttribute($name, $value);
}


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

sub getTagged
{
  my ($node, $tag, $recur) = @_;
  
  $recur = 0 unless defined $recur;
  
  # $DB::single = 1;
  
  my $x = ref($node) ? $node->xmi_idref_resolve->getElementsByTagName($tag, $recur) : undef;

  # print STDERR "$node/$tag => $x\n";
  
  $x ? $x->item(0) : undef;
}


sub createTagged
{
  my ($node, $tag) = @_;

  my $x = $node->getTagged($tag);

  unless ( $x ) {
    my $doc = $node->xmi_doc;
    $x = $doc->createElement($tag);
    $node->appendChild($x);
  }

  $x;
}

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


sub getTagged1
{
  my ($node, $tag, $recur) = @_;
  
  $node = getTagged($node, $tag, $recur);
  $node ? $node->getFirstChild : undef;
}

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

sub getTagged1Str
{
  my ($node, $tag) = @_;

  UML::XMI::xmi_toString($node->getTagged1($tag));
}


sub setTagged1Str
{
  my ($node, $tag, $value) = @_;

  # $DB::single = 1;

  my $x = $node->createTagged($tag);
  my $y = $x->getFirstChild;

  if ( $y ) {
    $y->setData($value);
  } else {
    $x->appendChild($y = $node->xmi_doc->createTextNode($value));
  }
}


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

sub getTaggedValue
{
  my ($node, $tag) = @_;
  $node = $node->getTagged($tag);
  xmi_value($node);
}


sub setTaggedValue
{
  my ($node, $tag, $value) = @_;
  my $x = $node->createTagged($tag);
  xmi_set_value($x, $value);
}

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

sub getTaggedTrue
{
  my ($node, $tag) = @_;

  UML::XMI::xmi_true($node->getTaggedValue($tag));
}


sub setTaggedTrue
{
  my ($node, $tag, $value) = @_;

  $value = UML::XMI::xmi_true($value) ? 'true' : 'false';

  $node->setTaggedValue($tag => $value);
}

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

sub getTagged1IdRef
{
  my ($node, $tag) = @_;
  $node = $node->getTagged1($tag);
  xmi_idref_resolve($node);
}


sub setTagged1IdRef
{
  my ($node, $tag, $value) = @_;

  $node->setTaggedChildIdRef($tag, $value);
}


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

sub getTaggedChildIdRef
{
  my ($node, $tag) = @_;

  $node = $node->getTagged($tag);

  # $DB::single = 1;
  
  my @gens = $node ? $node->getChildNodes() : ();
  
  @gens = map(xmi_idref_resolve($_), @gens);
  
  wantarray ? @gens : \@gens;
}


sub addTaggedChildIdRef
{
  my ($node, $tag, @elem) = @_;

  $node = $node->createTagged($tag);

  for my $elem ( @elem ) {
    my $e = $elem;
    # $DB::single = 1;
    my $id;
    if ( $id = $e->xmi_id ) {
      $e = $e->xmi_doc->createElement($e->getNodeName);
      $e->setAttribute('xmi.idref' => $id);
    } else {
      $e->xmi_id_alloc;
    }
    $node->appendChild($e);
  }

  $node;
}


sub setTaggedChildIdRef
{
  my ($node, $tag, @elem) = @_;

  my $tnode = $node->createTagged($tag);
  for my $child ( $tnode->getChildNodes ) {
    $tnode->removeChild($child);
    $child->dispose;
  }
  $node->addTaggedChildIdRef($tag, @elem);
}


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


sub make_accessors
{
  my ($package, $locative, $xml_tag, $param) = @_;

  $xml_tag = join('.', $package->xmi_xml_tag, $xml_tag)
  unless $xml_tag =~ /\./;

  unless ( $param ) {
    $xml_tag =~ /\.([^.]+)$/;
    $param = $1;
  }

  my $code = qq{
    package $package;
    sub xmi_$param {
      my (\$node) = \@_;
      \$node -> get$locative('$xml_tag');
    }
    sub xmi_set_$param {
      my (\$node, \$value) = \@_;
      \$node -> set$locative('$xml_tag' => \$value);
    }
  };

  if ( $locative eq 'TaggedChildIdRef' ) {
    $code .= qq{
    sub xmi_add_$param {
      my (\$node, \@value) = \@_;
      \$node -> add$locative('$xml_tag' => \@value);
    }
    sub xmi_remove_$param {
      my (\$node, \@value) = \@_;
      \$node -> remove$locative('$xml_tag' => \@value);
    }
    };

  }


  # print STDERR "make_accessors: code=$code\n";
  eval $code; die $@ if $@;
}


sub _param
{
  my $package = shift || (caller)[0];
  while ( @_ ) {
    my $x = shift @_;
    unless ( ref($x) ) {
      $x = [ $x, shift @_ ];
    }
    $package->make_accessors(@$x);
  }
}


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


__PACKAGE__->_param
(
 'Attribute', 'xmi.id', 
 'Attribute', 'xmi.idref', 
 'Attribute', 'xmi.value',
 );


sub xmi_idref_resolve
{
  my ($node) = @_;
  
  my $idref;
  
  ref($node) ? 
  (
   ($idref = $node->xmi_idref) ?
   ($node->xmi_doc->xmi_idref_resolve($idref) 
    || die("Cannot resolve idref for " . $node->toString)
    )
   : $node
   )
  : $node;
}


sub xmi_id_alloc
{
  my ($node) = @_;

  my $id;
  unless ( $id = $node->xmi_idref ) {
    $id = $node->xmi_doc->xmi_id_alloc($node);
  }

  $id;
}


####################################################################################
# tagged value support.
#


sub xmi_taggedValue_inheritedParent # Ad-hoc name
{
  my ($node) = @_;

  $node->getParentNode->getParentNode;
}


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

package UML::XMI::ModelElement;

use base qw(UML::XMI::Element);


sub xmi_xml_tag { 'Foundation.Core.ModelElement' }


__PACKAGE__->_param
(
 'Tagged1Str',  'name',
 'TaggedValue', 'visibility', 
 'TaggedTrue',  'isSpecification',
 );


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

  $name ||= $self->xmi_name;
  $name ||= '<' . $self->xmi_id . '>';
  $name ||= '<' . "$self" . '>';

  $name;
}


sub xmi_name_q # Ad-hoc name
{
  my ($self, $name) = @_;

  $name ||= $self->xmi_name_s;
  join("::", ($self->xmi_namespace_q)[1..-1], $name);
}


####################################################################################
# Foundation.Core.ModelElement.taggedValue support

sub _xmi_taggedValues # Ad-hoc name
{
  my ($node) = @_;
  
  $node = $node->xmi_idref_resolve;
  
  # $DB::single = 1;
  
  $node = $node->getTagged('Foundation.Core.ModelElement.taggedValue', 0);
  
  my @tagvalues = $node ? $node->getElementsByTagName('Foundation.Extension_Mechanisms.TaggedValue', 0) : ();
  
  #$DB::single = 1;
  
  @tagvalues = 
  map(
      (
       $_->getTagged1Str('Foundation.Extension_Mechanisms.TaggedValue.tag'),
       $_->getTagged1Str('Foundation.Extension_Mechanisms.TaggedValue.value'),
       ),
      
      @tagvalues
      );
  
  if ( 0 ) {
    print STDERR join(' ', $_[0]->getNodeName, $_[0]->xmi_id,
		      map($_->[0] . ' => ' . $_->[1], @tagvalues)
		      ), "\n";
  }
  
  wantarray ? @tagvalues : { @tagvalues };
}


sub xmi_taggedValues # Ad-hoc name
{
  my ($node) = @_;
  
  my $x;
  unless ( $x = $node->xmi_data('taggedValues') ) {
    $x = $node->_xmi_taggedValues;
    $node->set_xmi_data('taggedValues' => $x);
  }
  
  wantarray ? %$x : $x;
}


sub xmi_taggedValue
{
  my ($node, $tag, $default) = @_;
   
  $node = $node->xmi_taggedValues;

  exists $node->{$tag} ? $node->{$tag} : $default;
}


sub xmi_taggedValue_trace
{
  my ($node, $tag, $default) = @_;
   
  my $tv = $node->xmi_taggedValues;
  if ( exists $tv->{$tag} ) {
    $default = $tv->{$tag};
  }
  elsif ( my $trace = $node->xmi_generated_trace ) {
    $default = $trace->xmi_taggedValue_trace($tag, $default);
  }

  $default;
}


sub xmi_set_taggedValue
{
  my ($node, $tag, $value) = @_;

  $node->xmi_taggedValues->{$tag} = $value;
}


sub xmi_taggedValue_inherited # Ad-hoc name
{
  my ($node, $tag, $default) = @_;
  
  while ( $node && $node->getNodeName ne 'XMI' ) {
    # print STDERR "$node => ", $node->getNodeName, "\n";
    
    my $value = $node->xmi_taggedValue_trace($tag);
    if ( defined($value) ) {
      $default = $value;
      last;
    }
    $node = $node->xmi_taggedValue_inheritedParent;
  }
  
  if ( 0 ) {
    print STDERR join(' ', 'TVI', $_[0]->getNodeName, $_[0]->xmi_id, 
		      $tag, '=>', $default, 
		      $node ? ( '(', $node->getNodeName, $node->xmi_id, ')' ) : (),
		      ), "\n";
  }
  
  $default;
}


sub xmi_taggedValue_true # Ad-hoc name
{
  my ($node, $tag, $default) = @_;
  
  my $value = $node->xmi_taggedValue_trace($tag, $default);
  
  UML::XMI::xmi_true($value);
}


sub xmi_taggedValue_inherited_true # Ad-hoc name
{
  my ($node, $tag, $default) = @_;
  
  my $value = $node->xmi_taggedValue_inherited($tag, $default);
  
  UML::XMI::xmi_true($value);
}


sub xmi_model
{
  my ($node) = @_;

  $node->getOwnerDocument->xmi_model;
}


sub xmi_namespace
{
  my ($node) = @_;
  
  $node->getTagged1IdRef('Foundation.Core.ModelElement.namespace');
}


sub xmi_namespace_q # Ad-hoc name
{
  my ($node) = @_;
  
  my @namespace;
  
  while ( $node ) {
    push(@namespace, $node->xmi_name);
    
    # print STDERR "xmi_namespace_q: $node = ", $node->getNodeName, "\n";
    $node = $node->xmi_namespace;
  }
  
  @namespace = reverse @namespace;
  
  pop(@namespace);
  
  # print STDERR "$node namespace q = ", join('.', @namespace), "\n";
  
  wantarray ? @namespace : \@namespace;
}


sub xmi_clientDependency
{
  my ($node) = @_;

  $node->getTaggedChildIdRef('Foundation.Core.ModelElement.clientDependency');
}


sub xmi_clientDependency_supplier
{
  my ($node) = @_;
  
  map($_->xmi_supplier, $node->xmi_clientDependency);
}


sub xmi_supplierDependency_client
{
  my ($node) = @_;
  
  map($_->xmi_client, $node->xmi_clientDependency);
}



sub xmi_generated_trace
{
  my ($node) = @_;

  # $DB::single = 1;

  my $idref = $node->xmi_taggedValue('uml2code.generated.trace');

  $idref && $node->xmi_doc->xmi_idref_resolve($idref);
}


sub xmi_generated_trace_description
{
  my ($node) = @_;
  
  my $trace = $node->xmi_generated_trace;

  # $DB::single = 1;

  if ( $trace ) {
    my $classname = ref($trace);
    $classname =~ s/^.*:://;
    my $name_q = $trace->xmi_name_q;

    "uml2code.generated <<trace>> $classname $name_q";
  } else {
    "";
  }
}


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

package UML::XMI::GeneralizableElement;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.GeneralizableElement' }


__PACKAGE__->_param
(
 'TaggedTrue', 'isRoot',
 'TaggedTrue', 'isLeaf',
 'TaggedTrue', 'isAbstract',
 'TaggedChildIdRef', 'generalization',
 );


sub xmi_generalization_parent
{
  my ($node) = @_;
  
  my @gens = map($_->xmi_parent, $node->xmi_generalization);
  
  wantarray ? @gens : \@gens;
}


sub xmi_generalization_child
{
  my ($node) = @_;
  
  # print STDERR "gen_child ", $node->xmi_id, " ", $node->xmi_id, ":\n";

  my @x = $node->xmi_model->xmi_generalizations;

  #print STDERR " generalizations = ", join(', ', map($_, @x)), "\n";
  #print STDERR " generalizations id = ", join(', ', map($_->xmi_id, @x)), "\n";
  #$DB::single = 1;

  #print STDERR " gens parent = ", join(', ', map($_->xmi_parent->xmi_id, @x)), "\n";

  @x = grep($_->xmi_parent eq $node, @x);

  #print STDERR " gens parent eq $node = ", join(', ', map($_->xmi_id, @x)), "\n";

  @x = map($_->xmi_child, @x);

  #print STDERR " childs = ", join(', ', map($_->xmi_name, @x)), "\n";

  wantarray ? @x : \@x;
}


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


package UML::XMI::Namespace;

use base qw(UML::XMI::GeneralizableElement);


sub xmi_xml_tag { 'Foundation.Core.Namespace' }


sub xmi_ownedElements
{
  my ($node) = @_;

  grep(! $_->xmi_idref, $node->getTagged('Foundation.Core.Namespace.ownedElement'));
}


sub xmi_classes
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Class', 1));
}


# Returns all interfaces.
sub xmi_interfaces
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Interface', 1));
}


# Returns all associations.
sub xmi_associations
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Association', 1));
}


# Returns all stereotypes.
sub xmi_stereotypes
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Stereotype', 1));
}


# Returns all generalizations
sub xmi_generalizations
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Generalization', 1));
}


# Returns all abstractions
sub xmi_abstractions
{
  my ($node) = @_;
  
  grep(! $_->xmi_idref, $node->getElementsByTagName('Foundation.Core.Abstraction', 1));
}


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


package UML::XMI::Model;

use base qw(UML::XMI::Namespace);


sub xmi_xml_tag { 'Model_Management.Model'; }


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


package UML::XMI::Package;

use base qw(UML::XMI::Namespace);


sub xmi_xml_tag { 'Model_Management.Package'; }


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


package UML::XMI::DataType;

use base qw(UML::XMI::GeneralizableElement);


sub xmi_xml_tag { 'Foundation.Core.DataType'; }


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


package UML::XMI::Stereotype;

use base qw(UML::XMI::GeneralizableElement);


sub xmi_xml_tag { 'Foundation.Extension_Mechanisms.Stereotype'; }


__PACKAGE__->_param
(
 'Tagged1Str', 'baseClass',
 'TaggedChildIdRef', 'extendedElement',
 );


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


package UML::XMI::Classifier;

use base qw(UML::XMI::GeneralizableElement);


sub xmi_xml_tag { 'Foundation.Core.Classifier' }


__PACKAGE__->_param
(
 'TaggedChildIdRef', 'feature',
 );


sub xmi_attributes
{
  my ($node) = @_;
  
  my @attrs = grep($_->isa('UML::XMI::Attribute'), $node->xmi_feature);
  
  @attrs;
}


sub xmi_add_attribute
{
  my ($node, @value) = @_;

  $node->xmi_add_feature(@value);
}


sub xmi_operations
{
    my ($node) = @_;
    
    my @attrs = grep($_->isa('UML::XMI::Operation'), $node->xmi_feature);

    @attrs;
}


sub xmi_associations_attached_to
{
    my ($node) = @_;

    my @assoc;

    ASSOC:
    for my $assoc ( $node->xmi_model->xmi_associations ) {
	for my $assoc_end ( $assoc->xmi_connection ) {
	    if ( $assoc_end->xmi_type eq $node ) {
		push(@assoc, $assoc);
		next ASSOC;
	    }
	}
    }

    wantarray ? @assoc : \@assoc;
}


sub xmi_association_ends_attached_to
{
    my ($node) = @_;
    
    my @ends;

    for my $assoc ( $node->xmi_model->xmi_associations ) {
	my @assoc_ends = $assoc->xmi_connection;
	my @attached_ends = grep($_->xmi_type eq $node, @assoc_ends);
	push(@ends, @attached_ends);
    }

    wantarray ? @ends : \@ends;
}


# Returns all abstraction suppliers that $node uses as a client.
# In Java; this is represented as "implements"
sub xmi_abstraction_supplier
{
    my ($node) = @_;

    my @x;

    for my $abstr ( $node->xmi_model->xmi_abstractions ) {
      if ( $abstr->xmi_client eq $node ) {
	push(@x, $abstr->xmi_supplier);
      }
    }

    wantarray ? @x : \@x;
}



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


package UML::XMI::Class;

use base qw(UML::XMI::Classifier);


sub xmi_xml_tag { 'Foundation.Core.Class'; }


__PACKAGE__->_param
(
 'TaggedTrue', 'isActive',
 );


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


package UML::XMI::Interface;

use base qw(UML::XMI::Classifier);


sub xmi_xml_tag { 'Foundation.Core.Interface'; }


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


package UML::XMI::Feature;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.Feature' }

__PACKAGE__->_param
(
 'Tagged1IdRef', 'owner',
 'TaggedValue' , 'ownerScope',
 );


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


package UML::XMI::StructuralFeature;

use base qw(UML::XMI::Feature);


sub xmi_xml_tag { 'Foundation.Core.StructuralFeature' }


__PACKAGE__->_param
(
 'Tagged1IdRef', 'type',
 'Tagged1IdRef', 'multiplicity',
 'TaggedValue',  'changeability',
 'TaggedValue', 'targetScope',
 );


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


package UML::XMI::Attribute;

use base qw(UML::XMI::StructuralFeature);


sub xmi_xml_tag { 'Foundation.Core.Attribute'; }


__PACKAGE__->_param
(
 'TaggedChildIdRef', 'initialValue',
 );


sub _xmi_initialValue_hash
{
  my ($node) = @_;
  
  my @exprs = $node->xmi_initialValue;

  # $DB::single = 1;

  my %exprs = map(
		  (
		   $_->xmi_language,
		   $_->xmi_body,
		   ),
		  @exprs,
		  );
  
  \%exprs;
}


sub xmi_initialValue_hash # Ad-hoc name
{
  my ($node) = @_;

  my $x;
  unless ( $x = $node->xmi_data('initialValue') ) {
    $x = $node->_xmi_initialValue_hash;
    $node->set_xmi_data('initialValue' => $x);
  }

  $x;
}


sub xmi_initialValue_language # Ad-hoc name
{
  my ($node, $lang) = @_;

  my $x = $node->xmi_initialValue_hash;

  # $DB::single = 1;

  if ( $lang ) {
    $x->{$lang};
  } else {
    my @val = values %$x;
    $val[0];
  }
}


sub xmi_set_initialValue_hash
{
  my ($node, $x) = @_;

  $node->set_xmi_data('initialValue' => $x);
}



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


package UML::XMI::BehavioralFeature;

use base qw(UML::XMI::Feature);


sub xmi_xml_tag { 'Foundation.Core.BehavioralFeature' }


__PACKAGE__->_param
(
 'TaggedTrue', 'isQuery',
 );


sub xmi_parameter
{
  my ($node, $_return) = @_;

  $_return = 0 unless defined $_return;
  
  # $DB::single = 1;
  
  $node = $node->getTagged('Foundation.Core.BehavioralFeature.parameter');
  
  my @params = $node ? $node->getElementsByTagName('Foundation.Core.Parameter', 0) : ();
  
  unless ( $_return ) {
    @params = grep($_->xmi_kind ne 'return', @params);
  }
  
  wantarray ? @params : \@params;
}


sub xmi_return # Ad-hoc name
{
  my ($node) = @_;
  
  my @params = grep($_->xmi_kind eq 'return', $node->xmi_parameter(1));
  
  wantarray ? @params : $params[0];
}


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


package UML::XMI::Operation;

use base qw(UML::XMI::BehavioralFeature);


sub xmi_xml_tag { 'Foundation.Core.Operation'; }


__PACKAGE__->_param
(
 'TaggedValue', 'concurrency',
 'TaggedTrue', 'isRoot',
 'TaggedTrue', 'isLeaf',
 'TaggedTrue', 'isAbstract',
 );


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


package UML::XMI::Parameter;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.Parameter'; }


__PACKAGE__->_param
(
 'TaggedValue', 'kind',
 'Tagged1IdRef', 'behavioralFeature',
 'Tagged1IdRef', 'type',
 'Tagged1IdRef', 'multiplicity',
 );


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


package UML::XMI::Dependency;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.Dependency' }


__PACKAGE__->_param
(
 'Tagged1IdRef', 'client',
 'Tagged1IdRef', 'supplier',
 );


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


package UML::XMI::Usage;

use base qw(UML::XMI::Dependency);


sub xmi_xml_tag { 'Foundation.Core.Usage' }


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


package UML::XMI::Binding;

use base qw(UML::XMI::Dependency);


sub xmi_xml_tag { 'Foundation.Core.Binding' }


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


package UML::XMI::Permission;

use base qw(UML::XMI::Dependency);


sub xmi_xml_tag { 'Foundation.Core.Permission' }


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


package UML::XMI::Abstraction;

use base qw(UML::XMI::Dependency);


sub xmi_xml_tag { 'Foundation.Core.Abstraction' }


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


package UML::XMI::Generalization;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.Generalization' }


__PACKAGE__->_param
(
 'Tagged1IdRef', 'parent',
 'Tagged1IdRef', 'child',
 );


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


package UML::XMI::Association;

use base qw(UML::XMI::GeneralizableElement);


sub xmi_xml_tag { 'Foundation.Core.Association' }


__PACKAGE__->_param
(
 'TaggedChildIdRef', 'connection',
 );


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


package UML::XMI::AssociationEnd;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.AssociationEnd' }


__PACKAGE__->_param
(
 'TaggedTrue', 'isNavigable',
 'TaggedValue', 'ordering',
 'TaggedValue', 'aggregation',
 'TaggedValue', 'targetScope',
 'Tagged1IdRef', 'multiplicity',
 'Tagged1IdRef', 'association',
 'Tagged1IdRef', 'type',
 );


sub xmi_name_q # Ad-hoc name
{
  my ($self) = @_;
  
  join('.', $self->xmi_association->xmi_name_q, $self->xmi_name_s);
}


sub xmi_opposite # Ad-hoc name
{
  my ($node) = @_;
  
  my $assoc = $node->xmi_association;
  
  my @ends = $assoc->xmi_connection;
  
  @ends = grep($_ ne $node, @ends);
  
  wantarray ? @ends : $ends[0];
}



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


package UML::XMI::Comment;

use base qw(UML::XMI::ModelElement);


sub xmi_xml_tag { 'Foundation.Core.Comment' }


__PACKAGE__->_param
(
 'Tagged1IdRef', 'annotatedElement',
 );


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


package UML::XMI::Multiplicity;

use base qw(UML::XMI::Element);


sub xmi_xml_tag { 'Foundation.Data_Types.Multiplicity'; }


__PACKAGE__->_param
(
 'TaggedChildIdRef', 'range',
 );


sub xmi_ranges # Ad-hoc name
{
  my ($node) = @_;
  
  # $DB::single = 1;
  
  my @ranges;

  for my $range ( $node->xmi_range ) {
    my $lower = $range->xmi_lower;
    my $upper = $range->xmi_upper;
    
    $lower = '*' if $lower < 0;
    $upper = '*' if $upper < 0;
    
    my $r;
    
    if ( wantarray ) {
      $r = [ $lower, $upper ];
    } else {
      my $r = $lower eq $upper ? $lower : "${lower}..${upper}";
      
      $r = '*' if $r eq '0..*';
    }
    
    push(@ranges, $r);
  }
  
  wantarray ? @ranges : join(',', @ranges);
}


sub xmi_upper # Ad hoc name.
{
  my ($node) = @_;

  my $upper = 0;

  for my $r ( $node->xmi_ranges ) {
    if ( $r->[1] eq '*' ) {
      # No mulitiplicity can be greater than '*'.
      $upper = $r->[1];
      last;
    }
    elsif ( $r->[1] > $upper ) {
      $upper = $r->[1];
    }
  }

  $upper;
}


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


package UML::XMI::MultiplicityRange;

use base qw(UML::XMI::Element);


sub xmi_xml_tag { 'Foundation.Data_Types.MultiplicityRange' }


__PACKAGE__->_param
(
 'Tagged1Str', 'lower',
 'Tagged1Str', 'upper',
 );


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


package UML::XMI::Expression;

use base qw(UML::XMI::Element);


sub xmi_xml_tag { 'Foundation.Data_Types.Expression' }


__PACKAGE__->_param
(
 'Tagged1Str', 'language',
 'Tagged1Str', 'body',
 );


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

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

