# -*- perl -*-
# DO NOT EDIT - This file is generated by UMMF; http://ummf.sourceforge.net 
# From template: $Id: PerlTemplate.txt,v 1.74 2004/08/01 03:50:07 kstephens Exp $

package UMMF::UML::MetaModel::__ObjectBase;

# This package provides base class support for generated Classifiers.

#use 5.6.1;
use strict;
use warnings;

#################################################################
# Version
#

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

=head1 NAME

UMMF::UML::MetaModel::__ObjectBase - base class package for Model UML 1.5 final/03-03-01;

=head1 SYNOPSIS

  use base qw(UMMF::UML::MetaModel::__ObjectBase);

=head1 DESCRIPTION

This package provides a base class for Perl modules generated from UML.

=head1 USAGE

=head1 EXPORT

  use UMMF::UML::MetaModel::__ObjectBase qw(:__ummf_array);

  __ummf_array_index
  __ummf_array_delete
  __ummf_array_delete_once
  __ummf_array_delete_each
  __ummf_array_delete_each_once


=head1 AUTHOR

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

=head1 SEE ALSO

L<UMMF::UML::MetaModel|UMMF::UML::MetaModel>

=head1 VERSION

$Revision: 1.74 $

=head1 METHODS

=cut 

#################################################################
# Supers
#

use base qw(Exporter);
our @EXPORT_OK = 
  qw(
     __ummf_array_index
     __ummf_array_delete
     __ummf_array_delete_once
     __ummf_array_delete_each
     __ummf_array_delete_each_once
    );
our %EXPORT_TAGS = (
		   '__ummf_array' => \@EXPORT_OK,
		   );

#################################################################
# Dependencies
#

use Carp qw(croak confess);
use Set::Object;

#################################################################
# Dynamic loading
#


my %__use;

=head2 C<__use>

  my $pkg = $self->__use('Some::Package');
  my $new_obj = $pkg->new(...);

Dynamically "use" a package.

=cut
sub __use
{
  my ($self, $cls) = @_;

  $cls ||= $self;

  unless ( $__use{$cls} ) {
    # $DB::single = 1;
    no strict 'refs';
    unless ( ${"${cls}::VERSION"} ) {
      use Carp qw(confess);
      # $DB::single = 1;
      eval "use $cls"; confess "Attempting use '$cls':\n$@" if $@;
      ${"${cls}::VERSION"} ||= -1;
    }
    $__use{$cls} = 1;
  }

  $cls;
}


#################################################################
# Introspection
#

=head2 C<__factory>

Returns the factory object for this Classifier's Model.

=cut
# 'emacs
sub __factory 
{ 
  __use('UMMF::UML::MetaModel')->factory;
}


=head2 C<__metamodel>

Returns the Model for this Classifier.

=cut
sub __metamodel 
{
  __use('UMMF::UML::MetaModel')->model;
}


my %__classifier;
=head2 C<__classifier>

  my $classifier = $obj_or_package->__classifier;

Returns the UML meta-model Classifier for an object or package.

=cut
sub __classifier 
{ 
  my ($self) = @_;
  
  my $name = ref($self) || $self;

  my $cls;
  unless ( $cls = $__classifier{$name} ) {
    use UMMF::UML::MetaMetaModel::Util qw(Namespace_ownedElement_name_);
    $cls = $__classifier{$name} = 
    Namespace_ownedElement_name_($self->__metamodel, $self->__model_name);
  }
  
  $cls;
}


=head2 C<__isAbstract>

  $package->__isAbstract;

Returns true if C<<$package>> is an abstract Classifer.

Abstract Classifiers are not instantiable via C<new>.

=cut
sub __isAbstract { 1 }


#################################################################
# Validation.
#

=head2 C<__validate_type>

  Some::Package->__validate_type($value);

Returns true if C<$value> is a valid representation of this Classifier.

=cut
sub __validate_type { 1 }


=head2 C<__typecheck>

  $value = Some::Package->__typecheck($value, $msg);

Generates an exception with C<$msg> if C<$value> is not a valid representaion of this Classifier.

Returns C<$value>.

=cut
sub __typecheck { $_[1] }


#################################################################
# Initialization.
#


=head2 C<__initialize>

Initialize all slots in an instance with initial values.

Called by C<new> and C<new_>.

=cut
sub __initialize { shift }


=head2 C<___initialize>

Initialize all slots of a particular Classifier's Attributes and AssociationEnds.

Called by C<__initialize>.

=cut
#'emacs
sub ___initialize { shift }


=head2 C<__create>

Calls all Generalizations' C<__create> methods.

Called by C<new>.

=cut
sub __create { shift }


=head2 C<___create>

Placeholder for user-specified <<create>> methods.

Called by C<__create>.

=cut
sub ___create { shift }


=head2 C<____create>

Hand-coded subclasses can override this method, but they must return C<$self>.

Called by C<new>.

=cut
sub ____create { shift }


#################################################################
# Extent.
#

=head2 C<$_id>

Variable incremented for each new instance created by C<__new_instance>.  The new ID is stored in the object's C<<$self->{_id}>> slot.

=cut
our $_id = 0;


=head2 C<$__new_instance_event>

Defines a subroutine that is called with each new instance created by C<__new_instance>.
Deprecated: See C<add___extent>.

=cut
our $__new_instance_event;


my @__extent;

=head2 C<add___extent>

  my $extent = UMMF::Object::Extent->new();
  UMMF::UML::MetaModel::__ObjectBase->add___extent($extent);

Register a new Extent observer object to this base class.

See also: L<UMMF::Object::Extent|UMMF::Object::Extent>.

=cut
sub add___extent
{
  my ($self, $extent) = @_;

  push(@__extent, $extent);
  $extent->add_classifier($self);
}


=head2 C<remove___extent>

  my $extent = ...;
  UMMF::UML::MetaModel::__ObjectBase->remove__extent($extent);

Deregister an Extent observer object from this base class.

=cut
sub remove___extent
{
  my ($self, $extent) = @_;

  @__extent = grep($_ ne $extent, @__extent);
  $extent->remove_classifier($self);
}


=head2 C<__extent_add_object>

  $obj = $package->__extent_add_object($obj, @args)

Cause all registered Extent objects to be messaged as C<<$extent->add_object($obj, @args)>>.

Extent observer implementors should note that C<$obj> may not be a fully initialized instance.

Called by C<__new_instance> and C<__clone>.

Overides of C<__new_instance> or C<__clone> should call C<<self->__extent_add_object($obj, ...)>>.

Returns C<$obj>.

=cut
sub __extent_add_object
{
  my ($self, $obj, @args) = @_;

  # Deprecated: use add___extent.
  $__new_instance_event->($self, @args) if $__new_instance_event;

  for my $extent ( @__extent ) {
    $extent->add_object($self, @args);
  }

  $obj;
}


#################################################################
# Instantiation.
#

=head2 C<__new_instance>

  my $obj = $package->__new_instance(%attrs);

Returns a new instance, without initializing.

New instances get a unique id stored in C<<$obj->{'_id'}>>.

=cut
sub __new_instance
{
  my ($self, %attrs) = @_;

  $attrs{'_id'} ||= ++ $_id;
  $self->__extent_add_object(bless(\%attrs, ref($self) || $self), '__new_instance');
}


=head2 C<new>

  my $obj = $package->new(%attrs);

Returns a new, initialized instance using keyword values.

Throws exception if C<<$package->__isAbstract>>.

Calls C<<$package->__new_instance(%attrs)>> to create instance, 
then calls C<<$obj->__initialize()->__create()>> to complete initialization.

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

  # $DB::single = 1;

  # Abstract Classifiers are not instantitable.
  confess("$self isAbstract") if $self->__isAbstract;

  # Allow __initialize method to delegate instantation.
  $self->__new_instance(@opts)->__initialize->__create()->____create();
}


=head2 C<new_>

  my $obj = $package->new_(@opts);

Returns a new, initialized instance using a matching <<create>> Method.

Throws exception if C<<$package->__isAbstract>>.

Calls C<<$package->__new_instance()>> to create instance without any initialization keyword values
then calls C<<$obj->__initialize()->__create(@opts)>> to complete initialization.

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

  # $DB::single = 1;

  # Abstract Classifiers are not instantitable.
  confess("$self isAbstract") if $self->__isAbstract;

  # Allow __initialize method to delegate instantation.
  $self->__new_instance()->__initialize->__create(@opts);
}


=head2 C<__clone>

  my $clone = $obj->__clone();

Returns a new cloned instance.

Clones get a unique id stored in C<<$clone->{'_id'}>>.

=cut
sub __clone
{
  my ($self) = @_;

  $self = bless({ %$self }, ref($self));

  $self->{'_id'} .= '.' . ++ $_id; # Fix me!!!

  # Clone all attributes.
  for my $key ( keys %$self ) {
    my $v = \$self->{$key};
    if ( ref($$v) eq 'ARRAY' ) {
      $$v = [ @$$v ];
    } elsif ( ref($$v) eq 'HASH' ) {
      $$v = { %$$v };
    } elsif ( ref($v) eq 'Set::Object') {
      $$v = Set::Object->new(($$v)->members);
    }
  }

  $self->__clone_deepen;

  $self->__extent_add_object($self, '__clone');
}


=head2 C<__clone_deepen>

Further deepens any composed objects in a instance.
Subclasses may override and call SUPER.

=cut
sub __clone_deepen
{
  my ($self) = @_;

  # Clone all the aggegrated Associations.

  $self;
}


=head2 C<__ummf_disassemble>

$obj->__ummf_disassemble();

Dissassembles an object graph, recursively, by traversing any Attributes or AssoicationEnds.

Only objects that respond to C<__ummf_disassemble> are affected.

=cut

sub __ummf_disassemble ($)
{
  no warnings;

  my ($self) = @_;

  # untie(%$self); # Dont allow Tangram OnDemand start pulling things in.

  # print STDERR "__ummf_disassemble $self\n";

  # Get list of objects to traverse.
  my @x;
  for my $k ( keys %$self ) {
    untie $self->{$k}; # Dont allow Tangram::*OnDemand start pulling things in.
    my $v = $self->{$k};

    if ( my $ref = ref($v) ) {
      if ( $ref eq 'Set::Object' ) {
	push(@x, $v->members);
      }
      elsif ( $ref eq 'ARRAY' ) {
	push(@x, @$v);
      }
      elsif ( $ref eq 'HASH' ) {
	push(@x, values %$v);
      }
      else {
	push(@x, $v);
      }
    }
  }

  # Only objects that can disassemble.
  @x = grep(UNIVERSAL::can($_, '__ummf_disassemble'), @x);

  # Empty $self; avoids recursion.
  %$self = ();

  # Process.
  for $self ( @x ) {
    $self->__ummf_disassemble;
  }
}



############################################################################
# Exported Helpers
#


=head2 __ummf_array_index

  my $i = __ummf_array_index(\@a, $elem);

Returns the first index of C<$elem> in C<@a> or undef.

=cut
sub __ummf_array_index
{
  my ($a, $e) = @_;

  my $i = 0;
  for my $ae ( @$a ) {
    return $i if $ae eq $e;
    ++ $i;
  }
  undef; # Not found.
}


=head2 __ummf_array_delete

  __ummf_array_delete(\@a, $elem);

Deletes all C<$elem> in C<@a>.

=cut
sub __ummf_array_delete
{
  my ($a, $e) = @_;

  my $i = 0;
  while ( $i < @$a ) {
    if ( $a->[$i] eq $e ) {
      splice(@$a, $i, 1);
      next;
    }
    ++ $i;
  }
}


=head2 __ummf_array_delete_once

  __ummf_array_delete_once(\@a, $elem);

Deletes the first C<$elem> in C<@a>.

=cut
sub __ummf_array_delete_once
{
  my ($a, $e) = @_;

  my $i = 0;
  while ( $i < @$a ) {
    if ( $a->[$i] eq $e ) {
      splice(@$a, $i, 1);
      last;
    }
    ++ $i;
  }
}


=head2 __ummf_array_delete_each

  __ummf_array_delete_each(\@a, \@elem);

Deletes each element in C<@elem> in C<@a>.

=cut
sub __ummf_array_delete_each
{
  my ($a, $es) = @_;
  for my $e ( @$es ) {
    __ummf_array_delete($a, $e);
  }
}


=head2 __ummf_array_delete_each

  __ummf_array_delete_each(\@a, \@elem);

Deletes each first element in C<@elem> in C<@a>.

=cut
sub __ummf_array_delete_each_once
{
  my ($a, $es) = @_;
  for my $e ( @$es ) {
    __ummf_array_delete_once($a, $e);
  }
}


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


use vars qw($AUTOLOAD);

our $AUTOLOAD_verbose = 0;


sub __true { 1 };
sub __false { 1 };


my %__isa;


=head2 C<AUTOLOAD>

Autoloader to simplify isa<Classifier>() handling of disjoint types.
This also prints a verbose stack trace for an unimplemented method.

=cut
sub AUTOLOAD
{
  no strict 'refs';
  
  my ($self, @args) = @_;
  local ($1, $2);
  
  my ($package, $operation) = $AUTOLOAD =~ m/^(?:(.+)::)([^:]+)$/;
  return if $operation eq 'DESTROY';
  
  my ($method); # The autogenerated method.
  
  #$DB::single = 1;
  
  # warn __PACKAGE__ . ": package='$package' operation='$operation'";
  
  # Handle isa<Classifier> automagically.
  # better check your spelling!!
  if ( $self && $operation =~ /^isa[A-Z]/ ) {
    my $ref = ref($self) || $self;

    # Install true method in $self class, not any superclass.
    $AUTOLOAD = "${ref}::${operation}";

    # Check a false cache.
    my $method = $__isa{$AUTOLOAD};
    unless ( defined $method ) {
      my @x = @{"${ref}::ISA"};
      while ( @x ) {
	my $x = pop @x;
	if ( UNIVERSAL::can($x, $operation) && $x->$operation ) {
	  $method = \&__true;
	  last;
	}
	push(@x, @{"${x}::ISA"});
      }
      $__isa{"$ref\t$operation"} = 0;
    }

    # Do not install false method, so multiple-inheritance will work.
    # print STDERR "$ref \t $operation \t = $method->()\n";
    return undef unless $method;
  }
  
  # Install the generated method and invoke it.
  if ( $method ) {
    *{$AUTOLOAD} = $method;
    # Tail call.
    goto &$method;
  } else {
    use Carp qw(confess);
    use Data::Dumper;

    # Nice feature:
    # Print a stack trace if an undefined method is called.
    # Why doesn't Perl always do this?
    my $e = 
    {
      'type'      => 'UndefinedMethod',
      'package'   => $package,
      'operation' => $operation,
      'receiver'  => "$self",
      'arguments' => [ map("$_", @args) ],
    };

    confess(Data::Dumper->new([$e],[qw(EXCEPTION)])->Dump);
  }
}  


1; # Is true!!!

