UMMF::Core::Util - Utilities for querying meta-models and models.

UMMF documentation Contained in the UMMF distribution.

Index

Code Index:

NAME

Top

UMMF::Core::Util - Utilities for querying meta-models and models.

SYNOPSIS

Top

DESCRIPTION

Top

Useful manipulations of model. These can be used for any UML meta level.

This allows other modules, like UMMF::UML::Export::*, to assume that the UML meta-model is "stupid" i.e. has no support methods other than accessors for Attributes and Associations.

Eventually these could be imported into generated models as supplimentary methods.

USAGE

Top

EXPORT

Top

None exported.

AUTHOR

Top

Kurt Stephens, kstephens@users.sourceforge.net 2003/04/15

SEE ALSO

Top

UMMF::Core::MetaMetaModel (UMMF::Core::MetaMetaModel)

VERSION

Top

$Revision: 1.36 $

METHODS

Top

ModelElement_name_qualified

  my @names = ModelElement_name_qualified($obj);
  my $qname = ModelElement_name_qualified($obj, $sep);
  my $qname = ModelElement_name_qualified($obj, $sep, $filter);

Returns the fully-qualified name for a ModelElement. Applies $name = $filter->($obj, $name) to each ModelElement, if $filter is defined.

In list context, returns the names of all parent namespaces. In scalar context, joins the names of all parent namespaces with $sep $sep defaults to '::'.

ModelElement_namespace_root

Returns the root Namespace of a ModelElement.

ModelElement_namespace_common

Returns the Namespace parent that is common to two ModelElements.

For example: if $x is in a UML Namespace "A::B" and $y is in a Namespace "A::C::D", ModelElement_namespace_common($x, $y) will return the "A" Namespace object.

Namespace_namespace

Returns a list of all Namespace nodes owned by a Namespace.

Namespace_classifier

Returns a list of all Classifier nodes owned by a Namespace.

Namespace_class

Returns a list of all Class nodes owned by a Namespace.

Namespace_associationClass

Returns a list of all AssociationClass nodes owned by a Namespace.

Namespace_interface

Returns a list of all Interface nodes owned by a Namespace.

Namespace_enumeration

Returns a list of all Enumeration nodes owned by a Namespace.

GeneralizableElement_generalization_parent

Returns a list of the Generalization parents (superclasses) of a GeneralizableElement.

GeneralizableElement_generalization_parent_all

Returns a list of all the Generalization parents (superclasses) of a GeneralizableElement, toward the root Generalization (root baseclasses).

Classifier_attribute

Returns all Attribute features.

Classifier_operation

Returns all Operation features

Classifier_method

Returns all Method features.

Operation_return

Returns the return Parameter.

Expression_body_language

Returns the body text of an Expression for a specific language.

Attribute_initialValue_language

Returns the body text of an Attribute's initialValue Expression.

AssociationEnd_opposite

  @other_ends = AssociationEnd_opposite($end);

Returns a list of all the AssociationEnds opposite to the AssociationEnd. Typically this list has only one AssociationEnd.

Multiplicity_fromString

  my $multiplicity = Multiplicity_fromString($str, $factory);

Creates a Multiplicity object, using factory $factory by parsing string $str.

Class_Association_Attribute

Returns a list of new Attribute objects that are a typical representation of opposite AssociationEnds in a Class.

AssociationClass_Attribute

Returns a list of new Attribute objects that are a typical representation of the AssociationEnds in a AssociationClass.

UMMF documentation Contained in the UMMF distribution. 
package UMMF::Core::Util;

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


our $AUTHOR = q{ kstephens@users.sourceforge.net 2003/04/15 };
our $VERSION = do { my @r = (q$Revision: 1.36 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };


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

use base qw(Exporter);

our @EXPORT_OK = 
qw(
   ModelElement_initialize

   ModelElement_name_qualified
   ModelElement_namespace_root
   ModelElement_namespace_common

   Namespace_ownedElement_match
   Namespace_ownedElement_name_safe
   Namespace_ownedElement_name
   Namespace_ownedElement_name_
   Namespace_lookup

   Namespace_namespace
   Namespace_classifier
   Namespace_class
   Namespace_interface
   Namespace_enumeration
   Namespace_associationClass
   
   GeneralizableElement_generalization_parent
   GeneralizableElement_generalization_parent_all
   GeneralizableElement_generalization_child
   GeneralizableElement_generalization_child_all

   Multiplicity_fromString
   Multiplicity_asString
   Multiplicity_lower
   Multiplicity_upper
   MultiplicityRange_asString

   Association_asString
   AssociationEnd_asString

   Attribute_asString

   ModelElement_taggedValue_name
   ModelElement_taggedValue_name_true
   ModelElement_taggedValue_inheritsFrom
   ModelElement_taggedValue_inherited
   ModelElement_taggedValue_inherited_true
   ModelElement_taggedValue_trace
   ModelElement_set_taggedValue_name
   
   TagDefinition_for_name

   Classifier_attribute
   Classifier_operation
   Classifier_method
   
   Class_Association_Attribute
   AssociationClass_Attribute

   Attribute_initialValue_language

   Operation_return

   Expression_body_language

   __fix_association_end_names

   AssociationEnd_opposite
   AssociationEnd_association

   Model_clone
   Attribute_clone
   Operation_clone
   Association_clone

   Model_destroy

   trimws
   trim_ws_undef

   String_toBoolean
   ISA_super
   index_array
   unique_proc
   unique
   unique_ref
   );

our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );

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

use Carp qw(confess);

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

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


sub trim_ws_undef
{
  my ($x) = @_;

  if ( ref($x) ) {
    return $$x = trim_ws_undef($$x);
  }

  return undef unless defined $x;

  $x =~ s/^[\s\n]+//sg;
  $x =~ s/[\s\n]+$//sg;

  length $x ? $x : undef;
}



sub String_toBoolean
{
  my ($x) = @_;
  
  return undef unless defined $x;

  $x = trimws($x);
  
  no warnings;
  $x ne '' && $x ne 'false' && $x ne 'no' && $x ne '0';
}


sub ISA_super
{
  my ($x) = @_;

  # $DB::single = 1;
  $x = ref($x) || $x;

  no strict 'refs';

  my @x = ( $x );
  my @c;
  while ( @x ) {
    my $x = pop @x;
    next if grep($_ eq $x, @c);
    push(@c, $x);
    push(@x, @{"${x}::ISA"});
  }

  wantarray ? @c : \@c;
}


sub members
{
  my ($x) = @_;

  $x ? (UNIVERSAL::can($x, 'members') ? $x->members() : @$x) : ();
}


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

  for ( my $i = -1; ++ $i < @x;  ) {
    return $i if $x[$i] eq $x;
  }

  undef;
}


sub identity { shift }


sub unique_proc ($$)
{
  my ($proc, $x) = @_;
  my %x = map(($proc->($_), $_), @$x);
  wantarray ? values %x : [ values %x ];
}


sub unique
{
  unique_proc(\&identity, \@_);
}


sub unique_ref ($)
{
  unique_proc(\&identity, $_[0]);
}


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


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

  my $name = $self->{'name'};
  if ( length $name ) {
    die("Invalid ModelElement name '$name'") if $name =~ /::/;
  }

  $self->SUPER::initialize;
}


sub ModelElement_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") if $name =~ /::/;
  }

  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 '" . $ns->name . "' already has element '$x' named '$name' for $self");
      }
    }
  }

  $self;
}


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


sub Attribute_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'}, UMMF::UML::MetaMetaModel->factory);

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


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


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

  my $x = $self->{'connection'};
  if ( $x ) {
    $x->[0]->set_namespace($x->[1]->participant) unless $x->[0]->namespace;
    $x->[1]->set_namespace($x->[0]->participant) unless $x->[1]->namespace;

    # Set the Association's namespace
    # to be the common Namespace of all the Participants.
    # This seems to be what ArgoUML is doing.
    unless ( $self->{'namespace'} ) {
      # $DB::single = 1;
      $self->set_namespace(
			   ModelElement_namespace_common(map($_->namespace, @$x))
			   );
    }

  }

  $self;
}


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


sub AssociationEnd_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'}, UMMF::UML::MetaMetaModel->factory);

  $self;
}



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


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

  my $name = $node->name;
  
  # Handle anonymous model elements.
  unless ( length($name) ) {
    # Use the position of ModelElement in it's Namespace's ownedElement
    # Association, even though that AssociationEnd is not ordered.
    if ( $node->namespace ) {
      my $i = 0;
      for my $x ( $node->namespace->ownedElement ) {
	if ( $x eq $node ) {
	  $name = "__Anon__$i";
	  last;
	}
	$i ++;
      }
    }
    
    # Fall back on the memory address of the ModelElement.
    unless ( length($name) ) { 
      $node =~ /0x([0-9a-f]+)/i;
      $name = $1 ? "__Anon__$1" : "__Anon_IGiveUp";
    }
  }
  
  $name;
}



sub ModelElement_name_qualified
{
  my ($node, $sep, $filter) = @_;

  my @x;

  confess("$node is not ref") unless ref($node);

  #
  # Cull the Model's name (Model's are root namespaces, ie. Model->namespace = nil) 
  # Model names are not usually intended for
  # scoping ModelElements when generating code.
  #
  if ( $node->namespace ) {
    @x = ModelElement_name_qualified($node->namespace, undef, $filter);

    {
      my $name = ModelElement_name_anon($node);
      $name = $filter->($node, $name) if $filter;
      push(@x, $name);
    }
  }

  # $DB::single = 1;

  wantarray ? @x : join($sep || '::', @x); 
}



sub ModelElement_namespace_root
{
  my ($ns) = @_;

  while ( my $x = $ns ? $ns->namespace : confess("ns") ) {
    $ns = $x;
  }

  $ns;
}



sub ModelElement_namespace_common
{
  my ($me1, $me2, @other) = @_;

  my $x = $me1 || $me2;

  X: while ( $x ) {
    my $y = $me2 || confess("me2");
    while ( $y ) {
      last X if $y eq $x;
      $y = $y->namespace;
    }
    $x = $x->namespace;
  }

  if ( @other ) {
    $x = ModelElement_namespace_common($x, @other);
  }

  $x;
}


our $namespace_trace = 0;
sub Namespace_ownedElement_match
{
  my ($ns, $match, $recur, $limit, $ns_too) = @_;

  unless ( ref($match) ) {
    my $meth = $match;
    $match = sub { $_[0]->$meth };
  }

  if ( $namespace_trace ) {
    print STDERR "N_oE_m ", scalar ModelElement_name_qualified($ns), " : $namespace_trace :\n";
  }

  my @x;
  my $oE = $ns->ownedElement;
  push(@x, grep($match->($_), $ns));

  if ( $recur ) {
    for my $x ( @$oE ) {
      confess("BAAAAAH $x") if ref($x) eq 'main';
      if ( $x->isaNamespace ) {
	if ( $ns_too ) {
	  push(@x, grep($match->($x), $x));
	  last if $limit && @x >= $limit;
	}
	push(@x, Namespace_ownedElement_match($x, $match, $recur, $limit, $ns_too));
	last if $limit && @x >= $limit;
      } else {
	push(@x, grep($match->($x), $x));
      }
    }
  } else {
    push(@x, grep($match->($_), @$oE));
  }

  if ( $namespace_trace ) {
    local $" = ', ';
    print STDERR "N_oE_m ", scalar ModelElement_name_qualified($ns), " : = @x\n";
  }

  @x = @x[0 .. $limit - 1] if $limit;

  if ( $limit && $namespace_trace ) {
    local $" = ', ';
    print STDERR "N_oE_m ", scalar ModelElement_name_qualified($ns), " limited = @x\n";
  }


  wantarray ? @x : \@x;
}


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

  #$DB::single = 1 if $ns->{'name'} eq 'Model_Management';

  # Nice hack for relative Namespaces.
  if ( $name eq '.' ) {
    return $ns;
  }
  elsif ( $name eq '..' ) {
    $ns = $ns->namespace || $ns;
    return $ns;
  }

  # Try ownedElements first.
  for my $elem ( $ns->ownedElement ) {
    # $DB::single = 1 unless ref($elem);
    confess("ownedElement $elem is not blessed ref") unless ref($elem) =~ /::/;
    return $elem if ( $elem->name eq $name );
  }
  
  # Try importedElement if $ns is a package!
  if ( $ns->isaPackage ) {
    for my $elem ( $ns->importedElement ) {
      # alias through ElementImport?
      #$DB::single = 1 unless ref($elem);
      confess("importedElement is not ref") unless ref($elem);
      return $elem if ( $elem->name eq $name );
    }
  }

  undef;
}


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

  my @name = ref($name) ? @$name : split('::', $name);
  if ( @name != 1 ) {
    if ( $name[0] eq '.' ) {
      $ns = $ns;
      shift @name;
    } else {
      $ns = ModelElement_namespace_root($ns);
    }
    my $last_name = pop(@name);

    for my $pn ( @name ) {
      my $x = Namespace_ownedElement_name_safe($ns, $pn);

      unless ( $x ) {
	$DB::single = 1;
	confess("Cannot find Namespace named '$pn' from Namespace '" . ModelElement_name_qualified($ns) . "' $ns");
      }

      $ns = $x;
    }

    $name = $last_name;
  }
  
  Namespace_ownedElement_name_safe($ns, $name);
}


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

  # Incase its already resolved.
  return $name if ref($name);

  my $x = Namespace_ownedElement_name($ns, $name);
  confess("Cannot find ModelElement named '$name' from Namespace '" . ModelElement_name_qualified($ns) . "' $ns") unless $x;

  $x;
}


#
# This is a lexical convention, not a UML convention.
#
# If looking up by name from within the context of a Classifier fails,
# 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 Usages
# when most Classifiers in a Package colaborate with each other.
# 
# There was some mention of direct ownedElements are visible from all
# parent namespaces in the UML spec.
#
sub Namespace_lookup
{
  my ($ns, $name) = @_;

  # Shorthand for search/replace.
  if ( ref($name) eq 'SCALAR' ) {
    return $$name = Namespace_lookup($ns, $$name);
  }

  # Namespace searches in a Classifier should
  # always bounce out to its namespace.
  if ( $ns->isaClassifier ) {
    my $x = Namespace_ownedElement_name($ns, $name);
    return $x if $x;

    # Try Classifier's namespace.
    $ns = $ns->namespace;
  }

  Namespace_ownedElement_name_($ns, $name);
}



sub Namespace_namespace
{
  Namespace_ownedElement_match($_[0], 'isaNamespace', 1);
}



sub Namespace_classifier
{
  Namespace_ownedElement_match($_[0], 'isaClassifier', 1);
}



sub Namespace_class
{
  Namespace_ownedElement_match($_[0], 'isaClass', 1);
}



sub Namespace_associationClass
{
  Namespace_ownedElement_match($_[0], 'isaAssociationClass', 1);
}



sub Namespace_interface
{
  Namespace_ownedElement_match($_[0], 'isaInterface', 1);
}



sub Namespace_enumeration
{
  Namespace_ownedElement_match($_[0], 'isaEnumeration', 1);
}



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



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

  # $DB::single = 1 unless $self =~ /::/;
  # confess("not a ref") unless ref($self);

  my @x = map($_->parent, $self->generalization);

  @x;
}



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

  # $DB::single = 1 unless $self =~ /::/;

  my @gen_all;

  my @q = GeneralizableElement_generalization_parent($self);
  while ( @q ) {
    my $q = pop @q;
    next if grep($_ eq $q, @gen_all);
    push(@gen_all, $q);
    push(@q, map($_->parent,
		 grep(defined, $q->generalization),
		 )
	 );
  }

  @gen_all;
}


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

  # $DB::single = 1 unless $self =~ /::/;
  # confess("not a ref") unless ref($self);

  my @x = map($_->child, $self->generalization);

  @x;
}


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

  # $DB::single = 1 unless $self =~ /::/;

  my @gen_all;

  my @q = GeneralizableElement_generalization_child($self);
  while ( @q ) {
    my $q = pop @q;
    next if grep($_ eq $q, @gen_all);
    push(@gen_all, $q);
    push(@q, map($_->child,
		 grep(defined, $q->generalization),
		 )
	 );
  }

  @gen_all;
}


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



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

  grep($_->isaAttribute, $node->feature);
}



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

  grep($_->isaOperation, $node->feature);
}



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

  grep($_->isaMethod, $node->feature);
}


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



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

  my @x = grep($_->kind eq 'return', $node->parameter);

  @x ? $x[0] : undef;
}



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



sub Expression_body_language
{
  my ($obj, $lang) = @_;

  my $value;

  if ( $obj ) {
    # Specific language?
    if ( $lang && lc($obj->language) eq lc($lang) ) { 
      # confess("$obj -> body") unless UNIVERSAL::can($obj, 'body');
      $value = $obj->body;
    }
    # Universal language?
    elsif ( $lang && ! length($obj->language) ) {
      $value = $obj->body;
    }
    # No language specified.
    elsif ( ! $lang ) { 
      $value = $obj->body;
    }
  }

  if ( defined $value ) {
    $value = trimws($value);
  }

  $value = undef if defined $value && ! length $value;

  $value;
}


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



sub Attribute_initialValue_language
{
  my ($node, $lang) = @_;

  no warnings;

  my $body;

  # Use initialValue.body if it matches the requested language.
  my $iV = $node->initialValue;
  if ( $iV && lc($iV->language) eq lc($lang) ) {
    $body = $iV->body;
  } else {
    # Try tagged values.
    $lang = ucfirst($lang);
    
    $body = (grep(defined,
		  map(join('', ModelElement_taggedValue_name($node, $_)),
		      "ummf.$lang.initialValue",
		      "ummf.initialValue")
		 ))[0];
  }

  # Default to initialValue.body if initialValue.language is not specified.
  if ( ! defined $body ) {
    if ( $iV && ! length($iV->language) ) {
      $body = $iV->body;
    }
  }

  $body;
}


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


sub __make_association_end_name
{
  my ($x, $y) = @_;

  $x = $x->name if ( ref($x) );

  $x =~ s/^.*:://s;

  if ( @_ == 2 ) {
    $x = "${y}_$x" if $y;
    
    $x .= '_';
  } else {
    $x = lcfirst($x);
  }

  $x;
}


sub __fix_association_end_names
{
  if ( ! $_[1] && $_[3] ) {
    # T1 "" --- T2 n2 => n2_T1_
    # $DB::single = 1;

    #local $" = "\",\t\""; print STDERR "A\t@_\n";
    $_[1] = __make_association_end_name($_[0]);

    #print STDERR " =>\t@_\n";
  }
  elsif ( $_[1] && ! $_[3] ) {
    # T1 n1 --- T2 "" => n1_T2_

    # $DB::single = 1;
    #local $" = "\",\t\""; print STDERR "A\t@_\n";

    $_[3] = __make_association_end_name($_[2]);

    #print STDERR " =>\t@_\n";
  }
  elsif ( ! $_[1] && ! $_[3] ) {
    # $DB::single = 1;

    #local $" = "\",\t\""; print STDERR "A\t@_\n";

    $_[1] = __make_association_end_name($_[0]);
    $_[3] = __make_association_end_name($_[2]);

    #print STDERR " =>\t@_\n";
  }
  if ( $_[1] eq $_[3] ) {
    $_[1] .= '0';
    $_[3] .= '1';
  }
}




my ($a_type, $a_name, $e_type, $e_name) = 
(
 'Association',
 '',
 'AssociationEnd',
 'connection',
 );

__fix_association_end_names($a_type, $a_name, $e_type, $e_name);


sub AssociationEnd_association
{
  my ($end) = @_;

  confess("undef") unless $end;

  my $assoc;

  #
  # Hack to get around the unamed AssocationEnd between
  # AssocationEnd (connection) ------ () Association.
  #

  if ( 1 ) {
    # See modified MetaModel.spec.
    #
    #$DB::single = 1;
    $assoc = $end->{'_association'};
  }

  if ( 0 && ! $assoc ) {
    # See __fix_association_end_names()
    $assoc = $end->$a_name; 
  }

  unless ( $assoc ) {
    # Since the UML meta model does not have a role name for the Association
    # it is not navigable.
    # So to find the AssociationEnd opposite another end, we have to search the entire
    # model.
    
    # local $namespace_trace = "AssociationEnd_association $end";
    my ($assoc) = Namespace_ownedElement_match
    (ModelElement_namespace_root($end->participant),
     sub {
       $_[0]->isaAssociation && grep($_ eq $end, $_[0]->connection);
     },
     1,
     );    
  }

  $DB::single = 1 unless $assoc;
  confess("Cannot get Association from AssocationEnd " . AssociationEnd_asString($end)) unless $assoc;

  $assoc;
}



sub AssociationEnd_opposite
{
  my ($end) = @_;

  my @x;

  my $assoc = AssociationEnd_association($end);

  @x = grep($_ ne $end, $assoc->connection);

  @x;
}


#######################################################################
# These assume a Factory.
#


sub Multiplicity_fromString
{
  my ($str, $factory) = @_;

  # Shorthand.
  if ( ref($str) eq 'SCALAR' ) {
    return $$str = Multiplicity_fromString($$str, $factory);
  }

  # Dont bother if its already an object.
  return $str if ref($str);

  my @range = split(/\s*,\s*/, $str);

  push(@range, 1) unless @range;

  for my $r ( @range ) {
    my @x = split(/\s*\.\.\s*/, $r, 2);
    
    $r = $factory->create('MultiplicityRange',
			  'lower' => $x[0] ne '*' ? $x[0] : 0,
			  'upper' => $x[1] || $x[0],
			  );
  }

  my $x = $factory->create('Multiplicity',
			   'range' => \@range,
			   );

  $x;
}


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

  return $node unless ref $node;

  join(',',
       map(MultiplicityRange_asString($_),
	   $node->range)
       );
}


sub Multiplicity_lower
{
  my ($multi) = @_;

  my $lower;

  # Note: 
  # This code does not use accessor methods,
  # so UMMF::Boot::Factory::Object::AUTOLOAD()
  # will not go into recursion.
  #
  if ( $multi ) {
    for my $r ( members($multi->{'range'}) ) {
      my $x = $r->{'lower'};

      # ArgoUML and Poseidon use '-1' for UnlimitedInteger.
      $x = '*' if $x < 0; 
      
      if ( $x eq '*'  ) {
	confess("Unexpected UnlimitedInteger for MultiplicityRange lower");
      }
      elsif ( ! defined $lower ) {
	$lower = $x;
      }
      elsif ( $lower > $x ) {
	$lower = $x;
      }
    }
  }

  $lower = 1 unless defined $lower; # If none specified.

  $lower;
}


sub Multiplicity_upper
{
  my ($multi) = @_;

  my $upper = 1; # If none specified.

  # Note: 
  # This code does not use accessor methods,
  # so UMMF::Boot::Factory::Object::AUTOLOAD()
  # will not go into recursion.
  #
  if ( $multi ) {
    for my $r ( members($multi->{'range'}) ) {
      my $x = $r->{'upper'};

      # ArgoUML and Poseidon use '-1' for UnlimitedInteger.
      $x = '*' if $x < 0; 

      if ( $x eq '*'  ) {
	$upper = $x;
	last;
      }
      elsif ( $upper < $x ) {
	$upper = $x;
      }
    }
  }

  $upper;
}


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

  return 1 unless $node;

  my $u = $node->upper;
  my $l = $node->lower;

  $l = '*' if $l < 0;

  $u eq $l ? $u : "$l..$u";
}


sub ModelElement_name_with_id
{
  my ($p) = @_;

  no warnings;

  my $id = ref($p) ? $p->{'_id'} : '';
  $p = ref($p) ? $p->{'name'} : $p;
  $p = '""' unless length $p;
  $p = "$p /*$id*/" if ( $id );

  $p;
}


sub Association_asString
{
  my ($assoc, %end_annot) = @_;

  no warnings;

  my $name = ModelElement_name_with_id($assoc);

  sprintf("  @ @ %-50s\n",
	  $name
	  ) .
  join(",\n", 
       map("  " . AssociationEnd_asString($_, $end_annot{$_}),
	   members($assoc->{'connection'})
	   )
       ) . ';'
}



sub AssociationEnd_asString
{
  my ($x, $end_annot) = @_;

  no warnings;

  my $p = ModelElement_name_with_id($x->{'participant'});

  sprintf("%-2s %-3s %25s : %-20s %-5s %s %s%s%s",
	  (
	   (String_toBoolean($x->{'isNavigable'}) && '->'),
	   ($x->{'aggregation'} eq 'aggregate' && "<>") ||
	   ($x->{'aggregation'} eq 'composite' && "<#>")
	   ),
	  (
	   ($x->{'visibility'} eq 'public'    && '+') ||
	   ($x->{'visibility'} eq 'private'   && '-') ||
	   ($x->{'visibility'} eq 'protected' && '#') ||
	   ($x->{'visibility'} eq 'package'   && '~') ||
	                                         ' '
	   ) .
	  ($x->{'name'} || '""'),
	  $p,
	  Multiplicity_asString($x->{'multiplicity'}),
	  ($x->{'ordering'} eq 'ordered' && " {ordered}"),
	  ($x->{'_phantom'} && " {phantom}"),
	  ($x->{'_trace'} && " <<trace>> --> " . $x->{'_trace'}{'name'}),
	  " /*$x->{_id}*/ $end_annot",
	  );
}


sub Attribute_asString
{
  my ($x) = @_;

  no warnings;
  my $p = ModelElement_name_with_id($x->{'type'});

  my $m = Multiplicity_asString($x->{'multiplicity'});

  my $iV = $x->{'initialValue'};
  if ( ref($iV) ) {
    $iV = $iV->{'body'} . "/* $iV->{language} */";
  }

  sprintf("      %25s %-30s\n",
	  '',
	  "/* Attribute $x->{_id} */",
	  ) .
  sprintf("  %25s : %-20s %-7s%s;%s",
	  (
	   ($x->{'visibility'} eq 'public'    && '+') ||
	   ($x->{'visibility'} eq 'private'   && '-') ||
	   ($x->{'visibility'} eq 'protected' && '#') ||
	   ($x->{'visibility'} eq 'package'   && '%') ||
	   ' '
	   ) .
	  ($x->{'name'} || '""'),
	  $p,
	  $m ne '1' ? "[$m]" : '',
	  (defined $iV ? ' = ' . $iV : ''),
	  ($x->{'_trace'} && ("/* <<trace>> --> " . $x->{'_trace'}{'name'} . " */")),
	  );
}



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


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

  $DB::single = 1 unless ref($node);

  #$DB::single = 1 if ( ModelElement_name_qualified($node) =~ /sonema/ );

  return +() unless $node->can('taggedValue');

  my @x = grep($_->type->name eq $name, $node->taggedValue);

  #local $" = ', '; print STDERR "ME_tV_n ", scalar ModelElement_name_qualified($node), " $name => @x \n";

  @x ? @x : ( defined $default ? +( $default ) : () );
}


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

  my @x = ModelElement_taggedValue_name_array($node, $name);

  # This assumes that everybody wants dataValue as a string,
  # instead of the String[*] its specified as in the UML 1.5 Spec.
  @x ? join('', $x[0]->dataValue) : $default;
}


sub ModelElement_taggedValue_name_true
{
  String_toBoolean(ModelElement_taggedValue_name(@_));
}



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

  # Traverse up containment.
  #
  # Many XMI models do not specify namespaces for
  # Features (Attributes), so use the Feature's owner
  # for taggedValue inheritance.
  #
  if ( $node->isaFeature ) {
    $node = $node->owner;
  } else {
    $node = $node->namespace;
  }
  
  $node;
}


my $hiddenDefault = [ ];
sub ModelElement_taggedValue_inherited
{
  my ($node, $name, $default) = @_;

  # print STDERR "ME_tV_i ", scalar ModelElement_name_qualified($node), " $name =>\n";

  while ( $node ) {
    my $x = ModelElement_taggedValue_name($node, $name, $hiddenDefault);
    if ( $x ne $hiddenDefault ) {
      $default = $x;
      last;
    }

    $node = ModelElement_taggedValue_inheritsFrom($node);
  }

  # print STDERR "  '$default'\n";

  $default;
}


sub ModelElement_taggedValue_inherited_true
{
  String_toBoolean(ModelElement_taggedValue_inherited(@_));
}


sub ModelElement_taggedValue_trace
{
  ModelElement_taggedValue_inherited(@_);
}


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

  my @x = grep($_->type->name eq $name, $node->taggedValue);

  if ( @x ) {
    grep($_->set_dataValue($value), @x);
  } else {
    my $td = TagDefinition_for_name($node, $name, $factory);

    my $tv = $factory->create('TaggedValue',
			      'type' => $td,
			      'dataValue' => [ $value ],
			      );

    $node->add_taggedValue($tv);
  }

  $node
}


sub TagDefinition_for_name
{
  my ($node, $name, $factory, $multiplicity) = @_;

  my $model = $node && ModelElement_namespace_root($node);
  my $td;

  ($td) = grep($_->isaTagDefinition && $_->name eq $name, $model->ownedElement)
  if $model;
  
  unless ( $td ) {
    $multiplicity ||= '1';

    $td = $factory->create('TagDefinition', 
			   'name' => $name,
			   'multiplicity' => Multiplicity_fromString($multiplicity, $factory),
			   'tagType' => '',
			   );

    $model->add_ownedElement($td) if $model;
  }

  $td;
}



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


sub Class_Association_Attribute
{
  my ($cls, $factory) = @_;

  $factory ||= $cls->__factory;

  my @attr;

  for my $cls_end ( $cls->association ) {
    for my $end ( AssociationEnd_opposite($cls_end) ) {
      my $name  = $end->name; # IMPLEMENT: naming.
      next unless $name;
      next unless $end->isNavigable eq 'true';
      my $multi = $end->multiplicity;
      my $type  = $end->participant;
      my $targetScope = $cls_end->targetScope;
      my $ordering = $end->ordering;
      my $visibility = $end->visibility;
      
      my $attr = $factory->create('Attribute',
				  # 'owner' => $cls,
				  'name' => $name,
				  'type' => $type,
				  'multiplicity' => $multi,
				  'targetScope' => $targetScope,
				  'ordering' => $ordering,
				  'visibility' => $visibility,
				  );

      # IMPLEMENT: Add trace

      push(@attr, $attr);
				  
    }
  }

  wantarray ? @attr : \@attr;
}

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


sub AssociationClass_Attribute
{
  my ($cls, $factory) = @_;

  $factory ||= $cls->__factory;

  my @attr;

  for my $end ( $cls->connection ) {
    my $name  = $end->name; # IMPLEMENT: naming.
    next unless $name;
    next unless $end->isNavigable eq 'true';
    my $multi = $end->multiplicity;
    my $type  = $end->participant;
    my $targetScope = 'instance';
    my $ordering = $end->ordering;
    my $visibility = $end->visibility;
    
    my $attr = $factory->create('Attribute',
				# 'owner' => $cls,
				'name' => $name,
				'type' => $type,
				'multiplicity' => $multi,
				'targetScope' => $targetScope,
				'ordering' => $ordering,
				'visibility' => $visibility,
				);
    
    # IMPLEMENT: Add trace
    
    push(@attr, $attr);
  }

  wantarray ? @attr : \@attr;
}


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

sub Model_clone
{
  my ($node, $map, $map_) = @_;

  $map ||= { };

  my $ref = ref($node);

  return $node unless $ref;
  return [ map(Model_clone($_, $map, $map_), @$node) ] if $ref eq 'ARRAY';
  return { map(Model_clone($_, $map, $map_), %$node) } if $ref eq 'HASH'; 

  my $node_x = $map->{$node};
  return $node_x if $node_x;
  
  $map->{$node} = $node_x = bless({ %$node }, $ref);
  $map_->{$node_x} = $node if $map_;

  for my $key ( keys %$node_x ) {
    my $v = \{$node_x->{$key}};
    $$v = Model_clone($$v, $map, $map_);
  }
  
  $node_x;
}


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

  $node = $node->__clone;

  $node->{'owner'} = undef;

  $node;
}


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

  $node = $node->__clone;

  $node->{'owner'} = undef;

  my @x = map($_->__clone, $node->parameter);
  grep($_->{'parameter_'} = undef, @x);
  $node->{'parameter'} = [ ];
  $node->set_parameter(@x);

  $node;
}



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

  confess("undef") unless $node;

  $node = $node->__clone;

  # Make new AssociationEnds.
  # $DB::single = 1;
  my @x = map($_->__clone, $node->connection);
  grep($_->{'connection_'} = undef, @x);
  $node->{'connection'} = [ ];
  $node->set_connection(@x);

  $node;
}


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


sub Model_destroy
{
  my ($x) = @_;

  my $ref = ref($x);

  return unless $ref;

  my @x;

  if ( $ref =~ /ARRAY/ ) {
    @x = @$x;
    @$ref = ();
  }
  elsif ( $ref =~ /HASH/ ) {
    @x = @$x;
    %$ref = ();
  }
  elsif ( $ref =~ /SCALAR/ ) {
    $$ref = undef;
  }

  grep(Model_destroy($_), @x);
}


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




1;

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


### Keep these comments at end of file: kstephens@users.sourceforge.net 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: ###