[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / XML / XMI.pm

package SQL::Translator::Parser::XML::XMI;

# -------------------------------------------------------------------
# $Id: XMI.pm,v 1.5 2003-09-09 01:37:25 grommit Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Parser::XML::XMI - Parser to create Schema from UML
Class diagrams stored in XMI format.

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::XML::XMI;

  my $translator     = SQL::Translator->new(
      from           => 'XML-XMI',
      to             => 'MySQL',
      filename       => 'schema.xmi',
      show_warnings  => 1,
      add_drop_table => 1,
  );

  print $obj->translate;

=head1 DESCRIPTION

=head2 UML Data Modeling

To tell the parser which Classes are tables give them a <<Table>> stereotype.

Any attributes of the class will be used as fields. The datatype of the
attribute must be a UML datatype and not an object, with the datatype's name
being used to set the data_type value in the schema.

Primary keys are attributes marked with <<PK>> stereotype.

=head2 XMI Format

The parser has been built using XMI generated by PoseidonUML 2beta, which
says it uses UML 2. So the current conformance is down to Poseidon's idea
of XMI!

=head1 ARGS

=over 4

=item visibility

 visibilty=public|protected|private

What visibilty of stuff to translate. e.g when set to 'public' any private
and package Classes will be ignored and not turned into tables. Applies
to Classes and Attributes.

If not set or false (the default) no checks will be made and everything is
translated.

=back

=cut

# -------------------------------------------------------------------

use strict;

use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use Data::Dumper;
use Exporter;
use base qw(Exporter);
@EXPORT_OK = qw(parse);

use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
use SQL::Translator::Utils 'debug';
use XML::XPath;
use XML::XPath::XMLParser;

# XMI XPath parsing
#-----------------------------------------------------------------------------

#
# get_classes( XPATHOBJ, ARGS );
#
# XPATHOBJ - An XML::XPath object setup and ready to use. You can also use any
#            Node to search from as this sub just calls findnodes() on the arg.
#
# ARGS     - Name/Value list of args.
#
# xpath  =>  The xpath to use for finding classes. Default is //UML:Classes
#            which will find all the classes in the XMI.
#
# test   =>  An XPath predicate (ie the bit between [] ) to test the
#            classes with to decide if we should parse them. ie
#            test => '@name' would only pass out classes with a name.
#            Can also give it an array ref and it will and the tests.
#            It gets tacked onto to xpath so don't put any [] on
#            xpath if you use test as well.
#
# attribute_test => An XPath predicate to pass onto get_attributes.
#

# _add_xpath_tests $path, [qw/@name xmiVisible("public")/]; # and
# _add_xpath_tests $path, [qw/@name xmiVisible("public")/], "or";
sub _add_xpath_tests {
    my ($path,$tests,$join) = @_;
	return $path unless defined $tests;
	my @tests = ref($tests) ? @$tests : $tests;
	return $path unless @tests;
    $join ||= "and";
    return $path."[".join(" $join ", @tests)."]";
}

sub get_stereotype {
    my ($xp) = @_;
    return "".$xp->findvalue(
        'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');
    # TODO Test for difference between it existing or being "" ?
}

sub get_classes {
	my ($xp,%args) = @_;
	my $classes;

	my $xpath = $args{xpath} ||= '//UML:Class'; # Default: all classes
    $xpath = _add_xpath_tests $xpath, $args{test};
	debug "Searching for Classes using:$xpath";

	my @nodes = $xp->findnodes($xpath);
	return unless @nodes;

	for my $classnode (@nodes) {
        my $class = {};
		
        foreach (
			qw/name visibility isSpecification
			   isRoot isLeaf isAbstract isActive/
		) {
			$class->{$_} = $classnode->getAttribute($_);
		}
		$class->{stereotype} = get_stereotype($classnode);

        $class->{attributes} = get_attributes( $classnode,
            xpath => 'UML:Classifier.feature/UML:Attribute',
            test => $args{attribute_test} );
        
        $class->{operations} = get_operations( $classnode,
            xpath => '//UML:Classifier.feature/UML:Operation',
            test => $args{operation_test} );
		
        push @$classes, $class;
	}
	return wantarray ? @$classes : $classes;
};

sub get_attributes {
    my ($xp, %args) = @_;

	my $xpath = $args{xpath} ||= '//UML:Classifier.feature/UML:Attribute';
    $xpath = _add_xpath_tests $xpath, $args{test};
	debug "Searching for Attributes using:$xpath";
	
    my $attributes;
    foreach my $node ( $xp->findnodes($xpath) ) {
        my $attr = {};
        
        foreach (qw/name visibility isSpecification ownerScope/) {
            $attr->{$_} = $node->getAttribute($_);
        }
        $attr->{stereotype} = get_stereotype($node);

        # Get datatype name and the body of the initial value
        $attr->{datatype} = "".$node->find(
              'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name');
        if ( my @body = $node->findnodes(
            'UML:Attribute.initialValue/UML:Expression/@body') 
        ) {
            $attr->{initialValue} = $body[0]->getData;
        }
        
        push @$attributes, $attr;
    }
    return wantarray ? @$attributes : $attributes;
}

sub get_operations {
    my ($xp, %args) = @_;

	my $xpath = $args{xpath} ||= '//UML:Classifier.feature/UML:Operation';
    $xpath = _add_xpath_tests $xpath, $args{test};
	debug "Searching for operations using:$xpath";
	
    my $operations;
    foreach my $node ( $xp->findnodes($xpath) ) {
        my $operation = {};
        
        foreach (qw/name visibility isSpecification ownerScope isQuery
            concurrency isRoot isLeaf isAbstract/) {
            $operation->{$_} = $node->getAttribute($_);
        }
        $operation->{stereotype} = get_stereotype($node);

        $operation->{parameters} = get_parameters( $node,
            xpath => 'UML:BehavioralFeature.parameter/UML:Parameter',
            test  => $args{attribute_test} 
        );
        
        push @$operations, $operation;
    }
    return wantarray ? @$operations : $operations;
}

sub get_parameters {
    my ($xp, %args) = @_;

	my $xpath = $args{xpath} ||= '//UML:Classifier.feature/UML:Attribute';
    $xpath = _add_xpath_tests $xpath, $args{test};
	debug "Searching for Attributes using:$xpath";
	
    my $parameters;
    foreach my $node ( $xp->findnodes($xpath) ) {
        my $parameter = {};
        
        foreach (qw/name isSpecification kind/) {
            $parameter->{$_} = $node->getAttribute($_);
        }
        $parameter->{stereotype} = get_stereotype($node);

        $parameter->{datatype} = "".$node->find(
              'xmiDeref(UML:Parameter.type/UML:DataType)/@name');
        
        push @$parameters, $parameter;
    }
    return wantarray ? @$parameters : $parameters;
}

# SQLFairy Parser
#-----------------------------------------------------------------------------

sub parse {
	eval {

    my ( $translator, $data ) = @_;
    local $DEBUG    = $translator->debug;
    my $schema      = $translator->schema;
    my $pargs       = $translator->parser_args;

    debug "Visibility Level:$pargs->{visibility}" if $DEBUG;

    my $xp = XML::XPath->new(xml => $data);
    $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
    #
    # TODO
    # - Options to set the initial context node so we don't just
    #   blindly do all the classes. e.g. Select a diag name to do.

	#
    # Build an XPath for the classes and attributes we want...
	#
    # Only classes with an id (so we don't get any refs to classes ie 
    # xmi.idref classes). They also need a name to be usefull.
    my @tests = ('@xmi.id and @name');
	push @tests, "xmiVisible('$pargs->{visibility}')" if $pargs->{visibility};

	my $attrib_test = '@name and @xmi.id';
	$attrib_test .= " and xmiVisible('$pargs->{visibility}')"
	    if $pargs->{visibility};

	# ...and parse them out
	my $classes = get_classes( $xp,
		xpath => "//UML:Class", test => [@tests], attribute_test => $attrib_test);

    debug "Found ".scalar(@$classes)." Classes: ".join(", ",
        map {$_->{"name"}} @$classes) if $DEBUG;
	debug "Classes:",Dumper($classes);

	#
	# Turn the data from get_classes into a Schema
	#
	foreach my $class (@$classes) {
        next unless $class->{stereotype} eq "Table";

        # Add the table
        debug "Adding class: $class->{name}" if $DEBUG;
        my $table = $schema->add_table( name => $class->{name} )
            or die "Schema Error: ".$schema->error;

        #
        # Fields from Class attributes
        #
        # name data_type size default_value is_nullable
        # is_auto_increment is_primary_key is_foreign_key comments
        #
        foreach my $attr ( @{$class->{attributes}} ) {
			my %data = (
                name           => $attr->{name},
                data_type      => $attr->{datatype},
                is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
                #is_foreign_key => $stereotype eq "FK" ? 1 : 0,
            );
			$data{default_value} = $attr->{initialValue}
				if exists $attr->{initialValue};

            debug "Adding field:",Dumper(\%data);
            my $field = $table->add_field( %data ) or die $schema->error;

            $table->primary_key( $field->name ) if $data{'is_primary_key'};
            #
            # TODO:
            # - We should be able to make the table obj spot this when
            #   we use add_field.
            #
        }

    } # Classes loop

    return 1;

	};
	print "ERROR: $@\n" if $@;
	return 1;
}

1;

#=============================================================================
#
# XML::XPath extensions
#
#=============================================================================

package XML::XPath::Function;

=head1 XMI XPath Functions

The Parser adds the following extra XPath functions.

=head2 xmiDeref

Deals with xmi.id/xmi.idref pairs of attributes. You give it an
xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
tag it points at has an xmi.idref it looks up the tag with that
xmi.id and returns it.

If it doesn't have an xmi.id, the path is returned as normal.

e.g. given

 <UML:ModelElement.stereotype>
     <UML:Stereotype xmi.idref = 'stTable'/>
 </UML:ModelElement.stereotype>
  ...
 <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
     isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
     <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 </UML:Stereotype>

Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
<UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.

Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
"Table".

=head xmiVisible

 is_visible( VISLEVEL )

Returns true or false for whether the visibility of something e.g. a Class or
Attribute, is visible at the level given. e.g.

 //UML:Class[xmiVisible('public')]       - Find all public classes
 //UML:Class[xmiVisible('protected')]    - Find all public and protected classes

Supports the 3 UML visibility levels of public, protected and private.

Note: Currently any element tested that doesn't have a visibility="" attribute
is assumed to be visible and so xmiVisible will return true. This is probably
the wrong thing to do and is very likley to change. It is probably best to
throw an error if we try to test something that doesn't do visibility.

=cut

sub xmiDeref {
    my $self = shift;
    my ($node, @params) = @_;
    if (@params > 1) {
        die "xmiDeref() function takes one or no parameters\n";
    }
    elsif (@params) {
        my $nodeset = shift(@params);
        return $nodeset unless $nodeset->size;
        $node = $nodeset->get_node(1);
    }
    die "xmiDeref() needs an Element node." 
    unless $node->isa("XML::XPath::Node::Element");

    my $id = $node->getAttribute("xmi.idref") or return $node;
    return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
}

{
    my %vislevel = (
        public => 1,
        protected => 2,
        private => 3,
    );

    sub xmiVisible {
		my $self = shift;
		my ($node, @params) = @_;
		if (@params < 1 or @params > 2) {
			die "xmiVisible() function takes 1 or 2 parameters\n";
		}
		elsif (@params == 2) {
			my $nodeset = shift(@params);
			return unless $nodeset->size;
			$node = $nodeset->get_node(1);
		}
		die "xmiVisible() needs an Element node." 
		unless $node->isa("XML::XPath::Node::Element");

		my $vis = shift(@params) || return XML::XPath::Boolean->True;
		my $nodevis = $node->getAttribute("visibility")
			|| return XML::XPath::Boolean->True;
        return XML::XPath::Boolean->True
			if $vislevel{$vis} >= $vislevel{$nodevis};
        return XML::XPath::Boolean->False;
    }
}

# Test of custom xpath function.
sub hello {
    return XML::XPath::Literal->new("Hello World");
}

#=============================================================================
package main;


=pod

=head1 BUGS

Seems to be slow. I think this is because the XMI files can get pretty
big and complex, especially all the diagram info.

=head1 TODO

B<field sizes> Don't think UML does this directly so may need to include
it in the datatype names.

B<Check the Tag Attribute lists in get_* subs> I have taken them from looking
at Poseidon so need to check against XMI spec.

B<table_visibility and field_visibility args> Seperate control over what is 
parsed, setting visibility arg will set both.

Everything else! Relations, fkeys, constraints, indexes, etc...

=head1 AUTHOR

Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.

=head1 SEE ALSO

perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
SQL::Translator::Schema.

=cut
Commit	Line	Data
1223c9b2	1	package SQL::Translator::Parser::XML::XMI;
	2
	3	# -------------------------------------------------------------------
5cb154e5	4	# $Id: XMI.pm,v 1.5 2003-09-09 01:37:25 grommit Exp $
1223c9b2	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=head1 NAME
	24
	25	SQL::Translator::Parser::XML::XMI - Parser to create Schema from UML
	26	Class diagrams stored in XMI format.
	27
f8ec05fa	28	=head1 SYNOPSIS
	29
	30	use SQL::Translator;
	31	use SQL::Translator::Parser::XML::XMI;
	32
	33	my $translator = SQL::Translator->new(
	34	from => 'XML-XMI',
	35	to => 'MySQL',
	36	filename => 'schema.xmi',
	37	show_warnings => 1,
	38	add_drop_table => 1,
	39	);
	40
	41	print $obj->translate;
	42
	43	=head1 DESCRIPTION
	44
	45	=head2 UML Data Modeling
	46
	47	To tell the parser which Classes are tables give them a <<Table>> stereotype.
	48
	49	Any attributes of the class will be used as fields. The datatype of the
	50	attribute must be a UML datatype and not an object, with the datatype's name
	51	being used to set the data_type value in the schema.
	52
	53	Primary keys are attributes marked with <<PK>> stereotype.
	54
	55	=head2 XMI Format
	56
	57	The parser has been built using XMI generated by PoseidonUML 2beta, which
	58	says it uses UML 2. So the current conformance is down to Poseidon's idea
	59	of XMI!
	60
	61	=head1 ARGS
	62
	63	=over 4
	64
	65	=item visibility
	66
	67	visibilty=public\|protected\|private
	68
	69	What visibilty of stuff to translate. e.g when set to 'public' any private
	70	and package Classes will be ignored and not turned into tables. Applies
	71	to Classes and Attributes.
	72
	73	If not set or false (the default) no checks will be made and everything is
	74	translated.
	75
	76	=back
	77
1223c9b2	78	=cut
	79
	80	# -------------------------------------------------------------------
	81
	82	use strict;
	83
	84	use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
5cb154e5	85	$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
1223c9b2	86	$DEBUG = 0 unless defined $DEBUG;
	87
	88	use Data::Dumper;
	89	use Exporter;
	90	use base qw(Exporter);
	91	@EXPORT_OK = qw(parse);
	92
	93	use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
	94	use SQL::Translator::Utils 'debug';
	95	use XML::XPath;
	96	use XML::XPath::XMLParser;
	97
91ed9c32	98	# XMI XPath parsing
	99	#-----------------------------------------------------------------------------
	100
1223c9b2	101	#
f8ec05fa	102	# get_classes( XPATHOBJ, ARGS );
1223c9b2	103	#
f8ec05fa	104	# XPATHOBJ - An XML::XPath object setup and ready to use. You can also use any
f8ec05fa	105	# Node to search from as this sub just calls findnodes() on the arg.
ef2d7798	106	#
f8ec05fa	107	# ARGS - Name/Value list of args.
ef2d7798	108	#
f8ec05fa	109	# xpath => The xpath to use for finding classes. Default is //UML:Classes
f8ec05fa	110	# which will find all the classes in the XMI.
ef2d7798	111	#
91ed9c32	112	# test => An XPath predicate (ie the bit between [] ) to test the
	113	# classes with to decide if we should parse them. ie
	114	# test => '@name' would only pass out classes with a name.
	115	# Can also give it an array ref and it will and the tests.
	116	# It gets tacked onto to xpath so don't put any [] on
	117	# xpath if you use test as well.
	118	#
	119	# attribute_test => An XPath predicate to pass onto get_attributes.
f8ec05fa	120	#
91ed9c32	121
	122	# _add_xpath_tests $path, [qw/@name xmiVisible("public")/]; # and
	123	# _add_xpath_tests $path, [qw/@name xmiVisible("public")/], "or";
	124	sub _add_xpath_tests {
	125	my ($path,$tests,$join) = @_;
	126	return $path unless defined $tests;
	127	my @tests = ref($tests) ? @$tests : $tests;
	128	return $path unless @tests;
	129	$join \|\|= "and";
	130	return $path."[".join(" $join ", @tests)."]";
	131	}
	132
	133	sub get_stereotype {
	134	my ($xp) = @_;
	135	return "".$xp->findvalue(
	136	'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');
	137	# TODO Test for difference between it existing or being "" ?
	138	}
	139
f8ec05fa	140	sub get_classes {
f8ec05fa	141	my ($xp,%args) = @_;
91ed9c32	142	my $classes;
f8ec05fa	143
f8ec05fa	144	my $xpath = $args{xpath} \|\|= '//UML:Class'; # Default: all classes
91ed9c32	145	$xpath = _add_xpath_tests $xpath, $args{test};
91ed9c32	146	debug "Searching for Classes using:$xpath";
f8ec05fa	147
	148	my @nodes = $xp->findnodes($xpath);
	149	return unless @nodes;
	150
	151	for my $classnode (@nodes) {
	152	my $class = {};
91ed9c32	153
91ed9c32	154	foreach (
f8ec05fa	155	qw/name visibility isSpecification
	156	isRoot isLeaf isAbstract isActive/
	157	) {
	158	$class->{$_} = $classnode->getAttribute($_);
	159	}
91ed9c32	160	$class->{stereotype} = get_stereotype($classnode);
f8ec05fa	161
91ed9c32	162	$class->{attributes} = get_attributes( $classnode,
5cb154e5	163	xpath => 'UML:Classifier.feature/UML:Attribute',
5cb154e5	164	test => $args{attribute_test} );
91ed9c32	165
5cb154e5	166	$class->{operations} = get_operations( $classnode,
	167	xpath => '//UML:Classifier.feature/UML:Operation',
	168	test => $args{operation_test} );
	169
	170	push @$classes, $class;
f8ec05fa	171	}
91ed9c32	172	return wantarray ? @$classes : $classes;
f8ec05fa	173	};
ef2d7798	174
91ed9c32	175	sub get_attributes {
	176	my ($xp, %args) = @_;
	177
	178	my $xpath = $args{xpath} \|\|= '//UML:Classifier.feature/UML:Attribute';
	179	$xpath = _add_xpath_tests $xpath, $args{test};
	180	debug "Searching for Attributes using:$xpath";
	181
	182	my $attributes;
	183	foreach my $node ( $xp->findnodes($xpath) ) {
	184	my $attr = {};
	185
	186	foreach (qw/name visibility isSpecification ownerScope/) {
	187	$attr->{$_} = $node->getAttribute($_);
	188	}
	189	$attr->{stereotype} = get_stereotype($node);
	190
5cb154e5	191	# Get datatype name and the body of the initial value
91ed9c32	192	$attr->{datatype} = "".$node->find(
	193	'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name');
	194	if ( my @body = $node->findnodes(
	195	'UML:Attribute.initialValue/UML:Expression/@body')
	196	) {
	197	$attr->{initialValue} = $body[0]->getData;
	198	}
	199
	200	push @$attributes, $attr;
	201	}
	202	return wantarray ? @$attributes : $attributes;
	203	}
	204
5cb154e5	205	sub get_operations {
	206	my ($xp, %args) = @_;
	207
	208	my $xpath = $args{xpath} \|\|= '//UML:Classifier.feature/UML:Operation';
	209	$xpath = _add_xpath_tests $xpath, $args{test};
	210	debug "Searching for operations using:$xpath";
	211
	212	my $operations;
	213	foreach my $node ( $xp->findnodes($xpath) ) {
	214	my $operation = {};
	215
	216	foreach (qw/name visibility isSpecification ownerScope isQuery
	217	concurrency isRoot isLeaf isAbstract/) {
	218	$operation->{$_} = $node->getAttribute($_);
	219	}
	220	$operation->{stereotype} = get_stereotype($node);
	221
	222	$operation->{parameters} = get_parameters( $node,
	223	xpath => 'UML:BehavioralFeature.parameter/UML:Parameter',
	224	test => $args{attribute_test}
	225	);
	226
	227	push @$operations, $operation;
	228	}
	229	return wantarray ? @$operations : $operations;
	230	}
	231
	232	sub get_parameters {
	233	my ($xp, %args) = @_;
91ed9c32	234
5cb154e5	235	my $xpath = $args{xpath} \|\|= '//UML:Classifier.feature/UML:Attribute';
	236	$xpath = _add_xpath_tests $xpath, $args{test};
	237	debug "Searching for Attributes using:$xpath";
	238
	239	my $parameters;
	240	foreach my $node ( $xp->findnodes($xpath) ) {
	241	my $parameter = {};
	242
	243	foreach (qw/name isSpecification kind/) {
	244	$parameter->{$_} = $node->getAttribute($_);
	245	}
	246	$parameter->{stereotype} = get_stereotype($node);
	247
	248	$parameter->{datatype} = "".$node->find(
	249	'xmiDeref(UML:Parameter.type/UML:DataType)/@name');
	250
	251	push @$parameters, $parameter;
	252	}
	253	return wantarray ? @$parameters : $parameters;
	254	}
91ed9c32	255
	256	# SQLFairy Parser
	257	#-----------------------------------------------------------------------------
	258
1223c9b2	259	sub parse {
f8ec05fa	260	eval {
f8ec05fa	261
1223c9b2	262	my ( $translator, $data ) = @_;
	263	local $DEBUG = $translator->debug;
	264	my $schema = $translator->schema;
ef2d7798	265	my $pargs = $translator->parser_args;
1223c9b2	266
ef2d7798	267	debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
	268
	269	my $xp = XML::XPath->new(xml => $data);
1223c9b2	270	$xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
	271	#
	272	# TODO
	273	# - Options to set the initial context node so we don't just
	274	# blindly do all the classes. e.g. Select a diag name to do.
ef2d7798	275
f8ec05fa	276	#
	277	# Build an XPath for the classes and attributes we want...
	278	#
91ed9c32	279	# Only classes with an id (so we don't get any refs to classes ie
	280	# xmi.idref classes). They also need a name to be usefull.
	281	my @tests = ('@xmi.id and @name');
f8ec05fa	282	push @tests, "xmiVisible('$pargs->{visibility}')" if $pargs->{visibility};
f8ec05fa	283
91ed9c32	284	my $attrib_test = '@name and @xmi.id';
f8ec05fa	285	$attrib_test .= " and xmiVisible('$pargs->{visibility}')"
	286	if $pargs->{visibility};
	287
	288	# ...and parse them out
f8ec05fa	289	my $classes = get_classes( $xp,
91ed9c32	290	xpath => "//UML:Class", test => [@tests], attribute_test => $attrib_test);
f8ec05fa	291
	292	debug "Found ".scalar(@$classes)." Classes: ".join(", ",
	293	map {$_->{"name"}} @$classes) if $DEBUG;
	294	debug "Classes:",Dumper($classes);
	295
	296	#
	297	# Turn the data from get_classes into a Schema
	298	#
	299	foreach my $class (@$classes) {
	300	next unless $class->{stereotype} eq "Table";
ef2d7798	301
1223c9b2	302	# Add the table
f8ec05fa	303	debug "Adding class: $class->{name}" if $DEBUG;
f8ec05fa	304	my $table = $schema->add_table( name => $class->{name} )
1223c9b2	305	or die "Schema Error: ".$schema->error;
	306
	307	#
	308	# Fields from Class attributes
	309	#
ef2d7798	310	# name data_type size default_value is_nullable
1223c9b2	311	# is_auto_increment is_primary_key is_foreign_key comments
1223c9b2	312	#
f8ec05fa	313	foreach my $attr ( @{$class->{attributes}} ) {
	314	my %data = (
	315	name => $attr->{name},
	316	data_type => $attr->{datatype},
	317	is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
1223c9b2	318	#is_foreign_key => $stereotype eq "FK" ? 1 : 0,
1223c9b2	319	);
f8ec05fa	320	$data{default_value} = $attr->{initialValue}
f8ec05fa	321	if exists $attr->{initialValue};
1223c9b2	322
	323	debug "Adding field:",Dumper(\%data);
	324	my $field = $table->add_field( %data ) or die $schema->error;
	325
	326	$table->primary_key( $field->name ) if $data{'is_primary_key'};
	327	#
	328	# TODO:
ef2d7798	329	# - We should be able to make the table obj spot this when
1223c9b2	330	# we use add_field.
	331	#
	332	}
	333
	334	} # Classes loop
	335
	336	return 1;
f8ec05fa	337
	338	};
	339	print "ERROR: $@\n" if $@;
	340	return 1;
1223c9b2	341	}
	342
	343	1;
	344
f8ec05fa	345	#=============================================================================
	346	#
	347	# XML::XPath extensions
	348	#
	349	#=============================================================================
1223c9b2	350
f8ec05fa	351	package XML::XPath::Function;
1223c9b2	352
f8ec05fa	353	=head1 XMI XPath Functions
1223c9b2	354
f8ec05fa	355	The Parser adds the following extra XPath functions.
1223c9b2	356
f8ec05fa	357	=head2 xmiDeref
1223c9b2	358
f8ec05fa	359	Deals with xmi.id/xmi.idref pairs of attributes. You give it an
	360	xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
	361	tag it points at has an xmi.idref it looks up the tag with that
	362	xmi.id and returns it.
1223c9b2	363
f8ec05fa	364	If it doesn't have an xmi.id, the path is returned as normal.
1223c9b2	365
f8ec05fa	366	e.g. given
1223c9b2	367
f8ec05fa	368	<UML:ModelElement.stereotype>
	369	<UML:Stereotype xmi.idref = 'stTable'/>
	370	</UML:ModelElement.stereotype>
	371	...
	372	<UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
	373	isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
	374	<UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
	375	</UML:Stereotype>
1223c9b2	376
f8ec05fa	377	Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
f8ec05fa	378	<UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
1223c9b2	379
f8ec05fa	380	Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
f8ec05fa	381	"Table".
1223c9b2	382
f8ec05fa	383	=head xmiVisible
1223c9b2	384
f8ec05fa	385	is_visible( VISLEVEL )
1223c9b2	386
f8ec05fa	387	Returns true or false for whether the visibility of something e.g. a Class or
f8ec05fa	388	Attribute, is visible at the level given. e.g.
1223c9b2	389
f8ec05fa	390	//UML:Class[xmiVisible('public')] - Find all public classes
f8ec05fa	391	//UML:Class[xmiVisible('protected')] - Find all public and protected classes
1223c9b2	392
f8ec05fa	393	Supports the 3 UML visibility levels of public, protected and private.
1223c9b2	394
f8ec05fa	395	Note: Currently any element tested that doesn't have a visibility="" attribute
	396	is assumed to be visible and so xmiVisible will return true. This is probably
	397	the wrong thing to do and is very likley to change. It is probably best to
	398	throw an error if we try to test something that doesn't do visibility.
1223c9b2	399
f8ec05fa	400	=cut
1223c9b2	401
f8ec05fa	402	sub xmiDeref {
	403	my $self = shift;
	404	my ($node, @params) = @_;
	405	if (@params > 1) {
	406	die "xmiDeref() function takes one or no parameters\n";
	407	}
	408	elsif (@params) {
	409	my $nodeset = shift(@params);
	410	return $nodeset unless $nodeset->size;
	411	$node = $nodeset->get_node(1);
	412	}
	413	die "xmiDeref() needs an Element node."
	414	unless $node->isa("XML::XPath::Node::Element");
1223c9b2	415
f8ec05fa	416	my $id = $node->getAttribute("xmi.idref") or return $node;
	417	return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
	418	}
	419
	420	{
	421	my %vislevel = (
	422	public => 1,
	423	protected => 2,
	424	private => 3,
	425	);
	426
	427	sub xmiVisible {
	428	my $self = shift;
	429	my ($node, @params) = @_;
	430	if (@params < 1 or @params > 2) {
	431	die "xmiVisible() function takes 1 or 2 parameters\n";
	432	}
	433	elsif (@params == 2) {
	434	my $nodeset = shift(@params);
	435	return unless $nodeset->size;
	436	$node = $nodeset->get_node(1);
	437	}
	438	die "xmiVisible() needs an Element node."
	439	unless $node->isa("XML::XPath::Node::Element");
	440
	441	my $vis = shift(@params) \|\| return XML::XPath::Boolean->True;
	442	my $nodevis = $node->getAttribute("visibility")
	443	\|\| return XML::XPath::Boolean->True;
	444	return XML::XPath::Boolean->True
	445	if $vislevel{$vis} >= $vislevel{$nodevis};
	446	return XML::XPath::Boolean->False;
	447	}
	448	}
	449
	450	# Test of custom xpath function.
	451	sub hello {
	452	return XML::XPath::Literal->new("Hello World");
	453	}
	454
	455	#=============================================================================
	456	package main;
	457
	458
	459	=pod
1223c9b2	460
	461	=head1 BUGS
	462
ef2d7798	463	Seems to be slow. I think this is because the XMI files can get pretty
	464	big and complex, especially all the diagram info.
	465
1223c9b2	466	=head1 TODO
1223c9b2	467
ef2d7798	468	B<field sizes> Don't think UML does this directly so may need to include
1223c9b2	469	it in the datatype names.
1223c9b2	470
5cb154e5	471	B<Check the Tag Attribute lists in get_* subs> I have taken them from looking
	472	at Poseidon so need to check against XMI spec.
	473
ef2d7798	474	B<table_visibility and field_visibility args> Seperate control over what is
	475	parsed, setting visibility arg will set both.
	476
1223c9b2	477	Everything else! Relations, fkeys, constraints, indexes, etc...
	478
	479	=head1 AUTHOR
	480
	481	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
	482
	483	=head1 SEE ALSO
	484
	485	perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
	486	SQL::Translator::Schema.
	487
	488	=cut
f8ec05fa	489
f8ec05fa	490