package UML::Export;

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.9 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

=head1 NAME

UML::Export - Base exporter class for UML::MetaModel;

=head1 SYNOPSIS

  use base qw(UML::Export::...);
  my $code = UML::Export::...->new(...);
  $code->export_Model($model);

=head1 DESCRIPTION

This package allow UML (meta-)models to be exported, to XMI or implementation languages.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

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

=head1 VERSION

$Revision: 1.9 $

=head1 METHODS

=cut


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


package UML::Export;

use UML::MetaMetaModel::Util qw(:all);
use IO::Handle; # *STDOUT below.


=head2 new

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


sub initialize
{
  my ($self) = @_;
  
  $self->{'output'} ||= *STDOUT;
  $self->{'output'} = UML::Export::EvalIO->new()
  if ( $self->{'output'} eq 'EVAL' );

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

  $self->{'override'} ||= { };

  $self;
}



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

use Carp qw(confess);


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

  # Filter the model.
  $model = $self->model_filter($model);

  # Generate code for each class.
  eval {
    #$DB::single = 1;
    for my $cls ( Namespace_interface($model) ) {
      $self->export_Interface($cls);
      $self->{'output'}->flush;
    }
    for my $cls ( Namespace_class($model) ) {
      $self->export_Class($cls);
      $self->{'output'}->flush;
    }
    for my $cls ( Namespace_associationClass($model) ) {
      $self->export_AssociationClass($cls);
      $self->{'output'}->flush;
    }
    for my $cls ( Namespace_enumeration($model) ) {
      $self->export_Enumeration($cls);
      $self->{'output'}->flush;
    }

    delete $self->{'.attr'};
    delete $self->{'.oper'};
    delete $self->{'.literal'};
  };
  if ( $@ ) {
    die("While generating Model:\n$@");
  }

  #print STDERR "\n# DONE!\n";
  $self;
}




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


sub model_filters
{
  ();
}

sub model_filter
{
  my ($self, $model) = @_;;
 
  my @filters = $self->model_filters;

  if ( @filters ) {
    $model = Model_clone($model);

    for my $filter ( @filters ) {
      unless ( ref($filter) ) {
	$filter = "UML::XForm::$filter" unless $filter =~ /::/;
	eval "use $filter;"; die if $@;
	$filter = $filter->new('verbose' => 0);
      }

      $model = $filter->apply_Model($model);
    }

  }

  $model;
}

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


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

  confess(ref($self) . "->export_Interface(): not implemented");
}


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

  confess(ref($self) . "->export_Class(): not implemented");
}


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

  confess(ref($self) . "->export_AssociationClass(): not implemented");
}


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

  confess(ref($self) . "->export_Enumeration(): not implemented");
}


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



=head2 attribute

Returns a list of Attributes of a Classifier.

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

  my $x = $self->{'.attr'}{$cls} ||= 
  [
   Classifier_attribute($cls),
   ];

  wantarray ? @$x : $x;
}


=head2 operation

Returns a list of Operations of a Classifier.

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

  my $x = $self->{'.oper'}{$cls} ||= 
  [
   Classifier_operation($cls),
   ];

  wantarray ? @$x : $x;
}


=head2 enumerationLiteral

Returns a list of EnumerationLiterals of an Enumeration.

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

  my $x = $self->{'.literal'}{$cls} ||= $cls->literal;

  wantarray ? @$x : $x;
}


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

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

  my $over = $self->{'override'};
  my $kind = $self->export_kind;
  my $name = ModelElement_name_qualified($node);
  my $key = join('.', @args);

  my $value = (grep(defined $_,
		    $over->{$kind}{$name}{$key},
		    $over->{$kind}{'*'}{$key},
		    $over->{'*'}{$name}{$key},
		    $over->{'*'}{'*'}{$key},
		    ModelElement_taggedValue_inherited_true($node, join('.', "uml2code.$kind", @args)),
		    ModelElement_taggedValue_inherited_true($node, join('.', "uml2code", @args)),
		    ))[0];

  #local $" = ', ';
  #print STDERR "export_enabled $node $node->{name} '$kind' @args => $value\n";

  $value;
}


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

  my $over = $self->{'override'};
  my $kind = $self->export_kind;
  my $name = ModelElement_name_qualified($node);
  my $key = join('.', @args);

  my $value = (grep(defined $_,
		    $over->{$kind}{$name}{$key},
		    $over->{$kind}{'*'}{$key},
		    $over->{'*'}{$name}{$key},
		    $over->{'*'}{'*'}{$key},
		    map(ModelElement_taggedValue_name($node, join('.', $_, @args)),
			"uml2code.$kind",
			"uml2code",
			)
		    ))[0];

  #local $" = ', ';
  #print STDERR "export_enabled $node $node->{name} '$kind' @args => $value\n";

  $value;
}


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

  my $over = $self->{'override'};
  my $kind = $self->export_kind;
  my $name = ModelElement_name_qualified($node);
  my $key = join('.', @args);

  my $value = (grep(defined $_,
		    $over->{$kind}{$name}{$key},
		    $over->{$kind}{'*'}{$key},
		    $over->{'*'}{$name}{$key},
		    $over->{'*'}{'*'}{$key},
		    map(ModelElement_taggedValue_inherited($node, join('.', $_, @args)),
			"uml2code.$kind",
			"uml2code",
			)
		    ))[0];

  #local $" = ', ';
  #print STDERR "export_enabled $node $node->{name} '$kind' @args => $value\n";

  $value;
}


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

  confess(ref($self) . "->export_kind(): not implemented");
}

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


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

  confess(ref($self) . "->package_sep(): not implemented");
}


sub package_name
{
  my ($self, $cls, $sep) = @_;
  
  $sep ||= $self->package_sep;

  my @x;
  if ( ref($cls) eq 'ARRAY' ) {
    @x = @$cls;
  } else { 
    @x = (
	  ref($self->{'packagePrefix'}) ? @{$self->{'packagePrefix'}} : $self->{'packagePrefix'},
	  ModelElement_name_qualified($cls),
	  );
  }

  # Incase ModelElement names have spaces or other junk chars, 
  # which appears to be possible.
  # Perl doesn't like spaces in identifiers.
  # Neither does any other implementation language I can think of.
  grep(s/[^a-z0-9_]/_/sgi, @x);

  my $x = join($sep, @x);
  
  $x;  
}


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


sub package_file_name_sep { '/' }

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

  confess(ref($self) . "->package_file_name_suffix(): not implemented");
}


sub package_dir_name
{
  my ($self, $package) = @_;

  # If it package path or an object,
  # convert to package name with '::' sep.
  if ( ref($package) ) {
    $package = $self->package_name($package, '::');
  }

  my $file = $package;
  my $sep = $self->package_file_name_sep;
  $file =~ s/::/$sep/sge;
  
  $file;
}


sub package_file_name
{
  my ($self, $package) = @_;

  my $file = $self->package_dir_name($package);
  $file .= $self->package_file_name_suffix;
  
  $file;
}



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

package UML::Export::EvalIO;


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


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

  $self->{'code'} ||= '';
  #$self->{'debug'} = 0;

  $self;
}


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

  $self->{'code'} .= join('', @args);

  1;
}


sub close
{
  shift->flush;
}


sub __linenos
{
  my ($c) = @_;

  my $line = 0;

  $c = join("\n",
	    map(sprintf("%-4d ", ++ $line) . $_,
		split("\n", $c, 99999),
		),
	    '',
	    );
  my $sep = '#-' x 40;
  $c = "$sep\n$c$sep\n";

  $c;
}


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

  my $code = $self->{'code'};
  $self->{'code'} = '';

  if ( 1 ) {
    $code =~ /^.*\n.*\n(.*\n).*\n/;
    my $package = $1;
    print STDERR $package;
    if ( 0 && $package =~ /Classifier|ModelElement|Integer|String|Name|Kind/ ) {
      print STDERR $code;
      $DB::single = 1;
    }
  }

  eval($code);
  if ( $@ ) {
    $code = __linenos($code);
    die "$code\nin eval of code above:\n$@";
  }
  if ( $self->{'debug'} ) {
    print STDERR __linenos($code);
  }


  1;
}

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

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

