package UML::Export::Perl;

use 5.6.1;
use strict;

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

=head1 NAME

UML::Export::Perl - A code generator for Perl.

=head1 SYNOPSIS

  use base qw(UML::Export::Perl);

  my $coder = UML::Export::Perl->new('output' => *STDOUT);
  my $coder->code($model);

=head1 DESCRIPTION

This package allow UML models to be represented as Perl code.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

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

=head1 VERSION

$Revision: 1.6 $

=head1 METHODS

=cut

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

use base qw(UML::Export);

use UML::MetaMetaModel::Util qw(:all);
use Data::Dumper;

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


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

  $self->{'packagePrefix'} ||= '';
  $self->{'defaultSuperclass'} ||= [ ];
  $self->{'override'} ||= { };

  $self->SUPER::initialize;
}


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

sub export_Model
{
  my ($self, $model) = @_;

  my $out = $self->{'output'};

  eval {
    $DB::single = 1;
    my $model_package = $self->{'packagePrefix'};

    # Get the name for a base package.
    my $model_package_file = $self->package_name_to_file_name($model_package);

    
    my $base_package_name = join('::', grep(length,
						$self->{'packagePrefix'},
						'__ObjectBase',
					    ));
    my $base_package_file = $self->package_name_to_file_name($base_package_name);

    $self->{'base_package_name'} = $base_package_name;


    # Build a factory map.
    my $use = "\nuse $base_package_name;\n";
    my $factory_map = [ ];
    for my $cls ( Namespace_classifier($model) ) {
      my $cls_name = $cls->name;
      my $cls_name_q = ModelElement_name_qualified($cls);
      my $pkg_name = $self->export_Classifier_name($cls);
      push(@$factory_map,
	   $cls_name => $pkg_name,
	   $cls_name_q => $pkg_name,
	   );
      $use .= "use $pkg_name;\n";
    }

    # Perl code, please.
    $factory_map = Data::Dumper
    ->new([$factory_map],[qw($factory_map)])
    ->Indent(1)
    ->Purity(1)
    ->Useqq(1)
    ->Dump;

    # Now perl code for the meta model.
    my $metamodel = $model;
    $metamodel = Data::Dumper
    ->new([$metamodel],[qw($model)])
    ->Indent(1)
    ->Purity(1)
    ->Useqq(1)
    ->Dump;

    # Generate the top level package.
    $out->print
    (
     qq{
#//-// FILE BEGIN $model_package_file
       package $model_package;

       # Import them all!!!
       $use;

       my $factory_map;
       sub factory_map { \$factory_map; }
       
       my $metamodel;
       sub model { \$model; }
       
       my \$factory;
       sub factory {
	 my \$self = shift;
	 unless ( \$factory ) {
	   use UML::MetaMetaModel::Factory;
	   \$factory = UML::MetaMetaModel::Factory->new('classMap' => \$self->factory_map);
	 }
	 \$factory;
       }

       1; # Is true!!!
#//-// FILE END $model_package_file 
     });

    # Add the ultimate base class.
    ####################################################################################
    # Since the code generated here relies on a specific base class to handle
    # things like the AUTOLOAD of isa<Classifier>, object instantiation and
    # other hooks, its seem a good idea to simply package it up.  So that
    # the generated code has no external dependencies.
    #

    my $base_package = 
q{
#//-// FILE BEGIN %%%base_package_file%%%%
package %%%base_package%%%;

use 5.6.1;
use strict;
# use warnings;

############################################################################
# See UML::Code::Perl for dependencies.
#

# Returns true if a value is a valid representation of
# this Class.
sub __validate { 1 }

# Generates an exception if a value is not a valid representaion
# of this class.
sub __typecheck { $_[1] }

# Initialize all slots in an instance with initial values.
sub __initialize { shift }

# Initialize all associations from values specified in the constructor.
sub __initialize_associations { shift }

my %__autouse;
sub __autouse
{
  my ($self, $cls) = @_;

  $cls ||= $self;

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

  $cls;
}


# Return the metamodel for this model.
sub __metamodel 
{
  use %%%model_package%%%; 
  %%%model_package%%%->model;
}

# Returns a new instance, without initializing the associations.
sub __new_instance
{
  my ($self, %attrs) = @_;
  $self = bless(\%attrs, ref($self) || $self);
  $self->__initialize;
  $self;
}

# Returns a new instance, initializing the associations.
sub new
{
  my ($self, @opts) = @_;
  $self = $self->__new_instance(@opts);
  my $x = $self->__initialize;
  # Allow __initialize method to delegate instantation.
  if ( $x eq $self ) {
    $self->__initialize_associations;
  }
  $x;
}

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

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';
  
  my ($method); # The autogenerated method.
  
  #$DB::single = 1;
  
  # warn __PACKAGE__ . ": package='$package' operation='$operation'";
  
  # Handle isa<Classifier> automagically.
  # better check your spelling!!
  # IMPLEMENT: Check the method name against the list of Classifiers
  # in the Model.
  if ( $operation =~ /^isa[A-Z]/ ) {
    # $DB::single = 1;
    $method = sub { undef };
  }
  
  # Save 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 = 
    [
     'UndefinedMethod',
     'package'   => $package,
     'operation' => $operation,
     'receiver'  => "$self",
     'arguments' => [ map("$_", @args) ],
     ];

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

1; # Is true!!!

#//-// FILE END %%%base_package_file%%%
};

    $base_package =~ s/%%%+base_package%%%+/$base_package_name/esg;
    $base_package =~ s/%%%+base_package_file%%%+/$base_package_file/esg;
    $base_package =~ s/%%%+model_package%%%+/$model_package/esg;

    $out->print($base_package);

    # Just use the super Classifier iteration.
    $self->SUPER::export_Model($model);
  };
  if ( $@ ) {
    die("While processing model base class: $@");
  }

  $self;
}


sub package_name
{
  my ($self, @elem) = @_;

  @elem = grep(length, @elem);
  grep(s/[^a-z0-9_]/_/isg, @elem);

  my $x = join('::', @elem);

  $x;
}

sub package_name_to_file_name
{
  my ($self, $class) = @_;

  my $file = $class;
  $file =~ s/::/\//sg;
  $file .= '.pm';
  
  $file;
}

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

  my $out = $self->{'output'};
 
  eval {
    my $class = $self->export_Classifier_name($cls);
    my $file = $self->package_name_to_file_name($class);

    $out->print("#//-// FILE BEGIN $file\n");
    my $package = $class;
    $package =~ s/::[^:]+$//s;

    $out->print( "package $class;\n\n");
    $out->print( "#################################################################\n\n" );
    
 
    $out->print( q{our $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };}, "\n\n");

   
    $out->print( "use strict;\n");
    $out->print( "use warnings;\n\n");

    # Compute a list of exports.
    my @exports;
    $self->{'exports'} = \@exports;
    $self->export_Classifier_phase($cls, 'exports');
    
    my @supers = (
		  map($self->export_Classifier_name($_),
		      map($_->parent,
			  $cls->generalization,
			  )
		      )
		  );
    unless ( @supers ) {
      push(@supers, 
	   $self->{'base_package_name'},
	   @{$self->{'defaultSuperclass'}},
	   );
    }
    if ( @exports ) {
      push(@supers, 'Exporter');
    }

    if ( @supers ) {
      local $" = ' ';
      $out->print( "use base qw(@supers);\n\n" );
    }

    if ( @exports ) {
      local $" = ' ';
      $out->print( "our \@EXPORT_OK = qw(@exports);\n\n" );
    }
    
    # Inheritance semantics for reuse of meta-meta model.
    my $class_name = $cls->name;
    my $cls_name = ModelElement_name_qualified($cls);

    # Reflection support.
    $out->print("sub __model_name { '$cls_name' }\n\n");

    $out->print(
q{
  my $__class;
  sub __class 
{ 
  my ($self) = @_;
  
  unless ( $__class ) {
    use UML::MetaMetaModel::Util qw(Namespace_ownedElement_name_);
    $__class = Namespace_ownedElement_name_($self->__metamodel, $self->__model_name);
  }
  
  $__class;
}
}
);


    # Inheritance semantics for reuse of meta-meta model.
    my $class_name = $cls->name;
    $out->print("sub isa$class_name { 1 }\n\n");

    my $class_name = $cls_name;

    if ( $class_name ne $cls->name ) {
      $class_name =~ s/::/__/sg;
      $out->print("sub isa$class_name { 1 }\n\n");
    }

    my $override = $self->{'override'}{$cls_name};

    # Generate validate.
    my $validate;
    $validate = $override->{'validate'} if ( $override );

    # Generate valid EnumerationLiteral names.
    if ( $cls->isaEnumeration ) {
      # $DB::single = 1;

      $out->print('my %__literal = (', 
		  join(', ',
		       map("'$_' => '$_'", 
			   map($_->name, $cls->literal)
			   )
		       ), ");\n\n");
      $validate = q{ $__literal{$x} };
    }

    $validate = qq{
      # Use \$x->isa\$Class???
      UNIVERSAL::isa(\$x, '$class')
    } unless $validate;

    $out->print("sub __validate\n");
    $out->print("{\n");
    $out->print('  my ($self, $x) = @_;', "\n");
    $out->print("  $validate;\n");
    $out->print("}\n\n");

    $out->print("sub __typecheck\n");
    $out->print("{\n");
    $out->print('  my ($self, $x, $msg) = @_;', "\n");
    $out->print(qq{  die("typecheck: \$msg: type '$class': value '\$x'")});
    $out->print('  unless __validate($self, $x);', "\n");
    $out->print('  $x;', "\n");
    $out->print("}\n\n");

    if ( $override && $override->{'primitive'} ) {
      $out->print("sub new\n");
      $out->print("{\n");
      $out->print('  my ($self, @args) = @_;', "\n");
      $out->print('  my $x = pop(@args);', "\n");
      $out->print('  $x = ', $override->{'construct'}, ";\n") if $override->{'construct'};
      $out->print('  __typecheck($self, $x);', "\n");
      $out->print('  $x;', "\n");
      $out->print("}\n\n");
    }
    elsif ( $cls->isaEnumeration ) {
      $out->print("sub new\n");
      $out->print("{\n");
      $out->print('  my ($self, @args) = @_;', "\n");
      $out->print('  my $x = pop(@args);', "\n");
      $out->print('  die("Invalid EnumerationLiteral") unless $__literal{$x};', "\n");
      $out->print('  $x;', "\n");
      $out->print("}\n\n");

      # Generate EnumerationLiteral methods.
      $self->export_Classifier_phase($cls, 'accessor');
    }  
    elsif ( $override && $override->{'primitive'} ) {
      $out->print("sub new\n");
      $out->print("{\n");
      $out->print('  my ($self, @args) = @_;', "\n");
      $out->print('  my $x = pop(@args);', "\n");
      $out->print('  $x = ', $override->{'construct'}, ";\n") if $override->{'construct'};
      $out->print('  __typecheck($self, $x);', "\n");
      $out->print('  $x;', "\n");
      $out->print("}\n\n");
    } else {
      my $do_it = sub {
	my ($phase) = @_;
	$out->print("sub __$phase\n");
	$out->print("{\n");
	$out->print('  my ($self) = @_;', "\n\n");
	#$out->print('  $DB::single = 1', "\n\n");
	if ( @supers ) {
	  for my $super ( @supers ) {
	    $out->print('  $self->', $super, "::__$phase;", "\n");
	  }
	  $out->print("\n");
	}
	
	$self->export_Classifier_phase($cls, $phase);
	
	$out->print("\n");
	$out->print('  $self;', "\n");
	$out->print('}', "\n\n");
      };
      
      # Initialize attributes.
      $do_it->('initialize');
      
      # Resolve associations.
      $do_it->('initialize_associations');
      
      # Generate accessors.
      $self->export_Classifier_phase($cls, 'accessor');
    }

    $out->print( "\n\n1;\n\n" );

    $out->print("#//-// FILE END $file\n");
    
  };
  if ( $@ ) {
    die("Classifier: " . ModelElement_name_qualified($cls) . ":\n$@");
  }

  $self;
}


sub export_Classifier_phase
{
  my ($self, $cls, $phase) = @_;

  my $out = $self->{'output'};

  # $DB::single = $phase eq 'enumeration';

  # Generate accessors for each literal.
  if ( $cls->isaEnumeration ) {
    # $DB::single = 1;
    for my $literal ( $cls->literal ) {
      $out->print( $self->export_EnumerationLiteral($literal, $phase));
    }
  }
  
  # Is it an AssociationClass?
  if ( $cls->isaAssociation ) {
    # Generate code for each AssociationEnd.
    for my $end ( $cls->connection ) {
      $out->print("# AssociationClass Link => ", $self->export_Classifier_name($end->participant), ".", $end->name, "\n");
    }
  }

  # Generate accessors for each association end point
  # where this classifier participates.
  for my $cls_end ( $cls->association ) {
    # $DB::single = 1;
    $out->print( $self->export_AssociationEnd($cls_end, $phase));
  }
  
  # Generate accessors for each attribute.
  for my $attr ( grep($_->isaAttribute, $cls->feature) ) {
    $out->print( $self->export_Attribute($attr, $phase));
  }
  
  
  $self;
}


sub export_typecheck
{
  my ($self, $msg, $type, $expr) = @_;

  $type = $self->export_Classifier_name($type);

  my $code = qq{
    \$self->__autouse('$type')
    ->__typecheck($expr, '$msg');
  };

  $code;
}


sub export_Attribute
{
  my ($self, $attr, $phase) = @_;

  my $code = '';

  return $code unless grep($phase eq $_, 'initialize', 'accessor');

    
  my $name = $attr->name;
  eval {
    my $type = $attr->type;
    my $multi = $attr->multiplicity;

    $multi = Multiplicity_asString($multi);
    die('multi is ref') if ref($multi);

    my $initialValue = $attr->initialValue;

    my $typecheck = $self->export_typecheck($name, $type, '$new');
    
    my $type_name = ModelElement_name_qualified($type);
    $code .= "# Attribute " . $attr->toId . " name = $name, type = $type_name, multiplicity = $multi\n";
    
    my $loc = "\$self->{'$name'}";
    if ( $multi eq '1' or $multi eq '0..1' ) {
      if ( $phase eq 'initialize' ) {
	my $do_init = $initialValue ? "\$loc = $initialValue" : '';

	$code .=
	qq{
	  if ( exists $loc ) {
	    my \$x = $loc;
	    $loc = undef;
	    \$self->set_$name(\$x);
	  } else {
	    $do_init;
	  }
	};
      } else {
	$code .= qq{
	  sub $name {
	    my (\$self) = \@_;

	    $loc;
	  }
	  sub set_$name {
	    my (\$self, \$new) = \@_;

	    $typecheck;

	    $loc = \$new;

	    \$self;
	  }
	};
      }
    } else {
      if ( $phase eq 'initialize' ) {
	# Unneeded?
	# $code .= "$loc = [ ] unless defined $loc;";
	$code .= "$loc = undef unless exists $loc;";
      } else {
	$code .= qq{
	  sub $name {
	    my (\$self) = \@_;
	    
	    my \$x = $loc;
	    wantarray ? \@{\$x} : \$x;
	  }
	  sub set_$name {
	    my (\$self, \@new) = \@_;
	    
	    for my \$new ( \@new ) { 
	      $typecheck;
	    }
	    
	    $loc = [ \@new ];
	    
	    \$self;
	  }
	  sub add_$name {
	    my (\$self, \@new) = \@_;
	    
	    for my \$new ( \@new ) { 
	      $typecheck;
	    }
	    push(\@{$loc ||= [ ]}, \@new);
	    
	    \$self;
	  }
	  sub remove_$name {
	    my (\$self, \@new) = \@_;
	    for my \$new ( \@new ) { 
	      $typecheck;
	    }
	    my \$x = $loc ||= [ ];
	    for my \$new ( \@new ) {
	      \@\$x = grep(\$_ ne \$new, \@\$x);
	    }
	    
	    \$self;
	  }
	};
      }
    }
    
    $code .= "\n";
  };
  if ( $@ ) {
    die("Attribute $name:\n$@");
  }

  $code;
}


sub export_AssociationEnd
{
  my ($self, $cls_end, $phase) = @_;

  my $code = '';

  return $code unless grep($phase eq $_, 'initialize', 'accessor', 'initialize_associations');

  eval {
    my $assoc = $cls_end->connection_;  # UGLY!!!

    # Create an attribute and accessors for each
    # AssociationEnd that is "opposite" the one attached
    # to this class.
    for my $end ( AssociationEnd_opposite($cls_end) ) {
      my $name = $end->name;

      
      $name ||= $cls_end->name . '_'; # UGLY!!!!

      if ( $name ) {
	my $type = $end->participant;
	my $multi = $end->multiplicity;
	
	$multi = Multiplicity_asString($multi);
	die('multi is ref') if ref($multi);

	# The association relationship with the otherside 
	# must be maintained.
	my @others = grep($_ ne $end, $assoc->connection);
	@others = map($self->export_AssociationEnd_other($_), @others);
	
	my $others = join("\n\n", @others);
	
	my $typecheck = $self->export_typecheck($name, $type, '$new');

	my $loc = "\$self->{'$name'}";
	
	my $type_name = ModelElement_name_qualified($type);
	$code .= "# AssociationEnd " . $end->toId . " name = $name, type = $type_name multiplicity = $multi\n";
	
	if ( $multi eq '1' or $multi eq '0..1' ) {
	  # Allow single multiplicity assocations to have undefined values,
	  # so objects can be re-associated with new objects.
	  #
	  # Dont allow ! defined($new) in add or remove methods for
	  # 2 or more multiplicities.
	  #
	  $typecheck = '! defined($new) || ' . $typecheck;

	  if ( $phase eq 'initialize' ) {
	    $code .= "$loc = undef unless exists $loc;";
	  } 
	  elsif ( $phase eq 'initialize_associations' ) {
	    $code .= qq{
	      if ( defined $loc ) {
		my \$x = $loc;
		$loc = undef;
		\$self->set_$name(\$x);
	      }
	    };
	  }
	  else {
	    $code .= qq{
	      sub $name {
		my (\$self) = \@_;
		
		$loc;
	      }
	      sub set_$name {
		my (\$self, \$new) = \@_;

		no warnings;

		my \$old;
		if ( (\$old = $loc) ne \$new ) { # Recursion lock
		  $typecheck;
		  $loc = \$new;        # Recursion lock
		  $others;
		}

		\$self;
	      }
	    };
	  }
	} else {
	  if ( $phase eq 'initialize' ) {
	    # $code .= "$loc = [ ] unless defined $loc;";
	    $code .= "$loc = undef unless exists $loc;";
	  }
	  elsif ( $phase eq 'initialize_associations' ) {
	    $code .= qq{
	      if ( defined $loc && \@{$loc}) {
		my \$x = $loc;
		$loc = [ ];
		\$self->add_$name(\@\$x);
	      }
	    };
	  } else {
	    my $typecheck_remove = $self->export_typecheck($name, $type, '$old');
	    
	    $code .= qq{
	      sub $name {
		my (\$self) = \@_;
		
		my \$x = $loc ||= [ ];
		wantarray ? \@{\$x} : \$x;
	      }
	      sub set_$name {
		my (\$self, \@new) = \@_;
		
		\$self->clear_$name;
		\$self->add_$name(\@new);
	      }
	      sub add_$name {
		my (\$self, \@new) = \@_;
		
		my \$x = $loc ||= [ ];
		my \$old; # Place holder

		for my \$new ( \@new ) {
		  unless ( grep(\$_ eq \$new, \@\$x) ) { # Recursion lock
		    $typecheck;
		    push(\@{\$x}, \$new);                # Recursion lock
		    $others;
		  }
		}
		
		\$self;
	      }
	      sub remove_$name {
		my (\$self, \@new) = \@_;

		my \$x = $loc ||= [ ];
		my \$new; # Place holder

		for my \$old ( \@new ) {
		  if ( grep(\$_ eq \$old, \@\$x) ) {   # Recursion lock
		    $typecheck_remove;
		    \@\$x = grep(\$_ ne \$old, \@\$x); # Recursion lock
		    $others;
		  }
		}
		
		\$self;
	      }
	      sub clear_$name {
		my (\$self) = \@_;

		my \$x = $loc ||= [ ];
		my \$new; # Place holder

		$loc = [ ];              # Recursion lock
		for my \$old ( \@\$x ) { # Recursion lock
		  $others;
		}
		
		\$self;
	      }
	      
	    };
	  }
	}
      }
    }
 
    $code .= "\n";

  };
  if ( $@ ) {
    die("AssocationEnd " . $cls_end->toString . ":\n$@");
  }


  $code;
}


sub export_AssociationEnd_other
{
  my ($self, $end) = @_;

  my $code = '';

  my $name = $end->name;

  eval {
    if ( $name ) {
      my $type = $end->participant;
      my $multi = $end->multiplicity;

      $multi = Multiplicity_asString($multi);

      die('multi is ref') if ref($multi);

      my $type_name = ModelElement_name_qualified($type);
      $code .= "# AssociationEnd " . $end->toId . " name = $name, type = $type_name, multiplicity = $multi\n";
 
      if ( $multi eq '1' or $multi eq '0..1' ) {
	$code .= qq{
	  \$old->set_$name(\$self) if \$old;
	  \$new->set_$name(\$self) if \$new;
	};
      } else {
	$code .= qq{
	  \$old->remove_$name(\$self) if \$old;
	  \$new->add_$name(\$self) if \$new;
	};
      }
    }
  };
  if ( $@ ) {
    die("AssocationEnd " . $end->toString . ":\n$@");
  }


  $code;
}


sub export_EnumerationLiteral
{
  my ($self, $literal, $phase) = @_;

  my $code = '';

  # $DB::single = 1;
  return $code unless grep($phase eq $_, 'accessor', 'exports');
 
  my $name = $literal->name;
  my $NAME = uc($name);

  if ( $phase eq 'exports' ) {
    push(@{$self->{'exports'}}, $NAME); 
  } else {
    $code .= "# EnumerationLiteral \n";
    $code .= "sub $NAME { '$name' }\n\n";
  }

  $code;
}
 

sub export_Classifier_name
{
  my ($self, $cls) = @_;
  
  my $x = join('::', 
	       grep(length,
		    $self->{'packagePrefix'},
		    scalar ModelElement_name_qualified($cls)
		    )
	       );

  # In case ModelElement names have spaces, which appears to be possible.
  # Perl doesn't like spaces in identifiers.
  $x =~ s/\s+/_/sg;
  
  $x;
}


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

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

