package UML::Export::Template;

use 5.6.1;
use strict;

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

=head1 NAME

UML::Export::Template - A code generator using Template Toolkit.

=head1 SYNOPSIS

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

=head1 DESCRIPTION

This package allow UML models to be quickly processed into other forms.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 TO DO

=over 4

=back

=head1 AUTHOR

Kurt Stephens, ks.perl@kurtstephens.com 2003/05/02

=head1 SEE ALSO

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

=head1 VERSION

$Revision: 1.13 $

=head1 METHODS

=cut

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

use base qw(UML::Export);

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

use UML::MetaMetaModel::Util qw( :all );
use Carp qw(confess);

use Template;
use Template::Constants qw( :debug );

use File::Basename;

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


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

  $self->SUPER::initialize;

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

  $self;
}


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

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

  $model = $self->model_filter($model);

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

  # $Template::Parser::DEBUG = 1;

  my $vars = $self->template_vars($model);
  my $file = $self->template_file;
  my $template = $self->template;

  $file = basename($file);

  $DB::single = 1;
  my $result = $template->process($file, $vars, $out);
  die $@ if $@;

  #$DB::single = 1;
  #$out->print($result);

  $self;
}


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


=head2 template_file

  $self->template_file;

Returns the name of the Template to be used.

If C<$self->{'template_file'}> is not defined, defaults
to the file name C<ref($self) . '.txt'>.
 
=cut
sub template_file
{
  my ($self) = @_;

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

  $file =~ s@::@/@sg;
  $file .= '.pm';
  $file = $INC{$file};
  $file =~ s/\.pm$/Template.txt/;

  use File::Spec;
  $file = File::Spec->rel2abs($file);

  # $DB::single = 1;

  $file = $self->{'template_file'} ||= $file;

  $file;
}


=head2 template_confg

Returns the Template configuration hash.

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

  my $x = $self->{'template_config'} ||=
  {
      'INCLUDE_PATH'  => [ dirname($self->template_file) ],
      'INTERPOLATE'   => 0, # Do not interpolate $var
      # 'RELATIVE'      => 1,
      'POST_CHOMP'    => 1,
      # 'PRE_PROCESS' => 'header',
      'EVAL_PERL'     => 1,

      'COMPILE_EXT'   => '.ttc',
      'COMPILE_DIR'   => "/tmp/$ENV{USER}.ttc",

      # 'DEBUG'         => DEBUG_ALL, # DEBUG_PARSER | DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_PROVIDER,
  };

  {
    use File::Path;
    mkpath([ $x->{'COMPILE_DIR'} ], 1); 
  }

  $x;
}


=head2 template

Returns a cached Template object.

=cut
sub template
{
  my ($self) = @_;
  
  my $t = $self->{'template'} ||= 
  Template->new($self->template_config) || die Template->error(), "\n";
  
  $t;
}


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


sub object_value
{
  my ($self, $obj, $key) = @_;

  my $x = $obj->key();

  $x;
}


sub __id
{
  my ($self, $obj) = @_;

  # print STDERR "__id($obj)\n";

  my $id = $obj->{'_id'};
  unless ( $id ) {
    local $1;
    $obj =~ /[(]([^\)]+)[)]/;
    $id = $1 || $obj;
  }

  my $name = $obj->{'name'};

  my $name_q = ModelElement_name_qualified($obj);
  my $name_ = $name;
  my $name_q_ = $name_q;
  
  $name_ =~ s/[^a-z_0-9]/_/sgi;
  $name_q_ =~ s/[^a-z_0-9]/_/sgi;
  
  my $namespace = $obj->namespace;
  if ( $namespace ) {
    $namespace = { $self->__id($namespace) }; 
  }

  my %vals = 
  (
   'obj' => $obj,
   'id' => $id,
   'name' => $name,
   'Name' => ucfirst($name),
   'NAME' => uc($name),
   'name_q' => $name_q,
   'name_' => $name_,
   'name_q_' => $name_q_,

   ($obj->isaNamespace 
    ?
    (
     'package' => $self->package_name($obj),
     'package_file' => $self->package_file_name($obj),
     
     'implementation_file' => $self->package_file_name($obj), # IMPLEMENT
     'interface_file' => $self->package_file_name($obj), # IMPLEMENT
     
     ) 
    : 
    ()
    ),
   'namespace' => $namespace,

   # Template variables beginning with '_' do not work.
   'phantom_obj' => $obj->{'_phantom'},
   'phantom' => $obj->{'_phantom'} && ($self->package_name($obj->{'_phantom'}) || $obj->{'_phantom'}),
   
   'trace_obj' => $obj->{'_trace'},
   'trace' => $obj->{'_trace'} && ($self->package_name($obj->{'_trace'}) || $obj->{'_trace'}),
     
   );

  #print STDERR "__id($obj)->namepace = $namespace\n";

  %vals;
}

=head2 template_vars

Returns the template vars generated from scanning the Model object.

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

  my $v = { };

  $v->{'model'} = $model;

  # print STDERR "\n\nPreparing template vars:\n";

  # $DB::single = 1;

  $v->{'model_package'} = $self->package_name($self->{'packagePrefix'});
  $v->{'model_package_file'} = $self->package_file_name($self->{'packagePrefix'});
  $v->{'model_package_dir'} = $self->package_dir_name($self->{'packagePrefix'});
  {
    my $ob = [ @{$self->{'packagePrefix'}}, '__ObjectBase' ];
    $v->{'base_package'} = $self->package_name($ob);
    $v->{'base_package_file'} = $self->package_file_name($ob);
    $v->{'base_package_dir'} = $self->package_dir_name($ob);
  }

  {
    my @factory_map;
    $v->{'factory_map'} = \@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->package_name($cls);
      push(@factory_map,
	   $cls_name => $pkg_name,
	   $cls_name_q => $pkg_name,
	   );
    }
  }

  if ( 0 ) {
    # local $UML::MetaMetaModel::Util::namespace_trace = 1;
    my (@ac) = Namespace_ownedElement_match($model, 'isaAssociationClass', 1);
    $DB::single = 1;
    
    print STDERR "AC: ", join(', ', map($_->name, @ac)), "\n";
  }

  my (@cls_v, %cls_v, %cls);
  my (@assoc, @assoc_v);
  
  $v->{'classifier'} = \@cls_v;
  $v->{'association'} = \@assoc_v;

  my @cls_all = Namespace_classifier($model);
  for my $cls ( @cls_all ) {
    # print STDERR "Classifier $cls->{name} \t:\t";
    unless ( $self->template_enabled($cls) ) {
      # print STDERR "IGNORED!\n";
      next;
    }
    # print STDERR "OK!\n";
    
    my $x = {
      $self->__id($cls),
      
      'primitive' => String_toBoolean($self->export_value($cls, 'primitive')),
      'primitive_type' => $self->export_value($cls, 'primitive_type'),
      
      'construct_type' => $self->export_value($cls, 'construct_type'),
      
      'validate_type' => $self->export_value($cls, 'validate_type'),
      'validate_type_type' => $self->export_value($cls, 'validate_type_type'),
      
      'construct' => $self->export_value($cls, 'construct'),
      'construct_type' => $self->export_value($cls, 'construct_type'),
      
      map(($_ => String_toBoolean(scalar $cls->$_())),
	  'isRoot',
	  'isLeaf',
	  'isAbstract',
	  'isSpecification',
	  ),
      
      map(($_ => $cls->$_()),
	  'visibility',
	  ),
      
      map(($_ => $cls->$_),
	  'isaClass',
	  'isaAssociationClass',
	  'isaInterface',
	  'isaEnumeration',
	  'isaPrimitive',
	  'isaDataType',
	  ),
    };
    
    #$x->{'primitive_type'} ||= $x->{'package'};
    #$x->{'construct_type'} ||= $x->{'primitive_type'};
    #$x->{'validate_type_type'} ||= $x->{'construct_type'};
    
    push(@cls_v, $x);
    
    $cls_v{$cls} = $x;
    $cls{$x} = $cls;      
  }

  # Find all AssociationEnds
  for my $cls ( @cls_all ) {

    # Generate accessors for each association end point
    # where this classifier participates.
    my @x = $cls->association;
    push(@x, map(AssociationEnd_opposite($_), @x));
    for my $end ( @x ) {
      next if $end->{'.v'};
      
      my $name = $end->name;
      
      my $type = $end->participant;
      my $multi = $end->multiplicity;
      
      my $instance = $end->targetScope ne 'classifier'; 
      
      my $x = {
	$self->__id($end),
	
	'isNavigable' => $end->isNavigable ne 'false',
	'instance' => $instance,
	
	'type' => $self->package_name($type),
	'type_impl' => $self->export_value($end, 'type_impl'),
	
	'multi' => Multiplicity_asString($multi),
	'multi_upper' => Multiplicity_upper($multi),
	'multi_single' => Multiplicity_upper($multi) eq '1',
	
	map(($_ => $end->$_()),
	    'visibility',
	    'ordering',
	    'aggregation',
	    'targetScope',
	    'changeability',
	    )
      };
      
      # Cant nav if it doesn't have a name.
      $x->{'isNavigable'} = 0 unless $x->{'name'};
      
      $x->{'type_impl'} ||= $x->{'type'};
      $x->{'type_primitive'} ||= 
      $cls_v{$type}{'primitive_type'} || $x->{'type_impl'};

      if ( 0 && $x->{'phantom'} ) {
	my $assoc = AssociationEnd_association($end);
	print STDERR "\nPHANTOM: $cls->{name}\t : $end \n", Association_asString($assoc), "\n";
      }

      # Remember it.
      push(@assoc, $end);
      push(@assoc_v, $x);

      $end->{'.v'} = $x;
    }
  }

  # print STDERR "assocs: ", join(",\n ", sort keys %assoc_v), "\n";

  # Add opposites to each End.
  for my $end ( @assoc ) {
    # The association relationship with the AssocationEnds
    # on the other side must be maintained.
    my @x = AssociationEnd_opposite($end);
    @x =
    map(
	$_->{'.v'} || confess("No assoc_v for '$_->{name}' ($_)"), 
	@x,
	);
    $end->{'.v'}{'opposite'} = \@x;
    $end->{'.v'}{'opposites'} = scalar @x;
  }


  # Internals in each class.
  for my $cls_v ( @cls_v ) {
    my $cls = $cls{$cls_v};

    # Dependencies
    {
      my @usage;
      $cls_v->{'usage'} = \@usage;
      
      for my $cls ( map($_->supplier, 
			grep($self->template_enabled($_),
			     grep($_->isaUsage,
				  $cls->clientDependency,
				  )
			     )
			)
		    ) {
  	my $dep_v = $cls_v{$cls};
	push(@usage, $dep_v);
	
      }

      $cls_v->{'usages'} = scalar @usage;
    }
    
    # Generalizations
    {
      my @exports;
      $cls_v->{'exports'} = \@exports;
      
      my @x = map($_->parent,
		  grep(defined, $cls->generalization),
		  );
      $cls_v->{'generalization'} = \@x;
      $cls_v->{'generalizations'} = scalar @x;
      

      ###############################################
      # Get all generalizations
      #

      my @gen_all = map($cls_v{$_}, GeneralizableElement_generalization_parent_all($cls));
      @gen_all = reverse @gen_all;
      $cls_v->{'generalization_all'} = \@gen_all;
      $cls_v->{'generalization_alls'} = scalar @gen_all;
      
      
      my @supers = (
		    map($self->package_name($_),
			@x,
			)
		    );
      $cls_v->{'supers'} = \@supers;
      
      # If no supers are specified be sure to use the base package.
      $cls_v->{'supers_default'} =
      [
       @supers ? () :
       (
	$v->{'base_package'},
	@{$self->{'defaultSuperclass'}},
	)
       ];
      
      for my $x ( @x ) {
	$x = $cls_v{$x};
      }
      #local $" = ', '; print STDERR "*** $cls->{name} supers [@supers]\n";
    }
    
    # Abstractions
    {
      my @abstraction;
      $cls_v->{'abstraction'} = \@abstraction;
      
      @abstraction = map($_->supplier, 
			grep($_->isaAbstraction,
			     grep(defined $_,
				  $cls->clientDependency
				  )
			     )
			);
      for my $x ( @abstraction ) {
	$x = $cls_v{$x};
      }

      $cls_v->{'abstractions'} = scalar @abstraction;
    }
 

    # EnumerationLiteral
    {
      my @literal;
      $cls_v->{'literal'} = \@literal;
      
      # Generate accessors for each association end point
      # where this classifier participates.
      if ( $cls->isaEnumeration ) {
	# $DB::single = 1;

	for my $literal ( $cls->literal ) {
	  my $name = $literal->name;
	  
	  my $literal_v = {
	    $self->__id($literal),
	  };

	  push(@literal, $literal_v);
	}
      }
    }

    # Attributes
    {
      my @attr;
      $cls_v->{'attribute'} = \@attr;
      
      # $DB::single = 1;
      
      for my $attr ( $self->attribute($cls) ) {
	
	# print STDERR "Attribute $cls->{name} :: $attr->{name}\t:\t";
	unless ( $self->template_enabled($attr) ) {
	  # print STDERR "IGNORED!\n";
	  next;
	}
	# print STDERR "OK\n";
	
	my $name = $attr->name;
	
	my $type = $attr->type;
	my $multi = $attr->multiplicity;
	
	my $initialValue = $self->export_value($attr, 'initialValue');
	unless ( defined $initialValue ) {
	  $initialValue = $attr->initialValue;
	  if ( $initialValue && $initialValue->language eq $self->export_kind ) {
	    $initialValue = $initialValue->body;
	  }
	}

	# $DB::single = 1;	
	my $attr_v = {
	  $self->__id($attr),

	  'type' => $self->package_name($type),
	  'type_impl' => $self->export_value($attr, 'type_impl'),
	  
	  'multi' => Multiplicity_asString($multi),
	  'multi_upper' => Multiplicity_upper($multi),
	  'multi_single' => Multiplicity_upper($multi) eq '1',
	  
	  'initialValue_defined' => defined $initialValue,
	  'initialValue' => $initialValue,
	  
	  'instance' => $attr->ownerScope ne 'classifier',

	  map(($_ => $attr->$_()),
	      'visibility',
	      'changeability',
	      'targetScope',
	      'ordering',
	      ),
	};
	
	$attr_v->{'type_impl'} ||= 
	$cls_v{$type}{'primitive_type'} || 
	$attr_v->{'type'};

	push(@attr, $attr_v);
      }

      $cls_v->{'attributes'} = scalar @attr;
    }

    # Association
    {
      my @assoc = map($_->{'.v'}, $cls->association);
      $cls_v->{'association'} = \@assoc;
      $cls_v->{'associations'} = scalar @assoc;
    }

    if ( 0 && grep($cls_v->{'name'} eq $_, 'Namespace', 'ModelElement') ) {
      use Data::Dumper;
      print STDERR Data::Dumper->new([ $cls_v ], [ $cls_v->{name} ])->Maxdepth(5)->Dump();
      $DB::single = 1;
    }
  }

  for my $end ( @assoc ) {
    delete $end->{'.v'};
  }


  $v;
}


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


sub template_enabled
{
  my ($self, $node, @args) = @_;

  $self->export_enabled($node, @args);
}


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

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

