package UML::MetaMetaModel::Util;

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/15 };
our $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

=head1 NAME

UML::MetaMetaModel::Util - Utilities for querying meta-models and models.

=head1 SYNOPSIS

=head1 DESCRIPTION

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

This allows other modules, like 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.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

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

=head1 VERSION

$Revision: 1.3 $

=head1 METHODS

=cut

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

use base qw(Exporter);

our @EXPORT_OK = 
qw(
   ModelElement_name_qualified
   ModelElement_namespace_root

   Namespace_ownedElement_match
   Namespace_ownedElement_name_safe
   Namespace_ownedElement_name_
   Namespace_lookup

   Namespace_classifier

   GeneralizableElement_generalization_parent
   AssociationEnd_opposite

   Multiplicity_fromString
   Multiplicity_asString
   Multiplicity_upper
   MultiplicityRange_asString
   );

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

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

use Carp qw(confess);

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

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

  my @x = 
  grep(length,
       $node->namespace && ModelElement_name_qualified($node->namespace),
       $node->name,
       );

  # $DB::single = 1;

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


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

  while ( my $x = $ns->namespace ) {
    $ns = $x;
  }

  $ns;
}


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

  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, @$oE));

  if ( $recur ) {
    for my $x ( @$oE ) {
      if ( $x->isaNamespace ) {
	push(@x, Namespace_ownedElement_match($x, $match, $recur, $limit));
	last if $limit && @x >= $limit;
      }
    }
  }

  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) = @_;

  # Try locallly ownedElements.
  for my $elem ( $ns->ownedElement ) {
    return $elem if ( $elem->name eq $name );
  }
  
  # Try imported 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 = split('::', $name);
  if ( @name != 1 ) {
    $ns = ModelElement_namespace_root($ns);
    my $last_name = pop(@name);

    for my $pn ( @name ) {
      my $x = Namespace_ownedElement_name_safe($ns, $pn);
      die("Cannot find Namespace named '$pn'") unless $x;
      $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) . '"') unless $x;

  $x;
}


#
# 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.
# 
# There was some mention of direct ownedElemtns are visible from all
# parent namespaces.
#
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);
}


=head2 Namespace_classifier

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

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


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

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

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

  my @x;
  for my $x ( $self->generalization ) {
    push(@x, $x->parent);
  }

  @x;
}

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

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

  my @x;

  my $assoc;
  if ( 1 ) {
    #
    # Hack to get around the unamed AssocationEnd between
    # AssocationEnd (connection) ------ () Association.
    #
    #$DB::single = 1;
    $assoc = $end->connection_; 
  } else {
    # Since the UML meta model does not have a role name for the Assocation
    # it is not navigable!!!
    # So to find the AssociationEnd opposite another end, we have to search the entire
    # model!!
    
    local $namespace_trace = "AssociationEnd_opposite $end";
    my ($assoc) = Namespace_ownedElement_match
    (ModelElement_namespace_root($end),
     sub {
       $_[0]->isaAssociation && grep($_ eq $end, $_[0]->connection);
     },
     1,
     );
    
  }

  @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],
			  '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_upper
{
  my ($multi) = @_;

  my $upper = 1; # If none specified.

  if ( $multi ) {
    for my $r ( $multi->range ) {
      my $x;
      if ( ($x = $r->upper) eq '*' ) {
	$upper = $x;
	last;
      }
      elsif ( $upper < ($x = $r->upper) ) {
	$upper = $x;
      }
    }
  }

  $upper;
}


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

  return 1 unless $node;

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

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



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

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

