UMMF::Export::Template - A code generator base class using Template Toolkit.
Index
Code Index:
NAME
UMMF::Export::Template - A code generator base class using Template Toolkit.
SYNOPSIS
use base qw(UMMF::Export::Template);
DESCRIPTION
This package allow UML models to be processed into other forms using a template.
USAGE
Need description of template input data structure.
EXPORT
TO DO
This entire class needs to be refactored; it has grown too large and most of the template variables are set up in a redundant manner that is dependent on the underlying meta-model.
I propose that the meta-model be used directly in all templates from now on.
AUTHOR
Kurt Stephens, kstephens@users.sourceforge.net 2003/05/02
SEE ALSO
UMMF::UML::MetaModel (UMMF::UML::MetaModel)
VERSION
METHODS
template_file
$self->template_file;
Returns the name of the Template to be used.
If $self-{'template_file'}> is not defined, defaults
to the file name ref($self) . '.txt'.
template_config
Returns the Template configuration hash.
template
Returns a cached Template object.
template_vars
Returns the template variables generated by scanning the Model.
package UMMF::Export::Template;
use 5.6.1;
use strict;
our $AUTHOR = q{ kstephens@users.sourceforge.net 2003/04/06 };
our $VERSION = do { my @r = (q$Revision: 1.66 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };
#######################################################################
use base qw(UMMF::Export);
#######################################################################
use UMMF;
use UMMF::Core::Util qw( :all );
use Carp qw(confess);
use Template;
use Template::Stash;
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'};
$out = '-' if $out eq *STDOUT;
$out = '-' if $out eq \*STDOUT;
# $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;
}
#######################################################################
sub template_file
{
my ($self) = @_;
my $x = \$self->{'template_file'};
unless ( $$x ) {
my @try;
my $file;
# Try file in other resource path.
$file = ref($self) || $self;
$file =~ s@.*::@@s;
$file .= '.txt';
push(@try, map("$_/$file", UMMF->resource_path('template')));
# Try file in same directory as this module (Foo)
# named FooTemplate.txt
#$file = ref($self) || $self;
#$file =~ s@::@/@sg;
#$file .= '.pm';
#$file = $INC{$file};
#$file =~ s/\.pm$/Template.txt/;
#push(@try, $file);
# Find readable file.
$file = undef;
if ( $self->{'debug'} ) {
for my $x ( @try ) { print STDERR " try $x\n"; }
}
for my $x ( @try ) {
if ( -r $x ) {
$file = $x;
last;
}
}
unless ( $file ) {
die("Cannot find template for " . ref($self));
}
# Make it absolute.
use File::Spec;
$file = File::Spec->rel2abs($file);
print STDERR "Export: using template $file\n";
# $DB::single = 1;
$$x = $file;
}
$$x;
}
sub template_config
{
my ($self) = @_;
# use Template::Constants qw( :debug );
my $x = $self->{'template_config'} ||=
{
'INCLUDE_PATH' => [
dirname($self->template_file),
UMMF->resource_path('template'),
],
'INTERPOLATE' => 0, # Do not interpolate $var
# 'RELATIVE' => 1,
'POST_CHOMP' => 1,
# 'PRE_PROCESS' => 'header',
'EVAL_PERL' => 1,
'COMPILE_EXT' => '.ttc',
'COMPILE_DIR' => join('/', UMMF->tmp_dir, "$ENV{USER}.ttc"),
# 'DEBUG' => DEBUG_ALL, # DEBUG_PARSER | DEBUG_SERVICE | DEBUG_CONTEXT | DEBUG_PROVIDER,
};
{
use File::Path;
mkpath([ $x->{'COMPILE_DIR'} ], 1);
}
$x;
}
$Template::Stash::SCALAR_OPS->{unquoted} ||= sub {
no warnings;
my ($x) = @_;
$x =~ s/["']//sg;
$x;
};
$Template::Stash::SCALAR_OPS->{asInteger} ||= sub {
no warnings;
my ($x) = @_;
$x =~ s/["']//sg;
$x =~ /^[+-]?[0-9]+$/ ? $x : '-1';
};
$Template::Stash::SCALAR_OPS->{uc} ||= sub {
no warnings;
uc(shift);
};
$Template::Stash::SCALAR_OPS->{lc} ||= sub {
no warnings;
lc(shift);
};
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";
# Get objects unique id.
my $id = $obj->{'_id'};
# Default to Perl object reference.
unless ( $id ) {
local $1;
$obj =~ /[(]([^\)]+)[)]/;
$id = $1 || $obj;
}
# Get name.
my $name = $obj->{'name'};
# Get qualified name.
my $name_q = ModelElement_name_qualified($obj);
# Translate non-alphanumeric characters to '_' for
# implementation language compatibility.
my $name_ = $name;
$name_ =~ s/[^a-z_0-9]/_/sgi;
my $name_q_ = $name_q;
$name_q_ =~ s/[^a-z_0-9]/_/sgi;
# Get the object's Namespace representation.
my $namespace = $self->__id_namespace($obj->namespace);
# Get the names of any Stereotypes applied.
my @stereotype = $obj->stereotype;
for my $s ( @stereotype ) {
$s = $s->name if ref($s);
}
if ( 0 && @stereotype ) {
local $" = ', ';
print STDERR "$obj $obj->{name} stereotype = @stereotype\n";
}
# Get documentation
my $documentation = $self->config_value($obj, 'documentation');
$documentation = '' unless defined $documentation;
$DB::single = 1 if $documentation;
# Documentation with each line prefixed with the implementation language's
# comment character(s).
my $documentation_commented = $documentation;
my $comment_char = $self->comment_char;
$documentation_commented =~ s/\n/\n$comment_char/sg;
# Separate first paragraph of documentation from rest.
my ($documentation_1, $documentation_rest) = split("\n\n", $documentation, 2);
trim_ws_undef(\$documentation);
trim_ws_undef(\$documentation_commented);
trim_ws_undef(\$documentation_1);
trim_ws_undef(\$documentation_rest);
# $DB::single = 1 unless $name;
my %vals =
(
'obj' => $obj,
# Unique identifiers:
# Generated by this class.
'id' => $id,
# Generated by Poseidon.
'element_uuid' => ModelElement_taggedValue_name($obj, 'element.uuid'),
# The underlying UML metaobject class name,
'metatype' => ref($obj),
# Different types of names for the same metaobject.
# Note: identifier_name_filter will translate away keywords
# reserved by the implementation language, e.g. 'final', 'while', etc.
# Unqualified:
# As is.
'name' => $self->identifier_name_filter($obj, $name),
# Non alphanumeric chars translated to '_'.
'name_' => $self->identifier_name_filter($obj, $name_),
# First char uppercase.
'Name' => $self->identifier_name_filter($obj, ucfirst($name)),
'Name_' => $self->identifier_name_filter($obj, ucfirst($name_)),
# All uppercase.
'NAME' => $self->identifier_name_filter($obj, uc($name)),
'NAME_' => $self->identifier_name_filter($obj, uc($name_)),
# First char lowercase.
'nAME' => $self->identifier_name_filter($obj, lcfirst($name_)),
'nAME_' => $self->identifier_name_filter($obj, lcfirst($name_)),
# Fully qualified in Namespace:
# As is.
'name_q_raw' => $name_q,
'name_q' => $self->identifier_name_filter($obj, $name_q),
# Non alphanumeric characters translated to '_'.
'name_q_' => $self->identifier_name_filter($obj, $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
)
:
()
),
# Give namespace data.
'namespace' => $namespace,
# List of Stereotypes and and hash for testing
# if a metaobject has a Stereotype applied.
'stereotype' => \@stereotype,
'has_stereotype' => { map(($_ => 1), @stereotype) },
# Template variables beginning with '_' do not work.
# Phantom means that this metaobject, is used only
# as a placeholder (possible in an Interface) but
# not in implementation.
#
# I.e. a phantom AssociationEnd may be added to a
# generated Interface.
'phantom_obj' => $obj->{'_phantom'},
'phantom' => $obj->{'_phantom'} && ($self->package_name($obj->{'_phantom'}) || $obj->{'_phantom'}),
# Trace to the metaobject responsible for the creation of
# this object during UML transformations.
'trace_obj' => $obj->{'_trace'},
'trace' => $obj->{'_trace'} && ($self->package_name($obj->{'_trace'}) || $obj->{'_trace'}),
'documentation' => $documentation,
'documentation_commented' => $documentation_commented,
'documentation_1' => $documentation_1,
'documentation_rest' => $documentation_rest,
# If true, the template should generate implementation code
# for this metaobject.
'generate' => $self->config_value_inherited_true($obj, 'generate', 1),
# If true, the template should generate implementation code
# to store this metaobject off-line.
'storage' => $self->config_value_inherited_true($obj, 'storage'),
'storage_type_impl' => $self->config_value($obj, 'storage.type.impl'),
'storage_type' => $self->config_value($obj, 'storage.type'),
'storage_type_sql' => $self->config_value($obj, 'storage.type.sql'),
'storage_subtype' => $self->config_value($obj, 'storage.subtype'),
'storage_key_type' => $self->config_value($obj, 'storage.key.type'),
'storage_key_sql' => $self->config_value($obj, 'storage.key.sql'),
'storage_value_type' => $self->config_value($obj, 'storage.value.type'),
'storage_value_sql' => $self->config_value($obj, 'storage.value.sql'),
'storage_index' => $self->config_value($obj, 'storage.index'),
'storage_deploy' => $self->config_value($obj, 'storage.deploy'),
'storage_retreat' => $self->config_value($obj, 'storage.retreat'),
'storage_table' => $self->config_value($obj, 'storage.table'),
'storage_table_filter' => $self->filter_func($self->config_value_inherited($obj, 'storage.table.filter', '')),
'storage_name' => $self->config_value($obj, 'storage.name'),
'storage_aggregation' => $self->config_value($obj, 'storage.aggregation'),
'storage_field_id' => $self->config_value($obj, 'storage.field.id'),
'storage_field_class' => $self->config_value($obj, 'storage.field.class'),
'storage_deploy_table' => $self->config_value_inherited_true($obj, 'storage.deploy.table', 1),
# Class/model version.
'version' => $self->config_value_inherited($obj, 'version', '1.0'),
# Enumerate common isa tests.
map(($_ => $obj->$_),
'isaClass',
'isaAssociation',
'isaAssociationEnd',
'isaAssociationClass',
'isaInterface',
'isaEnumeration',
'isaPrimitive',
'isaDataType',
'isaAttribute',
'isaOperation',
'isaMethod',
'isaParameter',
'isaPackage',
),
);
#print STDERR "$obj $obj->{name} generate=$vals{generate}\n";
#print STDERR "__id($obj)->namepace = $namespace\n";
%vals;
}
sub __id_namespace
{
my ($self, $obj) = @_;
return undef unless defined $obj;
my $cache = $self->{'.namespace'} ||= { };
my $x;
unless ( $x = $cache->{$obj} ) {
$x = $cache->{$obj} =
{
$self->__id($obj),
};
}
$x;
}
sub filter_non_alphanum
{
my ($self, $x) = @_;
$self;
}
sub template_vars
{
my ($self, $model) = @_;
my $v = { };
$v->{'model'} = $model;
$v->{'template'} = $self;
$v->{'template_file'} = $self->template_file;
print STDERR "\n\nPreparing template vars:\n" if $self->{'verbose'} > 0;
# $DB::single = 1;
$self->{'model_packagePrefix'} ||= $self->{'packagePrefix'};
# Note:
# UMMF::Export::Perl::Tangram::Storage
# relys on UML::__ObjectBase being the base class of all generated classes!
# Need some method for importing all those methods into the $packagePrefix::__ObjectBase.pm
# -- ks 2005/10/16
$self->{'model_packagePrefix'} = [ 'UML' ]
unless $self->{'model_packagePrefix'} && @{$self->{'model_packagePrefix'}};
$v->{'model_package'} = $self->package_name($self->{'model_packagePrefix'});
$v->{'model_package_'} = $self->package_name([ @{$self->{'model_packagePrefix'}}, '' ]);
$v->{'model_package_file'} = $self->package_file_name($self->{'model_packagePrefix'});
$v->{'model_package_dir'} = $self->package_dir_name($self->{'model_packagePrefix'});
{
my $ob = [ @{$self->{'model_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);
}
if ( 0 ) {
# local $UMMF::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, %obj_v, %v_obj);
my (@assocEnd, @assocEnd_v);
$v->{'classifier'} = \@cls_v;
$v->{'associationEnd'} = \@assocEnd_v;
my @cls_all = Namespace_classifier($model);
for my $cls ( @cls_all ) {
print STDERR "Classifier $cls->{name} \t:\n" if $self->{'verbose'} > 1;
unless ( $self->template_enabled($cls) ) {
# print STDERR "IGNORED!\n";
next;
}
#print STDERR "OK!\n";
my $primitive_type = $self->config_value($cls, 'primitive.type');
my $primitive = $self->config_value_true($cls, 'primitive', ! ! $primitive_type);
my $x = {
$self->__id($cls),
'primitive' => $primitive,
'primitive_type' => $primitive_type,
'construct_type' => $self->config_value($cls, 'construct.type'),
'validate_type' => $self->config_value($cls, 'validate.type'),
'validate_type_type' => $self->config_value($cls, 'validate.type.type'),
'construct' => $self->config_value($cls, 'construct'),
'construct_type' => $self->config_value($cls, 'construct.type'),
map(($_ => String_toBoolean(scalar $cls->$_())),
'isRoot',
'isLeaf',
'isAbstract',
'isSpecification',
),
map(($_ => $cls->$_()),
'visibility',
),
};
# Trap java::lang::boolean crap.
if ( 0 ) {
if ( $x->{name_q} =~ /java/ && $x->{name_q} =~ /lang/ && $x->{name_q} =~ /boolean/ ) {
print STDERR
"ARGGH: java.lang crap:\n",
Data::Dumper->new([$x], [qw($x)])
->Indent(2)
->Sortkeys(1)
->Dump;
# exit 1;
}
}
#$x->{'primitive_type'} ||= $x->{'package'};
#$x->{'construct_type'} ||= $x->{'primitive_type'};
#$x->{'validate_type_type'} ||= $x->{'construct_type'};
#$x->{'storage_type'} || $x->{'primitive_type'};
push(@cls_v, $x);
$obj_v{$cls} = $x;
$v_obj{$x} = $cls;
}
@cls_v = sort { $a->{'name_q'} cmp $b->{'name_q'} } @cls_v;
# Initialize the factory map.
{
my @factory_map;
$v->{'factory_map'} = \@factory_map;
for my $x ( @cls_v ) {
if ( $x->{'generate'} ) {
my $cls_name = $x->{'name'};
my $cls_name_q = $x->{'name_q_raw'};
my $pkg_name = $x->{'package'};
push(@factory_map,
$cls_name => $pkg_name,
$cls_name_q => $pkg_name,
);
}
}
}
# 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 $obj_v{$end};
print STDERR "AssociationEnd $cls->{name} :: $end->{name}\n" if $self->{'verbose'} > 1;
my $name = $end->name;
# $DB::single = 1 unless $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, undef, $cls),
'type' => $self->package_name($type, undef, undef),
'type_obj' => $type,
'type_info' => $obj_v{$type},
'type_impl' => $self->config_value($end, 'type.impl'),
'weak_ref_enabled' => $self->config_value_inherited_true($end, 'weak_ref_enabled'),
'container_type' => $self->config_value($end, 'container.type'),
'container_type_ordered' => $self->config_value_inherited($end, 'container.type.ordered'),
'container_type_unordered' => $self->config_value_inherited($end, 'container.type.unordered'),
'multi' => Multiplicity_asString($multi),
'multi_lower' => Multiplicity_lower($multi),
'multi_upper' => Multiplicity_upper($multi),
'multi_single' => Multiplicity_upper($multi) eq '1',
map(($_ => $end->$_()),
'visibility',
'ordering',
'aggregation',
'targetScope',
'changeability',
)
};
$x->{'weak_ref'} = $x->{'weak_ref_enabled'} && $self->config_value($end, 'weak_ref');
# Cant nav if it doesn't have a name.
$x->{'isNavigable'} = 0 unless $x->{'name'};
if ( 0 && $x->{'phantom'} ) {
my $assoc = AssociationEnd_association($end);
print STDERR "\nPHANTOM: $cls->{name}\t : $end \n", Association_asString($assoc), "\n";
}
# Remember it.
push(@assocEnd, $end);
push(@assocEnd_v, $x);
$obj_v{$end} = $x;
$v_obj{$x} = $end;
print STDERR "AssociationEnd $cls->{name} :: $end->{name}\t: DONE\n" if $self->{'verbose'} > 1;
}
}
@assocEnd = sort { $a->{'name'} cmp $b->{'name'} } @assocEnd;
@assocEnd_v = sort { $a->{'name'} cmp $b->{'name'} } @assocEnd_v;
# print STDERR "assocs: ", join(",\n ", sort keys %assoc_v), "\n";
# Add opposites to each End.
for my $end ( @assocEnd ) {
my $xx = \%obj_v; # Bug in perl parser?!?!
# The association relationship with the AssociationEnds
# on the other side must be maintained.
my @x = AssociationEnd_opposite($end);
@x =
map(
$xx->{$_} || confess("No assoc_v for '$_->{name}' ($_)"),
@x,
);
# @x = sort { $a->{'name'} cmp $b->{'name'} } @x;
my $v = $obj_v{$end};
$v->{'opposite'} = \@x;
$v->{'opposites'} = scalar @x;
}
# Create Association.
{
my @assoc_v;
for my $end ( @assocEnd ) {
my $assoc = AssociationEnd_association($end) || confess("No Association for $end");
my $x = $obj_v{$assoc};
unless ( $x ) {
$x = {
$self->__id($assoc),
'connection' => [ map($obj_v{$_} || die(), $assoc->connection) ],
};
# Give each AssociationEnd a relative position in the Association connection.
my $i = -1;
for my $c ( @{$x->{'connection'}} ) {
$c->{'i'} = ++ $i;
}
push(@assoc_v, $x);
$obj_v{$assoc} = $x;
}
# Add links from end to the assoc.
my $end_v = $obj_v{$end} || die();
$end_v->{'assoc'} = $x;
}
@assoc_v = sort { $a->{'name'} cmp $b->{'name'} } @assoc_v;
$v->{'association'} = \@assoc_v;
$v->{'associations'} = scalar @assoc_v;
}
# Find all Operations
for my $cls ( @cls_all ) {
my $cls_v = $obj_v{$cls};
# Operation
my @op;
$cls_v->{'operation'} = \@op;
for my $op ( $self->operation($cls) ) {
next if $obj_v{$op};
print STDERR "Operation $cls->{name} :: $op->{name}\t:\n" if $self->{'verbose'} > 1;
unless ( $self->template_enabled($op) ) {
# print STDERR "IGNORED!\n";
next;
}
my $return_param = Operation_return($op);
# Make the Operation's type the "return" params type.
my $type = $return_param->type || confess("Class " . $cls->name . ", Method " . $op->name . ", return Parameter " . $return_param->name . " has no type");
my $type_v = $obj_v{$type} || confess("Class " . $cls->name . ", Method " . $op->name . ", return Parameter " . $return_param->name . " cannot be mapped");
my $type_name = $type ? $self->package_name($type, undef, $cls) : 'void';
my @param;
# $DB::single = 1;
my $op_v = {
$self->__id($op),
'type' => $type_name,
'type_info' => $type_v,
'type_impl' => $self->config_value($return_param, 'type.impl'),
'instance' => $op->ownerScope ne 'classifier',
'parameter' => \@param,
map(($_ => $op->$_()),
'visibility',
'ownerScope',
'isQuery',
),
};
# IS THIS CORRECT? -- 2004/09/29
$op_v->{'type_impl'} ||=
$obj_v{$type}{'primitive_type'} ||
$op_v->{'type'};
# Trap java::lang::boolean crap.
if ( 1 ) {
if ( $op_v->{type_impl} =~ /java.*lang.*boolean/i ) {
print STDERR
"ARGGH: java.lang crap:\n",
Data::Dumper->new([$op_v], [qw($op_v)])
->Indent(1)
->Sortkeys(1)
->Dump;
exit 1;
}
}
# print STDERR " visibility = '$op_v->{visibility}'\n";
# print STDERR " ownerScope = '$op_v->{ownerScope}'\n";
push(@op, $op_v);
# Do Parameters that are not the return Parameter.
for my $param ( $op->parameter ) {
next if $param->name eq 'return';
my $type = $param->type || confess("Class " . $cls->name . ", Method " . $op->name . ", Parameter " . $param->name . " has no type");
my $type_name = $self->package_name($type, undef, $cls);
my $defaultValue = $self->get_Expression_body($param, $param, 'defaultValue');
my $param_v = {
$self->__id($param),
'type' => $type_name,
'type_info' => $obj_v{$type},
'type_impl' => $self->config_value($param, 'type.impl'),
'defaultValue_defined' => defined $defaultValue,
'defaultValue' => $defaultValue,
'kind' => $param->kind,
};
# IS THIS CORRECT? -- 2004/09/29
$param_v->{'type_impl'} ||=
$obj_v{$type}{'primitive_type'} ||
$param_v->{'type'};
# OLD CODE.
$param_v->{'type_impl'} ||= $param_v->{'type'};
$param_v->{'type_primitive'} ||=
$obj_v{$type}{'primitive_type'} || $param_v->{'type_impl'};
push(@param, $param_v);
}
$op_v->{'parameters'} = scalar @param;
$obj_v{$op} = $op_v;
$v_obj{$op_v} = $op;
}
$cls_v->{'operations'} = scalar @op;
}
# Internals in each class.
for my $cls_v ( @cls_v ) {
my $cls = $v_obj{$cls_v};
# Dependencies
{
my @dep;
$cls_v->{'dependency'} = \@dep;
for my $sup ( map($_->supplier,
$cls->clientDependency,
)
) {
my $sup_v = $obj_v{$sup};
push(@dep, $sup_v) if $sup_v;
# print STDERR "Classifier $cls->{name} Dependency -=-=-> $sup->{name}\n";
}
$cls_v->{'dependencys'} = scalar @dep;
}
# Usages
{
my @usage;
$cls_v->{'usage'} = \@usage;
for my $cls ( map($_->supplier,
grep($_->isaUsage,
$cls->clientDependency,
)
)
) {
my $usage_v = $obj_v{$cls};
push(@usage, $usage_v->{'package'});
}
# $DB::single = 1 if $cls->name eq 'Time';
my $usage = $self->config_value($cls, 'usage', '');
push(@usage, split(/\s*[,;]\s*|\s+/, $usage));
@usage = sort unique(@usage);
$cls_v->{'usages'} = scalar @usage;
}
# Imports
# Poseidon uses TaggedValues for JavaImportStatement.
{
my @import;
$cls_v->{'import'} = \@import;
# Poseidon-specific.
my $JavaImportStatement = ModelElement_taggedValue_name($cls, 'JavaImportStatement', '');
@import = split(/\s*:\s*/, $JavaImportStatement);
# Editor-inspecific.
# Handle translation of import UML names to impl package names.
my $import = $self->config_value($cls, 'import', '');
my @x = split(/\s*[;,]\s*/, $import);
@x = map(eval { Namespace_ownedElement_name($cls, $_) } || $_, @x);
@x = map(($obj_v{$_} && $obj_v{$_}{'package'}) || $_, @x);
push(@import, @x);
$cls_v->{'imports'} = scalar @import;
}
# Header/Footer
{
# Editor-inspecific.
my $header = $self->config_value($cls, 'header', '');
$cls_v->{'header'} = $header;
my $footer = $self->config_value($cls, 'footer', '');
$cls_v->{'footer'} = $footer;
}
# 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($obj_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 = $obj_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 = $obj_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:\n" if $self->{'verbose'} > 1;
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;
# $DB::single = 1 if $name eq 'SUNDAY';
my $initialValue = $self->get_Expression_body($attr, $attr, 'initialValue');
my $accessor = sub { $self->config_value_inherited_true($attr, 'accessor', 'true'); };
my $getter = $self->config_value_inherited_true($attr, 'accessor.getter', $accessor);
my $setter = $self->config_value_inherited_true($attr, 'accessor.setter', $accessor);
# $DB::single = 1;
my $attr_v = {
$self->__id($attr),
'type' => $self->package_name($type, undef, $cls),
'type_info' => $obj_v{$type},
'type_impl' => $self->config_value($attr, 'type.impl'),
'weak_ref_enabled' => $self->config_value_inherited_true($attr, 'weak_ref.enabled'),
'container_type' => $self->config_value($attr, 'container.type'),
'container_type_ordered' => $self->config_value_inherited($attr, 'container.type.ordered'),
'container_type_unordered' => $self->config_value_inherited($attr, 'container.type.unordered'),
'multi' => Multiplicity_asString($multi),
'multi_lower' => Multiplicity_lower($multi),
'multi_upper' => Multiplicity_upper($multi),
'multi_single' => Multiplicity_upper($multi) eq '1',
'initialValue' => $initialValue,
'initialValue_defined' => defined $initialValue,
'instance' => $attr->ownerScope ne 'classifier',
'getter' => $getter,
'getter_before' => $self->config_value($attr, 'accessor.getter.before'),
'getter_after' => $self->config_value($attr, 'accessor.getter.after' ),
'setter' => $setter,
'setter_before' => $self->config_value($attr, 'accessor.setter.before'),
'setter_after' => $self->config_value($attr, 'accessor.setter.after' ),
map(($_ => $attr->$_()),
'visibility',
'ownerScope',
'changeability',
'targetScope',
'ordering',
),
};
$attr_v->{'weak_ref'} = $attr_v->{'weak_ref_enabled'} && $self->config_value($attr, 'weak_ref');
$attr_v->{'type_impl'} ||=
$obj_v{$type}{'primitive_type'} ||
$attr_v->{'type'};
$attr_v->{'storage_type'} ||=
$obj_v{$type}{'storage_type'}
;
# print STDERR "$cls_v->{package}::$attr_v->{name} storage_type = $attr_v->{storage_type}\n";
if ( 0 && $attr_v->{'name'} eq 'time' ) {
print STDERR "****************************************\n";
print STDERR join(",\n",
map("$_ = " . $attr_v->{$_},
sort keys %$attr_v,
)
), "\n";
}
push(@attr, $attr_v);
}
$cls_v->{'attributes'} = scalar @attr;
}
# Classifer participant <--> association AssociationEnd
{
my @assocEnd = map($obj_v{$_}, $cls->association);
# Remap end.type in relation to the cls.
my %end_map;
for my $cls_end ( @assocEnd ) {
$cls_end = $end_map{$cls_end} ||= { %$cls_end };
for my $x ( @{$cls_end->{'opposite'}} ) {
$x = $end_map{$x} ||= { %$x };
my $type = $x->{'type_obj'};
# Get the type name in the context of the class.
my $new_type = $self->package_name($type, undef, $cls);
if ( 0 && $new_type ne $x->{'type'} ) {
print STDERR "Export: Class $cls_v->{name_q}: AssociationEnd $x->{name}: type: $x->{type} => $new_type\n";
}
$x->{'type'} = $new_type;
# IS THIS CORRECT? -- 2004/09/29
if ( 1 ) {
$x->{'type_impl'} ||=
$obj_v{$type}{'primitive_type'} ||
$x->{'type'};
} else {
$x->{'type_impl'} ||= $x->{'type'};
}
$x->{'type_primitive'} ||=
$obj_v{$type}{'primitive_type'} || $x->{'type_impl'};
$x->{'storage_type'} ||=
$obj_v{$type}{'storage_type'};
# Trap java::lang::boolean crap.
if ( 0 ) {
if ( $x->{type_impl} !~ /[^a-z0-9_]/i ) {
print STDERR
"ARGGH: java.lang crap:\n",
Data::Dumper->new([$x], [qw($x)])
->Indent(1)
->Sortkeys(1)
->Dump;
exit 1;
}
}
}
}
@assocEnd = sort { ($a->{'opposite'}[0]{'name'} || $a->{'name'})
cmp
($b->{'opposite'}[0]{'name'} || $b->{'name'})
} @assocEnd;
$cls_v->{'association'} = \@assocEnd;
$cls_v->{'associations'} = scalar @assocEnd;
}
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;
}
# Method
{
my @meth;
$cls_v->{'method'} = \@meth;
$cls_v->{'default_constructor'} = undef;
for my $meth ( $self->method($cls) ) {
# Get the Method's specification (Operation).
my $op = $meth->specification;
my $op_v = $obj_v{$op};
print STDERR "Method $cls->{name} :: $op->{name}\t:\n" if $self->{'verbose'} > 1;
unless ( $self->template_enabled($meth) ) {
# print STDERR "IGNORED!\n";
next;
}
my $name = $op->name;
# Get the method body for this export language type.
my $body = $self->get_Expression_body($op, $meth, 'body');
# $DB::single = 1;
my $meth_v = {
$self->__id($meth),
map(($_ => $meth->$_()),
# Note: ArgoUML/Poseidon does not define these;
# see method->specification Operation object.
'visibility',
'ownerScope',
'isQuery',
),
'instance' => $meth->ownerScope ne 'classifier',
'op' => $op_v,
'specification' => $obj_v{$op},
'body' => $body,
'body_defined' => defined $body,
};
# If the Operation is <<create>> and it has no parameters,
# The method is the default constructor.
if ( $op_v->{'has_stereotype'}{'create'} && @{$op_v->{'parameter'}} == 0 ) {
$cls_v->{'default_constructor'} = $meth_v;
}
# print STDERR " visibility = '$meth_v->{visibility}'\n";
# print STDERR " ownerScope = '$meth_v->{ownerScope}'\n";
push(@meth, $meth_v);
}
$cls_v->{'methods'} = scalar @meth;
}
}
print STDERR "\n\nPreparing template vars: DONE\n" if $self->{'verbose'} > 0;
$v;
}
#######################################################################
my %filter_func;
sub filter_func
{
my ($self, $expr) = @_;
my $sub_expr;
$filter_func{$expr} ||= eval($sub_expr = 'sub { no warnings; local($_) = @_; return $_ unless defined $_; ' . $expr . ' ; $_; }') || die("$@: in expr\n: $sub_expr");
}
#######################################################################
sub get_Expression_body
{
my ($self, $cobj, $obj, $key, $lang) = @_;
$lang ||= $self->config_kind;
# print STDERR "$cobj->{name} $key\n";
#$DB::single = 1;
# Get language-specific Expression body.
my $lang_value = $self->get_Expression_body_1($cobj, $obj, $key, $lang);
my $value = $lang_value;
# Get language-inspecific Expression body if there is no language-specific
# Expression body.
unless ( defined $value ) {
$value = $self->get_Expression_body_1($cobj, $obj, $key); # Any language.
}
# Is the Expression body
# explicitly ok for this language?
my $lang_ok = $self->config_value_inherited_true($cobj, "$key.ok");
if ( $lang_ok ) {
return $value;
}
# Does the Expression body contain language-specific tagged code, like:
# // UMMF_LANG:java
# java.lang.Object foo = x.somemethod(y);
# # UMMF_LANG:perl
# my $foo = $x->somemethod($y)
#
# If so, pull out the code for the specified $lang.
#
if ( defined $value && $value =~ m@(//+|#+)\s*UMMF[_-]LANG\s*:@is ) {
my $out = '';
# $DB::single = 1;
$value = "\n$value\n#UMMF_LANG\n"; # Anchor
while ( $value =~ s@\n\s*(//+|#+)\s*UMMF[_-]LANG\s*:\s*$lang\s*\n(.*?)(\n\s*(//+|#+)\s*UMMF[_-]LANG)@$3@is ) {
$out .= $2;
}
# Trim leading/trailing whitespace, make undef if it has no length.
$value = trim_ws_undef($out);
} else {
# Go back to language-specific Expression body.
$value = $lang_value;
}
$value;
}
sub get_Expression_body_1
{
my ($self, $cobj, $obj, $key, $lang) = @_;
# Try explicit config value.
# Trim leading/trailing whitespace, make undef if it has no length.
my $value = trim_ws_undef($self->config_value($cobj, $key));
# Try actual Expression body for specified language.
unless ( defined $value ) {
$value = trim_ws_undef(Expression_body_language($obj->$key, $lang));
}
$value;
}
#######################################################################
sub template_enabled
{
my ($self, $node, @args) = @_;
1; # $self->config_enabled($node, @args);
}
#######################################################################
1;
#######################################################################
### Keep these comments at end of file: kstephens@users.sourceforge.net 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: ###