package UML::MetaMetaModel::Object;

use 5.6.1;
use strict;
#use warnings;


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::MetaModel::Object - A base class for all MetaMetaModel classes.

=head1 SYNOPSIS

  use base qw(UML::MetaMetaModel::Object);

=head1 DESCRIPTION

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

L<UML::XMI|UML::XMI>

=head1 VERSION

$Revision: 1.3 $

=head1 METHODS

=cut


####################################################################################
# Base class for all meta-metamodle classes.
#
# Note: no AUTOLOAD facilities.
#

package UML::MetaMetaModel::Object::Base;

our $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

sub new
{
  my ($self, %opts) = @_;
  $self = bless(\%opts, ref($self) || $self);
  $self->initialize();
}


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

  $self;
}


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

  # $DB::single = 1;

  $self =~ /\(([^\)]+)\)/;

  $1;
}


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

  "$self()";
}


####################################################################################
# Base class for all meta model objects.
# Note: Clients of this class rely on AUTOLOAD functionality.
#


package UML::MetaMetaModel::Object;

our $VERSION = do { my @r = (q$Revision: 1.3 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

use base qw(UML::MetaMetaModel::Object::Base);


use Carp qw(confess);


####################################################################################
# These construct assessor methods for
# Associations in the meta-meta model.
#

sub __accessor_one_to_many
{
  my ($one, $many) = @_;

  return () unless $one;

  my $remove_many = "remove_$many";
  my $add_many = "add_$many";

  # $DB::single = 1;

  my $getter = sub {
    my ($self, $new) = @_;
    $self->{$one};
  };

  my $setter = sub {
    my ($self, $new) = @_;
    
    my $old;
    if ( ($old = $self->{$one}) ne $new ) { # Recursion lock
      $self->{$one} = $new; # Recursion lock
      
      if ( $many ) {
	# $DB::single = 1 if ( $many eq 'ownedElement' );
	$old->$remove_many($self) if $old;
	$DB::single = 1 if ( $new =~ /Smc/ );

	$new->$add_many($self) if $new;
      }
    }
    
    $self
  };

  (
   "$one", $getter, 
   "set_$one", $setter,
   );
}


sub __accessor_many_to_one
{
  my ($many, $one) = @_;

  return () unless $many;

  my $set_one = "set_$one";
  my $clear_many = "clear_$many";
  my $add_many = "add_$many";

  # $DB::single = 1;

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

    my $q = $self->{$many} ||= [ ];

    wantarray ? @$q : $q;
  };

  my $setter = sub {
    my ($self, @new) = @_;
    $self->$clear_many();
    $self->$add_many(@new);
  };

  my $adder = sub {
    my ($self, @new) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    for my $new ( @new ) {
      confess("Invalid $many") unless ref($new);

      unless ( grep($_ eq $new, @$q) ) { # Recursion lock
	push(@$q, $new); # Recursion lock
	
	die("ARGGRHT") if grep(! $_, @$q);
	
	if ( $one ) {
	  $new->$set_one($self);
	}
      }
    }

    $self;
  };

  my $remover = sub {
    my ($self, @old) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    for my $old ( @old ) {
      confess("Invalid $many") unless ref($old);

      if ( grep($_ eq $old, @$q) ) { # Recursion lock
	@$q = grep($_ ne $old, @$q); # Recursion lock
	
	die("ARGGRHT") if grep(! $_, @$q);
	
	if ( $one ) {
	  $old->$set_one(undef);
	}
      }
    }

    $self;
  };

  my $clearer = sub {
    my ($self) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    my @old = @$q; # Recursion lock
    @$q = (); # Recursion lock

    if ( $one ) {
      for my $old ( @old ) { 
	$old->$set_one(undef);
      }
    }

    $self;
  };

  (
   "$many", $getter,
   "set_$many", $setter,
   "clear_$many", $clearer,
   "add_$many", $adder, 
   "remove_$many", $remover,
  )
}


sub __accessor_many_to_many
{
  my ($many, $many2) = @_;

  # confess("DOOOD!!!") if $many eq $many2;

  return () unless $many;

  my $add_many2 = "add_$many2";
  my $remove_many2 = "remove_$many2";
  my $clear_many = "clear_$many";
  my $add_many = "add_$many";

  # $DB::single = 1;

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

    my $q = $self->{$many} ||= [ ];

    # $DB::single = 1 if $many eq 'importedElement';

    wantarray ? @$q : $q;
  };

  my $setter = sub {
    my ($self, @new) = @_;

    $self->$clear_many();
    $self->$add_many(@new);
  };

  my $adder = sub {
    my ($self, @new) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    for my $new ( @new ) {
      confess("Invalid $many") unless ref($new);

      #confess("DOH!!!") if $new eq $self;

      unless ( grep($_ eq $new, @$q) ) { # Recursion lock
	push(@$q, $new); # Recursion lock
	
	#die("ARGGRHT") if grep(! $_, @$q);

	if ( $many2 ) {
	  # $new->$remove_many2($self);
	  $new->$add_many2($self);
	}
      }
    }

    $self;
  };

  my $remover = sub {
    my ($self, @old) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    for my $old ( @old ) {
      confess("Invalid $many") unless ref($old);

      if ( grep($_ eq $old, @$q) ) { # Recursion lock
	@$q = grep($_ ne $old, @$q); # Recursion lock
	
	# die("ARGGRHT") if grep(! $_, @$q);
	
	# confess("BONK!!!") if $self eq $old;

	if ( $many2 ) {
	  $old->$remove_many2($self);
	}
      }
    }

    $self;
  };

  my $clearer = sub {
    my ($self) = @_;
    
    my $q = $self->{$many} ||= [ ];
    
    my $old = $q; # Recursion lock
    $self->{$many} = [ ]; # Recursion lock

    if ( $many2 ) {
      for my $old ( @$old ) { 
	$old->$remove_many2($self);
      }
    }

    $self;
  };

  (
   "$many", $getter,
   "set_$many", $setter,
   "clear_$many", $clearer,
   "add_$many", $adder, 
   "remove_$many", $remover,
  )
}


####################################################################################
# Store the Association methods for AUTOLOAD
#

my %method;

sub __add_method
{
  my ($cls, @method) = @_;
  
  my $x = $method{$cls} ||= { };

  #local $" = ' '; print STDERR "$cls: @method\n";

  # $DB::single = 1 if grep($_ eq 'importedElement', @method);

  while ( @method ) {
    my ($op, $meth) = splice(@method, 0, 2);
   
    $x->{$op} = $meth;

    no strict 'refs';
    *{"${cls}::${op}"} = $meth;
  }

  $cls;
}


sub __define_class
{
  my ($cls) = @_;
  
  my $cls_name = ref($cls) || $cls;

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

  #$DB::single = 1;
  __add_method($cls, "isa$cls_name", sub { 1; });
  
  # Prevent UML::MetaMetaModel::Factory from attempting to autoload.
  no strict 'refs';
  ${"${cls}::VERSION"} = $UML::MetaMetaModel::VERSION;

  $cls;
}


####################################################################################
# "User" interface for meta-meta-model Association accessors
#

sub __fix_association_end_names
{
  if ( ! $_[0] && $_[1] ) {
    $_[0] = "$_[1]_";
  }
  if ( ! $_[1] && $_[0] ) {
    $_[1] = "$_[0]_";
  }
}


sub __one_to_many
{
 my ($one_cls, $one_role, $many_cls, $many_role) = @_;

 __fix_association_end_names($one_role, $many_role);

 $one_cls->__add_method(__accessor_many_to_one($many_role, $one_role));
 $many_cls->__add_method(__accessor_one_to_many($one_role, $many_role));
}

sub __many_to_many
{
 my ($many_cls, $many_role, $many2_cls, $many2_role) = @_;

 __fix_association_end_names($many2_role, $many_role);

 $many_cls->__add_method(__accessor_many_to_many($many2_role, $many_role));
 $many2_cls->__add_method(__accessor_many_to_many($many_role, $many2_role));
}


sub __many_to_one
{
 my ($many_cls, $many_role, $one_cls, $one_role) = @_;

 __fix_association_end_names($one_role, $many_role);

 $one_cls->__add_method(__accessor_many_to_one($many_role, $one_role));
 $many_cls->__add_method(__accessor_one_to_many($one_role, $many_role));
}

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


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

  $self->SUPER::initialize;

  # Use accessors to initialize.
  for my $key ( keys %$self ) {
    my $val = $self->{$key};
    my $meth;
    if ( ref($val) eq 'ARRAY' && $self->can($meth = "add_$key") ) {
      $self->{$key} = undef;
      $self->$meth(@$val);
    }
    elsif ( $self->can($meth = "set_$key") ) {
      $self->{$key} = undef;
      $DB::single = 1 if $val =~ /::Smc/;
      $self->$meth($val);
    }
  }

  $self;
}


use vars qw($AUTOLOAD);

our $AUTOLOAD_verbose = 0;


sub AUTOLOAD
{
  no strict 'refs';
  
  my ($self, @args) = @_;
  local ($1, $2);
  
  my ($package, $operation) = $AUTOLOAD =~ m/^(?:(.+)::)([^:]+)$/;
  return if $operation eq 'DESTROY';
  
  #$DB::single = 1;
  
  # warn __PACKAGE__ . ": package='$package' operation='$operation'";
  
  $DB::single = 1 if $operation eq 'importedElement';

  my ($method); # The autogenerated method.  
  if ( $method = $method{$package}{$operation} ) {
    $DB::single = 1; # Huzzah!
  }
  elsif ( $operation =~ /^isa([A-Z][A-Za-z_0-9]*)$/ ) {
    my $target_cls = $1;
    #$DB::single = 1;
    if ( $package =~ /::$target_cls$/ ) {
      $method = sub { 1 };
    } else {
      $method = sub { undef };
    }
  }
  elsif ( $operation =~ /^set_(\w+)$/ # and exists($self->{$1})
       ) {
    my $slot = $1;
    $method = sub {
      no warnings; # Use of uninitialized value in string ne
      if ( $_[0]->{$slot} ne $_[1] ) {
	$_[0]->{$slot} = $_[1];
      }
      $_[0];
    };
  }
  elsif ( @_ == 1 ) {
    warn "$_[0] -> {$operation} does not exist" 
    if ( $AUTOLOAD_verbose && ! exists($self->{$operation}) );
    
    $method = sub {
      $_[0]->{$operation};
    };
  }
  
  # Save the generated method and invoke it.
  if ( $method ) {
    *{$AUTOLOAD} = $method;
    # Tail call now.
    goto &$method;
  } else {
    use Carp qw(confess);

    confess('Exception::Object::UndefinedMethod: ' . 
	join(' ',
	    'package'   => $package,
	    'operation' => $operation,
	    'reciever'  => $self,
	    'arguments' => [ @args ],
	     )
	);
  }
}


my %__class;
sub __class
{
  my ($self) = @_;

  my $cls_name = ref($self) || $self;

  # $DB::single = 1;

  my $cls;
  unless ( $cls = $__class{$cls_name} ) {
    #$DB::single = 1;

    my $meta_name = $cls_name;
    $meta_name =~ s/^UML::MetaMetaModel:://;

    # Get the meta-meta-meta-model.  Hehe.
    my $model = UML::MetaMetaModel->model;

    # $DB::single = 1;

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

    #local $UML::MetaMetaModel::Util::namespace_trace = "Classifier $meta_name\n";
    ($cls) = Namespace_ownedElement_match
    ($model,
     # If I had used the same Package conventions in meta-meta-model
     # as the meta-model, I wouldn't need this name lookup hack.
     # I could use Namespace_ownedElement_name_().
     # I should fix it.
     sub {
       my ($x) = @_;
       $x->isaClassifier && $x->name eq $meta_name;
     },
     1,
     #1,
     );
    
    confess("Cannot find '$meta_name' in $model") unless $cls;

    $__class{$cls_name} = $cls;
  }

  $cls;
}


 #   if ( 0 && $many eq 'importedElement' ) {
 #     unless ( $self->{'.watch'}{$many} ) {
#	$self->{'.watch'}{$many} = 1;
#
#	my $x = \$self->{$many};
#	
#	#print STDERR "REF? $x ", ref($x), "\n";
#	# $DB::single = 1;##
#
#	use Tie::Watch;
#	Tie::Watch->new
#	(
#	 -debug => 1,
#	 -variable => \$self->{$many},
#	 -store => sub { 
#	   my ($w, $val) = @_;
#	   print STDERR "$self->$many changed to '$val'\n";
#	   $w->Store($val);
#	 },
#	 );
#
#	Tie::Watch->new
#	(
#	 -debug => 1,
#	 -variable => $self->{$many},
#	 -clear => sub { 
#	   my ($w) = @_;
#
#	   print STDERR "$self->$many clear\n";
#	   $w->Clear();
#	 },
#	 -push => sub { 
#	   my ($w, @new) = @_;
#
#
#	   print STDERR "$self->$many push @new\n";
#	   $w->Push(@new);
#	 },
#	 -store => sub { 
#	   my ($w, $key, $val) = @_;
#
#	   print STDERR "$self->$many store [$key] $val\n";
#	   $w->Store($key, $val);
#	 },
#	 );
#      }
#    }


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

