package UML::Export::Java;

use 5.6.1;
use strict;
use warnings;

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

=head1 NAME

UML::Export::Java - A Java code generator for XMI

=head1 SYNOPSIS

  use base qw(UML::Export::Java);
  my $code = '';
  my $gen = new UML::Export::Java('output' => *STDOUT);
  $gen->code_Model($uml_model);
  print $code;

=head1 DESCRIPTION

This package allow XMI documents generate Java code.

=head1 USAGE

=head1 PATTERNS

=over 4

=item * a design pattern


=back

=head1 EXPORT

None exported.

=head1 AUTHOR

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

=head1 SEE ALSO

L<UML::XMI|UML::XMI>, L<XML::DOM|XML::DOM>

=head1 VERSION

$Revision: 1.1 $

=head1 METHODS

=cut

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

use base qw(UML::Export);

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


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


sub code_java_pq
{
  my ($self, $node) = @_;
  
  $self->code_namespace_q($node);
}


sub code_java_package
{
  my ($self, $node) = @_;
  
  join('.', $self->code_java_pq($node));
}


sub code_java_package_dir
{
  my ($self, $node) = @_;
  
  join('/', $self->code_java_pq($node));
}


sub code_java_package_name
{
  my ($self, $node) = @_;
  
  join('.', $self->code_java_pq($node), $self->code_name);
}


sub code_multi_upper
{
  my ($self, $multi) = @_;

  Multiplicity_upper($multi);
}



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

use Carp qw(confess);


sub code_java_type
{
  my ($self, $node, %opts) = @_;

  confess("ARRGH") unless $node;

  my $type_name = $node->name;
  my $java_type = $type_name;
  
  my $qual = $opts{'qual'};
  $qual = 1 unless defined $qual;
  if ( $qual ) {
    my $package_name = $self->code_java_package($node);
    $java_type = join('.', grep(length, $package_name, $type_name));
  }
  
  my $context = $opts{'context'};
  if ( $context ) {
    if ( $context eq $node ) {
      $java_type = $type_name;
    }
  }
  
  if ( my $multi = $opts{'multi'} ) {
    $multi = $self->code_multi_upper($multi) if ref($multi);
    if ( $multi ne '1' ) {
      $java_type .= '[]';
    }
  }
  
  $java_type;
}


sub code_java_box
{
  my ($self, $type, $expr) = @_;
  
  if ( $type eq 'boolean' ) { 
    $expr = "new java.lang.Boolean((boolean) $expr)";
  }
  elsif ( $type eq 'byte' ) { 
    $expr = "new java.lang.Byte((byte) $expr)";
  }
  elsif ( $type eq 'char' ) { 
    $expr = "new java.lang.Char((char) $expr)";
  }
  elsif ( $type eq 'short' ) { 
    $expr = "new java.lang.Short((short) $expr)";
  }
  elsif ( $type eq 'int' ) { 
    $expr = "new java.lang.Integer((int) $expr)";
  }
  elsif ( $type eq 'long' ) { 
    $expr = "new java.lang.Long((long) $expr)";
  }
  elsif ( $type eq 'float' ) { 
    $expr = "new java.lang.Float((float) $expr)";
  }
  elsif ( $type eq 'double' ) { 
    $expr = "new java.lang.Double((double) $expr)";
  }
  
  $expr;    
}


sub code_java_unbox
{
  my ($self, $type, $expr) = @_;
  
  if ( $type eq 'boolean' ) {
    $expr = "((java.lang.Boolean) $expr).booleanValue()";
  }
  elsif ( $type eq 'byte' ) {
    $expr = "((java.lang.(Byte) $expr).byteValue()";
  }
  elsif ( $type eq 'char' ) {
    $expr = "((java.lang.Char) $expr).charValue()";
  }
  elsif ( $type eq 'short' ) {
    $expr = "((java.lang.Short) $expr).shortValue()";
  }
  elsif ( $type eq 'int' ) {
    $expr = "((java.lang.Integer) $expr).intValue()";
  }
  elsif ( $type eq 'long' ) {
    $expr = "((java.lang.Long) $expr).longValue()";
  }
  elsif ( $type eq 'float' ) {
    $expr = "((java.lang.Float) $expr).floatValue()";
  }
  elsif ( $type eq 'double' ) {
    $expr = "((java.lang.Double) $expr).doubleValue()";
  }
  
  $expr;
}


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

sub code_java_modifiers
{
  my ($self, $node) = @_;
  
  my %mod;
  
  for my $x 
  ( 
    [ 'IV', 'uml2code.visibility', ],
    [ 'TV', 'Foundation.Core.ModelElement.visibility'                                   ],
    [ 'TV', 'Foundation.Core.GeneralizableElement.isAbstract', 'abstract'               ],
    [ 'TV', 'Foundation.Core.GeneralizableElement.isLeaf'    , 'final'                  ],
    [ 'TV', 'Foundation.Core.Feature.ownerScope'             , 'classifier' => 'static' ],
    [ 'TV', 'Foundation.Core.AssociationEnd.targetScope'     , 'classifier' => 'static' ],
    ) {
    my $c;

    if ( $x->[0] eq 'TV' ) {
      $c = $node->getTagged($x->[1]);
      next unless $c;
      
      $c = $c->value;
    }
    elsif ( $x->[0] eq 'IV' ) {
      $c = $node->taggedValue_inherited($x->[1]);

      next unless $c;
    }

    if ( $x->[3] ) {
      $c = $c eq $x->[2] ? $x->[3] : undef;
    }
    elsif ( $x->[2] ) {
      if ( UML::Export::code_true($c) ) {
      $c = $x->[2];
    } else {
      $c = undef;
    }
    }

    if ( defined $c ) {
      if ( $c eq 'private' ) {
	next if  $mod{'public'};
      }
      $mod{$c} = $c;
    }
  }

  # Unique them.
  my @mod = values %mod;

  wantarray ? @mod : join(' ', @mod);
}



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


sub code_java_needsCollection
{
  my ($self, $attr, $attr_multi) = @_;

  # $DB::single = $attr->name eq 'a';

  $attr_multi = $attr->multiplicity unless $attr_multi;
  my $attr_multi_upper = $attr_multi->upper;

  my $result = 0;

  if ( $attr_multi_upper ne '1' ) {
    # Needs a collection like java.lang.Vector or [];
    $result = $attr_multi_upper;
  }
  
  $result;
}


sub code_java_attribute
{
  my ($self, $attr, $cls) = @_;
  
  # $DB::single = 1;
  
  my $attr_name = $attr->name;
  my $attr_type = $attr->type;
  my $attr_multi = $attr->multiplicity;
  my $initial_value = 
  (grep(defined,
	map($attr->taggedValue_trace($_),
	    'uml2code.Java.initialValue',
	    'uml2code.initialValue',
	    'Java.intialValue',
	    'initialValue',
	    ),
	$attr->initialValue_language('Java'),
	)
   )[0];
  $initial_value = UML::Export::code_trimws($initial_value);
  
  my $mods = $self->code_java_modifiers($attr);
  my $needsCollection = $self->code_java_needsCollection($attr, $attr_multi);    
  
  my $java_type = $self->code_java_type($attr_type,
				       'context' => $cls,
				       'multi'   => $attr_multi,
				       );
  
  my @comment;

  no warnings; 
  # Use of uninitialized value in length at ./xmi2files line 606.
  # Use of uninitialized value in length at ./xmi2files line 622.
  # Use of uninitialized value in concatenation (.) or string
  
  unless ( length($initial_value) ) {
    if ( $needsCollection ) {
      if ( $needsCollection eq '*' ) {
	push(@comment, 'upper="*"');
      } else {
	# Get type name without multiplicity.
	my $elem_type = $self->code_java_type($attr_type,
					     'context' => $cls,
					     );
	
	# Create array constructor for initial value.
	$initial_value = "new $elem_type\[$needsCollection\]";
      }
    }
  }
  
  if ( length($initial_value) ) {
    $initial_value = ' = ' . $initial_value
    unless $initial_value =~ m/^[\s\n]*=/s;
  }
  
  $mods .= ' ' if $mods;
  
  my $trace = $attr->generated_trace_description;
  push(@comment, $trace) if $trace;

  my $comment = join('; ', @comment);
  $comment = " /* $comment */" if $comment;

  "$mods$java_type $attr_name$initial_value;$comment";
}


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

sub code_java_parameter
{
  my ($self, $param, $op, $cls) = @_;
  
  # $DB::single = $param eq undef;
  
  my $param_name = $param->name;
  
  my $param_type = $param->type;
  my $param_multi = $param->multiplicity;
  
  confess("$param $param_name type = undef") unless $param_type;
  # ARGOUML 0.13.3 bug:
  # parameters do not have multiplicity
  # confess("$param $param_name multi = undef") unless $param_multi;

  $param_type = $self->code_java_type( 
				      $param_type,
				      'multi' => $param_multi,
				      'context' => $cls,
				      );
  
  "$param_type $param_name";
}


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

sub code_java_operation
{
  my ($self, $op, $cls) = @_;
  
  # $DB::single = 1;
  
  my $mods = $self->code_java_modifiers($op);
  
  my $return_param = $op->return;
  my $return_multi = $return_param->multiplicity;
  my $return_type = $return_param->type;
  $return_type = $self->code_java_type($return_type,
				      'multi' => $return_multi,
				      'context' => $cls,
				      );
  
  my $op_name = $op->name;
  
  my $body;
  
  # Interfaces cannot have method bodies.
  if ( $self->code_java_class_kind($cls) eq 'interface' ) {    
    $body = ';';
  } else {
    $body = (grep(defined, 
		  $op->taggedValue_trace('uml2code.Java.body'),
		  $op->taggedValue_trace('uml2code.body'),
		  $op->taggedValue_trace('Java.body'),
		  $op->taggedValue_trace('body'),
		  ))[0];
    $body = $self->code_java_operation_body($return_type, $body);
  };
  
  my $params = join(', ',
		    map(
			$self->code_java_parameter($_, $op, $cls),
			$op->parameter,
			)
		    );
  
  "$mods $return_type $op_name($params)$body";    
}


sub code_java_operation_body
{
  my ($self, $return_type, $body) = @_;
  
  no warnings;
  # Use of uninitialized value in length
  
  $body = UML::Export::code_trimws($body);
  
  if ( ! length($body) ) {
    if ( $return_type eq 'void' ) {
      $body = '';
    }
    elsif ( $return_type eq 'boolean' ) { 
      $body = 'return false';
    }
    elsif ( $return_type eq 'byte' ) { 
      $body = 'return (byte) 0';
    }
    elsif ( $return_type eq 'short' ) { 
      $body = 'return (short) 0';
    }
    elsif ( $return_type eq 'int' ) { 
      $body = 'return (int) 0';
    }
    elsif ( $return_type eq 'long' ) { 
      $body = 'return (long) 0';
    }
    elsif ( $return_type eq 'float' ) { 
      $body = 'return (float) 0';
    }
    elsif ( $return_type eq 'double' ) { 
      $body = 'return (double) 0';
    }
    else { 
      $body = 'return null';
    }
    $body = "// UML2CODE: Needs uml2code.body?\n    $body";
  }
  
  if ( length($body) ) {
    $body .= ';' unless $body =~ m/;\s*$/s;
    $body = "\n  {\n    $body\n  }\n" unless $body =~ m/^\s*\{/s;
  }
  
  $body;
}



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

sub code_java_class_kind
{
  my ($self, $node) = @_;
  
  $node->isa('UML::Export::Class') ? 'class' : 'interface';
}


sub code_java_class_or_interface
{
  my ($self, $cls, $kind) = @_;
  
  # $DB::single = 1;
  
  return unless $cls->taggedValue_inherited_true('uml2code');
  
  $kind ||= $self->code_java_class_kind($cls);
  
  # $DB::single = 1;
  
  # print STDERR "cls node name = ", $cls->getNodeName, "\n";
  my $cls_name = $cls->name;
  my $file_suffix = $cls->taggedValue_inherited('uml2code.file.suffix', '.java');
  my $file_name = join('/',
		       grep(length,
			    $self->code_java_package_dir($cls), 
			    join('', $cls_name, $file_suffix)
			    )
		       );
  
  my $package = $self->code_java_package($cls);
  my $mods = $self->code_java_modifiers($cls);
  
  my $out = $self->{'output'};
  
  print $out (qq@
//-// FILE BEGIN $file_name
//-// 
@);

  print $out (qq@
package $package;
@) if $package;

  #   dependency
  my @dependency_supplier = $cls->clientDependency_supplier;
  if ( @dependency_supplier ) {
    print $out "\n// Dependencies\n";
    for my $s ( @dependency_supplier ) {
      print $out ("import ", 
		  (
		   $s->isa('UML::Export::Package') ? 
		   $self->code_java_package_name($s) . '.*' :
		   $self->code_java_type($s)
		   ), ";\n");
    }
    print $out "\n ";
  }

  # public? class|interface ...
  print $out (join(' ', grep(length, $mods, $kind, $cls_name)), "\n");
  
  # $DB::single = 1;
  
  #   extends ...
  my @extends = $cls->generalization_parent;
  if ( @extends ) {
    @extends = map($self->code_java_type($_), @extends);
    if ( @extends > 1 ) {
      local $" = ', ';
      print STDERR "Error: $package.$cls_name extends more than one class: { @extends }: use interfaces\n";
      die(1);
    }
    print $out ("  extends ", join(', ', @extends), "\n");
  }
  
  #   implements ...
  my @implements = $cls->abstraction_supplier;
  if ( @implements ) {
    print $out ("  implements ", join(', ', map($self->code_java_type($_), @implements)), "\n");
  }

  #   instantiate ...
  my $instantiates = 
  (grep(defined, map($cls->taggedValue_inherited($_),
		     'uml2code.instantiates',
		     'instantiates',
		     )
	))[0];
  if ( $instantiates ) {
    print $out ("  intstantiates $instantiates\n");
  }


  # {
  print $out ("{\n");
  
  # Attributes
  print $out ("\n  // Attributes\n");
  for my $attr ( $cls->attributes ) {
    print $out ("  ", $self->code_java_attribute($attr, $cls), "\n");
  }
  
  # Operations
  print $out ("\n  // Operations\n");
  for my $op ( $cls->operations ) {
    print $out ("  ", $self->code_java_operation($op, $cls), "\n");
  }
  
  if ( 0 ) {
    # Associations.
    print $out ("\n  // Assocation\n");
    for my $end ( $cls->association_ends_attached_to ) {
      print $out ("  ", $self->code_java_association_end_type($end, $cls), "\n");
    }
  }
  
  #  JavaBeans
  print $out ($self->code_java_bean_class_body($cls, $kind));
  
  print $out (qq@
}
//-// FILE END $file_name
@);


$self;
}


sub code_doc
{
  my ($self, $doc) = @_;
  
  my $model = $doc->model;
  
  $DB::single = 1;
  
  for my $cls ( $model->classes ) {
    $self->code_java_class_or_interface($cls, 'class');
  }
  for my $cls ( $model->interfaces ) {
    $self->code_java_class_or_interface($cls, 'interface');
  }

  $self;
}


######################################################################################
######################################################################################
# JavaBeans-specific
######################################################################################
######################################################################################

sub code_java_bean_is_bean
{
  my ($self, $node) = @_;
  
  $node->taggedValue_inherited_true('uml2code.Java.Bean') ||
  $node->taggedValue_inherited_true('uml2code.Java.Bean.bound') ||
  $node->taggedValue_inherited_true('uml2code.Java.Bean.vetoable') ||
  0;
}



sub code_java_bean_class_body
{
  my ($self, $cls, $kind) = @_;
  
  my $out = '';
  
  $kind ||= $self->code_java_class_kind($cls);
  return $out if $kind eq 'interface';

  my $is_bean = 
  grep($_,
       map($self->code_java_bean_is_bean($_),
	   $cls,
	   $cls->attributes,
	   )
       );
  
  return $out unless $is_bean;
  
  my $is_bound_property = 
  grep($_,
       map($_->code_taggedValue_inherited_true('uml2code.Java.Bean.bound'),
	   $cls,
	   $cls->code_attributes,
	   )
       );
  
  my $is_vetoable_property = 
  grep($_,
       map($_->code_taggedValue_inherited_true('uml2code.Java.Bean.vetoable'),
	   $cls,
	   $cls->attributes,
	   )
       );

  $out .= qq{
  /////////////////////////////////////////////////////////////
  // JavaBeans property change support.
  //

};

  if ( $is_bound_property ) {
    $out .= qq{
  private java.beans.PropertyChangeSupport __beanChanges;
  private java.beans.PropertyChangeSupport getPropertyChangeSuppport() { 
    if ( __beanChanges == null ) {
       __beanChanges = new java.beans.PropertyChangeSupport(this);
    }
    return __beanChanges;
  }
  public void addPropertyChangeListener(java.beans.PropertyChangeListener l)
  {
    getPropertyChangeSuppport().addPropertyChangeListener(l);
  }
  public void removePropertyChangeListener(java.beans.PropertyChangeListener l)
  {
    getPropertyChangeSuppport().removePropertyChangeListener(l);
  }

};
  }

  if ( $is_vetoable_property ) {
    $out .= qq{

  private java.beans.VetoableChangeSupport __beanVetos;
  private java.beans.VetoableChangeSupport getVetoableChangeSupport() { 
    if ( __beanVetos == null ) {
       __beanVetos = new java.beans.VetoableChangeSupport(this);
    }
    return __beanVetos;
  }
  public void addVetoableChangeListener(java.beans.VetoableChangeListener l)
  {
     getVetoableChangeSupport().addVetoableChangeListener(l);
  }
  public void removeVetoableChangeListener(java.beans.VetoableChangeListener l)
  {
     getVetoableChangeSupport().removeVetoableChangeListener(l);
  }
};
  };

  # Now do accessors for attributes that are Bean properties.
  $out .= join("\n\n", 
	       map($self->code_java_bean_attribute_class_body($_, $cls),
		   $cls->attributes
		   )
	       );

  $out;
}


sub code_java_bean_attribute_class_body
{
  my ($self, $attr, $cls) = @_;
  
  my $is_bean = $self->code_java_bean_is_bean($attr);
  my $is_bound_property = $attr->taggedValue_inherited_true('uml2code.Java.Bean.bound');
  my $is_vetoable_property = $attr->taggedValue_inherited_true('uml2code.Java.Bean.vetoable');

  my $getter = $attr->taggedValue_true('uml2code.Java.Bean.getter', 1);
  my $setter = $attr->taggedValue_true('uml2code.Java.Bean.setter', 1);

  my $out = '';
  
  if ( $is_bean || $is_bound_property || $is_vetoable_property ) {
    my $attr_type = $attr->type;
    my $multi_range = $attr->multiplicity;
    
    my $java_type = $self->code_java_type($attr_type,
					 'context' => $cls,
					 'multi' => $multi_range,
					 );
    my $is_indexed = $multi_range->upper ne '1';
    
    my $java_indexed_type = $self->code_java_type($attr_type,
						 'context' => $cls,
						 );
    my $java_attr = $attr->name;
    my $java_Attr = ucfirst($java_attr);
    
    my $firePropChange = join(', ', 
			      "\"$java_attr\"",
			      $self->code_java_box($java_type, '__oldValue'),
			      $self->code_java_box($java_type, '__newValue'),
			      );
    my $firePropChangeIndexed = join(', ', 
				     "\"$java_attr\"",
				     $self->code_java_box($java_type, '__oldValue'),
				     $self->code_java_box($java_indexed_type, '__newValue'),
				     );
    
    $out .=
    qq{

  //////////////////////////////////////////////////////////
  // JavaBean property "$java_attr"
  //

};

    if ( $getter ) {
      $out .=
      qq{
  // JavaBean property getter method
  public $java_type get$java_Attr() { 
    return $java_attr;
  }

};
      if ( $is_indexed ) {
	$out .=
	qq{

  public $java_indexed_type get$java_Attr(int __index) { 
    return $java_attr\[__index\];
  }

};
	}
    }

    my $throws = $is_vetoable_property ? ' throws java.beans.PropertyVetoException ' : '';
    
    if ( $setter ) {
      $out .= "\n  // JavaBean property setter method\n";
      $out .= "  public void set$java_Attr($java_type __newValue)$throws\n";
      $out .= "  {\n";
      $out .= "    $java_type __oldValue = $java_attr;\n" if ( $is_bound_property || $is_vetoable_property );
      $out .= "    getVetoableChangeSupport().fireVetoableChange($firePropChange);\n" if ( $is_vetoable_property );
      $out .= "    $java_attr = __newValue;\n";
      $out .= "    getPropertyChangeSuppport().firePropertyChange($firePropChange);\n" if ( $is_bound_property );
      $out .= "  }\n\n";
      
      if ( $is_indexed ) {
	$out .= "\n\n  public void set$java_Attr(int __index, $java_indexed_type __newValue)$throws\n";
	$out .= "  {\n";
	$out .= "    $java_type __oldValue = $java_attr;\n" if ( $is_bound_property || $is_vetoable_property );
	$out .= "    getVetoableChangeSupport().fireVetoableChange($firePropChangeIndexed);\n" if ( $is_vetoable_property );
	$out .= "    $java_attr\[__index\] = __newValue;\n";
	$out .= "    getPropertyChangeSuppport().firePropertyChange($firePropChangeIndexed);\n" if ( $is_bound_property );
	$out .= "  }\n\n";
      }
    }
  }
  
  $out;
}



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

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

