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

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

# -------------------------------------------------------------------
# $Id$
# -------------------------------------------------------------------
# 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
# -------------------------------------------------------------------

=pod

=head1 NAME

SQL::Translator::XMI::Parser - XMI Parser class for use in SQL Fairy's XMI 
parser.

=cut

use strict;
use 5.006_001;
use vars qw/$VERSION/;
$VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/;

use Data::Dumper;
use XML::XPath;
use XML::XPath::XMLParser;
use Storable qw/dclone/;

# Spec
#------
# See SQL::Translator::XMI::Parser::V12 and SQL::Translator::XMI::Parser:V10
# for examples.
#
# Hash ref used to describe the 2 xmi formats 1.2 and 1.0. Neither is complete!
#
# NB The names of the data keys MUST be the same for both specs so the
# data structures returned are the same.
#
# TODO
# 
# * There is currently no way to set the data key name for attrib_data, it just
# uses the attribute name from the XMI. This isn't a problem at the moment as
# xmi1.0 names all these things with tags so we don't need the attrib data!
# Also use of names seems to be consistant between the versions.
#
#
# XmiSpec( $spec )
#
# Call as class method to set up the parser from a spec (see above). This
# generates the get_ methods for the version of XMI the spec is for. Called by
# the sub-classes (e.g. V12 and V10) to create parsers for each version.
#
sub XmiSpec {
	my ($me,$spec) = @_;
	_init_specs($spec);
	$me->_mk_gets($spec);
}

# Build lookups etc. Its important that each spec item becomes self contained
# so we can build good closures, therefore we do all the lookups 1st.
sub _init_specs {
	my $specs = shift;

	foreach my $spec ( values %$specs ) {
		# Look up for kids get method
		foreach ( @{$spec->{kids}} ) {
            $_->{get_method} = "get_".$specs->{$_->{class}}{plural};
        }

		# Add xmi.id ti all specs. Everything we want at the moment (in both
		# versions) has an id. The tags that don't seem to be used for
		# structure.
		my $attrib_data = $spec->{attrib_data} ||= [];
		push @$attrib_data, "xmi.id";
	}

}

# Create get methods from spec
#
sub _mk_gets {
    my ($proto,$specs) = @_;
    my $class = ref($proto) || $proto;
    foreach ( values %$specs ) {
        # Clone from specs and sort out the lookups into it so we get a
        # self contained spec to use as a proper closure.
        my $spec = dclone($_);

		# Create _get_* method with get_* as an alias unless the user has
		# defined it. Allows for override. Note the alias is in this package
		# so we can add overrides to both specs.
		no strict "refs";
		my $meth = "_get_$spec->{plural}";
		*{$meth} = _mk_get($spec);
		*{__PACKAGE__."::get_$spec->{plural}"} = sub {shift->$meth(@_);}
		 	unless $class->can("get_$spec->{plural}");
    }
}

#
# Sets up the XML::XPath object and then checks the version of the XMI file and
# blesses its self into either the V10 or V12 class.
#
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %args = @_;
    my $me = {};

    # Create the XML::XPath object
    # TODO Docs recommend we only use 1 XPath object per application
    my $xp;
    foreach (qw/filename xml ioref/) {
        if ($args{$_}) {
            $xp = XML::XPath->new( $_ => $args{$_});
            $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
            last;
        }
    }
    $me = { xml_xpath => $xp };

    # Work out the version of XMI we have and return as that sub class 
	my $xmiv = $args{xmi_version}
	    || "".$xp->findvalue('/XMI/@xmi.version')
        || die "Can't find XMI version";
	$xmiv =~ s/[.]//g;
	$class = __PACKAGE__."::V$xmiv";
	eval "use $class;";
	die "Failed to load version sub class $class : $@" if $@;

	return bless $me, $class;
}

#
# _mk_get
#
# Generates and returns a get_ sub for the spec given.
# So, if you want to change how the get methods (e.g. get_classes) work do it
# here!
#
# The get methods made have the args described in the docs and 2 private args
# used internally, to call other get methods from paths in the spec.
# NB: DO NOT use publicly as you will break the version independance. e.g. When
# using _xpath you need to know which version of XMI to use. This is handled by
# the use of different paths in the specs.
#
#  _context => The context node to use, if not given starts from root.
#
#  _xpath   => The xpath to use for finding stuff.
#
sub _mk_get {
    my $spec = shift;

    # get_* closure using $spec
    return sub {
	my ($me, %args) = @_;
    my $xp = delete $args{_context} || $me->{xml_xpath};
	my $things;

	my $xpath = $args{_xpath} ||= $spec->{default_path};
#warn "Searching for $spec->{plural} using:$xpath\n";

    my @nodes = $xp->findnodes($xpath);
#warn "None.\n" unless @nodes;
	return unless @nodes;

	for my $node (@nodes) {
#warn "    Found $spec->{name} xmi.id=".$node->getAttribute("xmi.id")." name=".$node->getAttribute("name")."\n";
		my $thing = {};
        # my $thing = { xpNode => $node };

		# Have we seen this before? If so just use the ref we have.
        if ( my $id = $node->getAttribute("xmi.id") ) {
            if ( my $foo = $me->{model}{things}{$id} ) {
#warn "    Reffing from model **********************\n";
                push @$things, $foo; 
				next;
			}
        }

		# Get the Tag attributes
#warn "    getting attribs: ",join(" ",@{$spec->{attrib_data}}),"\n";
        foreach ( @{$spec->{attrib_data}} ) {
			$thing->{$_} = $node->getAttribute($_);
		}
#warn "    got attribs: ",(map "$_=$thing->{$_}", keys %$thing),"\n";

        # Add the path data
        foreach ( @{$spec->{path_data}} ) {
#warn "    getting path data $_->{name} : $_->{path}\n";
            my @nodes = $node->findnodes($_->{path});
            $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
                : (exists $_->{default} ? $_->{default} : undef);
#warn "    got path data $_->{name}=$thing->{$_->{name}}\n";
        }

        # Run any filters set
        #
        # Should we do this after the kids as we may want to test them?
        # e.g. test for number of attribs
        if ( my $filter = $args{filter} ) {
            local $_ = $thing;
            next unless $filter->($thing);
        }

        # Add anything with an id to the things lookup
        push @$things, $thing;
		if ( exists $thing->{"xmi.id"} and defined $thing->{"xmi.id"}
            and my $id = $thing->{"xmi.id"} 
        ) {
			$me->{model}{things}{$id} = $thing; }

        # Kids
        #
        foreach ( @{$spec->{kids}} ) {
			my $data;
            my $meth = $_->{get_method};
            my $path = $_->{path};

			# Variable subs on the path from thing
			$path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
			$data = $me->$meth( _context => $node, _xpath => $path,
                filter => $args{"filter_$_->{name}"} );
            if ( $_->{multiplicity} eq "1" ) {
                $thing->{$_->{name}} = shift @$data;
            }
            else {
                my $kids = $thing->{$_->{name}} = $data || [];
				if ( my $key = $_->{"map"} ) {
					$thing->{"_map_$_->{name}"} = _mk_map($kids,$key);
				}
            }
        }
	}

	if ( $spec->{isRoot} ) {
		push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things;
	}
	return $things;
} # /closure sub

} # /_mk_get

sub _mk_map {
	my ($kids,$key) = @_;
	my $map = {};
	foreach (@$kids) {
		$map->{$_->{$key}} = $_ if exists $_->{$key};
	}
	return $map;
}

sub get_associations {
	my $assoc = shift->_get_associations(@_);
	foreach (@$assoc) {
		next unless defined $_->{associationEnds}; # Wait until we get all of an association
		my @ends = @{$_->{associationEnds}};
		if (@ends != 2) {
			warn "Sorry can't handle otherEnd associations with more than 2 ends"; 
			return $assoc;
		}
		$ends[0]{otherEnd} = $ends[1];
		$ends[1]{otherEnd} = $ends[0];
	}
	return $assoc;
}

1; #===========================================================================


package XML::XPath::Function;

#
# May need to look at doing deref on all paths just to be on the safe side!
#
# Will also want some caching as these calls are expensive as the whole doc
# is used but the same ref will likley be requested lots of times.
#
sub xmiDeref {
    my $self = shift;
    my ($node, @params) = @_;
    my $nodeset;
    if (@params > 1) {
        die "xmiDeref() function takes one or no parameters\n";
    }
    elsif (@params) {
        $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") || return ($nodeset || $node);
    return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
    # TODO We should use the tag name to search from the source 
}


# compile please
1;

__END__

=head1 SYNOPSIS

 use SQL::Translator::XMI::Parser;
 my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
 my $classes = $xmip->get_classes(); 

=head1 DESCRIPTION

Parses XMI files (XML version of UML diagrams) to perl data structures and 
provides hooks to filter the data down to what you want.

=head2 new

Pass in name/value arg of either C<filename>, C<xml> or C<ioref> for the XMI
data you want to parse.

The version of XMI to use either 1.0 or 1.2 is worked out from the file. You
can also use a C<xmi_version> arg to set it explicitley.

=head2 get_* methods

Doc below is for classes method, all the other calls follow this form.

=head2 get_classes( ARGS )

 ARGS     - Name/Value list of args.

 filter   => A sub to filter the node to see if we want it. Has the nodes data,
             before kids are added, referenced to $_. Should return true if you
             want it, false otherwise.
             
             e.g. To find only classes with a "Foo" stereotype.

              filter => sub { return $_->{stereotype} eq "Foo"; }

 filter_attributes => A filter sub to pass onto get_attributes.

 filter_operations => A filter sub to pass onto get_operations.

Returns a perl data structure including all the kids. e.g. 

 {
   'name' => 'Foo',
   'visibility' => 'public',
   'isActive' => 'false',
   'isAbstract' => 'false',
   'isSpecification' => 'false',
   'stereotype' => 'Table',
   'isRoot' => 'false',
   'isLeaf' => 'false',
   'attributes' => [
       {
         'name' => 'fooid',
         'stereotype' => 'PK',
         'datatype' => 'int'
         'ownerScope' => 'instance',
         'visibility' => 'public',
         'initialValue' => undef,
         'isSpecification' => 'false',
       },
       {
         'name' => 'name',
         'stereotype' => '',
         'datatype' => 'varchar'
         'ownerScope' => 'instance',
         'visibility' => 'public',
         'initialValue' => '',
         'isSpecification' => 'false',
       },
   ]
   'operations' => [
       {
         'name' => 'magic',
         'isQuery' => 'false',
         'ownerScope' => 'instance',
         'visibility' => 'public',
         'isSpecification' => 'false',
         'stereotype' => '',
         'isAbstract' => 'false',
         'isLeaf' => 'false',
         'isRoot' => 'false',
         'concurrency' => 'sequential'
         'parameters' => [
             {
               'kind' => 'inout',
               'isSpecification' => 'false',
               'stereotype' => '',
               'name' => 'arg1',
               'datatype' => undef
             },
             {
               'kind' => 'inout',
               'isSpecification' => 'false',
               'stereotype' => '',
               'name' => 'arg2',
               'datatype' => undef
             },
             {
               'kind' => 'return',
               'isSpecification' => 'false',
               'stereotype' => '',
               'name' => 'return',
               'datatype' => undef
             }
         ],
       }
   ],
 }

=head1 XMI XPath Functions

The Parser adds the following extra XPath functions for use in the Specs.

=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".

=head1 SEE ALSO

perl(1).

=head1 TODO

=head1 BUGS

=head1 VERSION HISTORY

=head1 AUTHOR

grommit <mark.addison@itn.co.uk>

=cut
Commit	Line	Data
f42065cb	1	package SQL::Translator::XMI::Parser;
f42065cb	2
93f4a354	3	# -------------------------------------------------------------------
821a0fde	4	# $Id$
93f4a354	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
f42065cb	23	=pod
	24
	25	=head1 NAME
	26
93f4a354	27	SQL::Translator::XMI::Parser - XMI Parser class for use in SQL Fairy's XMI
93f4a354	28	parser.
f42065cb	29
	30	=cut
	31
	32	use strict;
	33	use 5.006_001;
93f4a354	34	use vars qw/$VERSION/;
821a0fde	35	$VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/;
f42065cb	36
93f4a354	37	use Data::Dumper;
f42065cb	38	use XML::XPath;
	39	use XML::XPath::XMLParser;
	40	use Storable qw/dclone/;
	41
	42	# Spec
93f4a354	43	#------
	44	# See SQL::Translator::XMI::Parser::V12 and SQL::Translator::XMI::Parser:V10
	45	# for examples.
f42065cb	46	#
93f4a354	47	# Hash ref used to describe the 2 xmi formats 1.2 and 1.0. Neither is complete!
f42065cb	48	#
	49	# NB The names of the data keys MUST be the same for both specs so the
	50	# data structures returned are the same.
	51	#
93f4a354	52	# TODO
	53	#
	54	# * There is currently no way to set the data key name for attrib_data, it just
f42065cb	55	# uses the attribute name from the XMI. This isn't a problem at the moment as
	56	# xmi1.0 names all these things with tags so we don't need the attrib data!
	57	# Also use of names seems to be consistant between the versions.
	58	#
f42065cb	59	#
93f4a354	60	# XmiSpec( $spec )
f42065cb	61	#
93f4a354	62	# Call as class method to set up the parser from a spec (see above). This
	63	# generates the get_ methods for the version of XMI the spec is for. Called by
	64	# the sub-classes (e.g. V12 and V10) to create parsers for each version.
f42065cb	65	#
93f4a354	66	sub XmiSpec {
93f4a354	67	my ($me,$spec) = @_;
42b5b9b6	68	_init_specs($spec);
42b5b9b6	69	$me->_mk_gets($spec);
93f4a354	70	}
f42065cb	71
f42065cb	72	# Build lookups etc. Its important that each spec item becomes self contained
b4b9f867	73	# so we can build good closures, therefore we do all the lookups 1st.
42b5b9b6	74	sub _init_specs {
f42065cb	75	my $specs = shift;
	76
	77	foreach my $spec ( values %$specs ) {
b4b9f867	78	# Look up for kids get method
b4b9f867	79	foreach ( @{$spec->{kids}} ) {
f42065cb	80	$_->{get_method} = "get_".$specs->{$_->{class}}{plural};
f42065cb	81	}
0b3f94e0	82
b4b9f867	83	# Add xmi.id ti all specs. Everything we want at the moment (in both
	84	# versions) has an id. The tags that don't seem to be used for
	85	# structure.
	86	my $attrib_data = $spec->{attrib_data} \|\|= [];
	87	push @$attrib_data, "xmi.id";
f42065cb	88	}
	89
	90	}
	91
93f4a354	92	# Create get methods from spec
93f4a354	93	#
42b5b9b6	94	sub _mk_gets {
93f4a354	95	my ($proto,$specs) = @_;
	96	my $class = ref($proto) \|\| $proto;
	97	foreach ( values %$specs ) {
	98	# Clone from specs and sort out the lookups into it so we get a
	99	# self contained spec to use as a proper closure.
	100	my $spec = dclone($_);
	101
	102	# Create _get_* method with get_* as an alias unless the user has
	103	# defined it. Allows for override. Note the alias is in this package
	104	# so we can add overrides to both specs.
	105	no strict "refs";
	106	my $meth = "_get_$spec->{plural}";
42b5b9b6	107	*{$meth} = _mk_get($spec);
93f4a354	108	*{__PACKAGE__."::get_$spec->{plural}"} = sub {shift->$meth(@_);}
93f4a354	109	unless $class->can("get_$spec->{plural}");
f42065cb	110	}
	111	}
	112
93f4a354	113	#
	114	# Sets up the XML::XPath object and then checks the version of the XMI file and
	115	# blesses its self into either the V10 or V12 class.
	116	#
f42065cb	117	sub new {
	118	my $proto = shift;
	119	my $class = ref($proto) \|\| $proto;
	120	my %args = @_;
	121	my $me = {};
93f4a354	122
f42065cb	123	# Create the XML::XPath object
	124	# TODO Docs recommend we only use 1 XPath object per application
	125	my $xp;
	126	foreach (qw/filename xml ioref/) {
	127	if ($args{$_}) {
	128	$xp = XML::XPath->new( $_ => $args{$_});
	129	$xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
	130	last;
	131	}
	132	}
	133	$me = { xml_xpath => $xp };
93f4a354	134
	135	# Work out the version of XMI we have and return as that sub class
	136	my $xmiv = $args{xmi_version}
b4b9f867	137	\|\| "".$xp->findvalue('/XMI/@xmi.version')
b4b9f867	138	\|\| die "Can't find XMI version";
93f4a354	139	$xmiv =~ s/[.]//g;
	140	$class = __PACKAGE__."::V$xmiv";
	141	eval "use $class;";
	142	die "Failed to load version sub class $class : $@" if $@;
f42065cb	143
93f4a354	144	return bless $me, $class;
f42065cb	145	}
f42065cb	146
93f4a354	147	#
42b5b9b6	148	# _mk_get
f42065cb	149	#
93f4a354	150	# Generates and returns a get_ sub for the spec given.
	151	# So, if you want to change how the get methods (e.g. get_classes) work do it
	152	# here!
f42065cb	153	#
	154	# The get methods made have the args described in the docs and 2 private args
	155	# used internally, to call other get methods from paths in the spec.
f42065cb	156	# NB: DO NOT use publicly as you will break the version independance. e.g. When
	157	# using _xpath you need to know which version of XMI to use. This is handled by
	158	# the use of different paths in the specs.
b2a00f50	159	#
f42065cb	160	# _context => The context node to use, if not given starts from root.
b2a00f50	161	#
f42065cb	162	# _xpath => The xpath to use for finding stuff.
b2a00f50	163	#
42b5b9b6	164	sub _mk_get {
f42065cb	165	my $spec = shift;
b2a00f50	166
f42065cb	167	# get_* closure using $spec
	168	return sub {
	169	my ($me, %args) = @_;
	170	my $xp = delete $args{_context} \|\| $me->{xml_xpath};
	171	my $things;
	172
	173	my $xpath = $args{_xpath} \|\|= $spec->{default_path};
	174	#warn "Searching for $spec->{plural} using:$xpath\n";
	175
	176	my @nodes = $xp->findnodes($xpath);
0b3f94e0	177	#warn "None.\n" unless @nodes;
f42065cb	178	return unless @nodes;
	179
	180	for my $node (@nodes) {
0b3f94e0	181	#warn " Found $spec->{name} xmi.id=".$node->getAttribute("xmi.id")." name=".$node->getAttribute("name")."\n";
f42065cb	182	my $thing = {};
f42065cb	183	# my $thing = { xpNode => $node };
b2a00f50	184
0b3f94e0	185	# Have we seen this before? If so just use the ref we have.
	186	if ( my $id = $node->getAttribute("xmi.id") ) {
	187	if ( my $foo = $me->{model}{things}{$id} ) {
	188	#warn " Reffing from model **********************\n";
	189	push @$things, $foo;
	190	next;
	191	}
	192	}
	193
f42065cb	194	# Get the Tag attributes
6e694599	195	#warn " getting attribs: ",join(" ",@{$spec->{attrib_data}}),"\n";
f42065cb	196	foreach ( @{$spec->{attrib_data}} ) {
	197	$thing->{$_} = $node->getAttribute($_);
	198	}
6e694599	199	#warn " got attribs: ",(map "$_=$thing->{$_}", keys %$thing),"\n";
b2a00f50	200
f42065cb	201	# Add the path data
f42065cb	202	foreach ( @{$spec->{path_data}} ) {
6e694599	203	#warn " getting path data $_->{name} : $_->{path}\n";
f42065cb	204	my @nodes = $node->findnodes($_->{path});
	205	$thing->{$_->{name}} = @nodes ? $nodes[0]->getData
	206	: (exists $_->{default} ? $_->{default} : undef);
6e694599	207	#warn " got path data $_->{name}=$thing->{$_->{name}}\n";
f42065cb	208	}
b2a00f50	209
	210	# Run any filters set
	211	#
f42065cb	212	# Should we do this after the kids as we may want to test them?
	213	# e.g. test for number of attribs
	214	if ( my $filter = $args{filter} ) {
	215	local $_ = $thing;
	216	next unless $filter->($thing);
	217	}
b2a00f50	218
0b3f94e0	219	# Add anything with an id to the things lookup
	220	push @$things, $thing;
	221	if ( exists $thing->{"xmi.id"} and defined $thing->{"xmi.id"}
	222	and my $id = $thing->{"xmi.id"}
	223	) {
	224	$me->{model}{things}{$id} = $thing; }
	225
f42065cb	226	# Kids
	227	#
	228	foreach ( @{$spec->{kids}} ) {
b2a00f50	229	my $data;
f42065cb	230	my $meth = $_->{get_method};
b2a00f50	231	my $path = $_->{path};
0b3f94e0	232
	233	# Variable subs on the path from thing
	234	$path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
b2a00f50	235	$data = $me->$meth( _context => $node, _xpath => $path,
f42065cb	236	filter => $args{"filter_$_->{name}"} );
f42065cb	237	if ( $_->{multiplicity} eq "1" ) {
	238	$thing->{$_->{name}} = shift @$data;
	239	}
	240	else {
b2a00f50	241	my $kids = $thing->{$_->{name}} = $data \|\| [];
	242	if ( my $key = $_->{"map"} ) {
	243	$thing->{"_map_$_->{name}"} = _mk_map($kids,$key);
	244	}
f42065cb	245	}
f42065cb	246	}
0b3f94e0	247	}
f42065cb	248
0b3f94e0	249	if ( $spec->{isRoot} ) {
0b3f94e0	250	push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things;
f42065cb	251	}
0b3f94e0	252	return $things;
f42065cb	253	} # /closure sub
f42065cb	254
42b5b9b6	255	} # /_mk_get
f42065cb	256
b2a00f50	257	sub _mk_map {
	258	my ($kids,$key) = @_;
	259	my $map = {};
	260	foreach (@$kids) {
	261	$map->{$_->{$key}} = $_ if exists $_->{$key};
	262	}
	263	return $map;
	264	}
	265
42b5b9b6	266	sub get_associations {
	267	my $assoc = shift->_get_associations(@_);
	268	foreach (@$assoc) {
30744474	269	next unless defined $_->{associationEnds}; # Wait until we get all of an association
30744474	270	my @ends = @{$_->{associationEnds}};
42b5b9b6	271	if (@ends != 2) {
	272	warn "Sorry can't handle otherEnd associations with more than 2 ends";
	273	return $assoc;
	274	}
	275	$ends[0]{otherEnd} = $ends[1];
	276	$ends[1]{otherEnd} = $ends[0];
	277	}
	278	return $assoc;
	279	}
	280
f42065cb	281	1; #===========================================================================
	282
	283
	284	package XML::XPath::Function;
	285
	286	#
	287	# May need to look at doing deref on all paths just to be on the safe side!
	288	#
	289	# Will also want some caching as these calls are expensive as the whole doc
	290	# is used but the same ref will likley be requested lots of times.
	291	#
	292	sub xmiDeref {
	293	my $self = shift;
	294	my ($node, @params) = @_;
6e694599	295	my $nodeset;
f42065cb	296	if (@params > 1) {
	297	die "xmiDeref() function takes one or no parameters\n";
	298	}
	299	elsif (@params) {
6e694599	300	$nodeset = shift(@params);
f42065cb	301	return $nodeset unless $nodeset->size;
	302	$node = $nodeset->get_node(1);
	303	}
	304	die "xmiDeref() needs an Element node."
	305	unless $node->isa("XML::XPath::Node::Element");
	306
6e694599	307	my $id = $node->getAttribute("xmi.idref") \|\| return ($nodeset \|\| $node);
f42065cb	308	return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
6e694599	309	# TODO We should use the tag name to search from the source
f42065cb	310	}
	311
	312
	313	# compile please
	314	1;
	315
	316	__END__
	317
	318	=head1 SYNOPSIS
	319
	320	use SQL::Translator::XMI::Parser;
	321	my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
	322	my $classes = $xmip->get_classes();
	323
	324	=head1 DESCRIPTION
	325
	326	Parses XMI files (XML version of UML diagrams) to perl data structures and
	327	provides hooks to filter the data down to what you want.
	328
	329	=head2 new
	330
b4b9f867	331	Pass in name/value arg of either C<filename>, C<xml> or C<ioref> for the XMI
	332	data you want to parse.
	333
	334	The version of XMI to use either 1.0 or 1.2 is worked out from the file. You
	335	can also use a C<xmi_version> arg to set it explicitley.
f42065cb	336
	337	=head2 get_* methods
	338
	339	Doc below is for classes method, all the other calls follow this form.
	340
	341	=head2 get_classes( ARGS )
	342
	343	ARGS - Name/Value list of args.
	344
	345	filter => A sub to filter the node to see if we want it. Has the nodes data,
	346	before kids are added, referenced to $_. Should return true if you
	347	want it, false otherwise.
	348
	349	e.g. To find only classes with a "Foo" stereotype.
	350
	351	filter => sub { return $_->{stereotype} eq "Foo"; }
	352
	353	filter_attributes => A filter sub to pass onto get_attributes.
	354
	355	filter_operations => A filter sub to pass onto get_operations.
	356
	357	Returns a perl data structure including all the kids. e.g.
	358
	359	{
	360	'name' => 'Foo',
	361	'visibility' => 'public',
	362	'isActive' => 'false',
	363	'isAbstract' => 'false',
	364	'isSpecification' => 'false',
	365	'stereotype' => 'Table',
	366	'isRoot' => 'false',
	367	'isLeaf' => 'false',
	368	'attributes' => [
	369	{
	370	'name' => 'fooid',
	371	'stereotype' => 'PK',
	372	'datatype' => 'int'
	373	'ownerScope' => 'instance',
	374	'visibility' => 'public',
	375	'initialValue' => undef,
	376	'isSpecification' => 'false',
	377	},
	378	{
	379	'name' => 'name',
	380	'stereotype' => '',
	381	'datatype' => 'varchar'
	382	'ownerScope' => 'instance',
	383	'visibility' => 'public',
	384	'initialValue' => '',
	385	'isSpecification' => 'false',
	386	},
	387	]
	388	'operations' => [
	389	{
	390	'name' => 'magic',
	391	'isQuery' => 'false',
	392	'ownerScope' => 'instance',
	393	'visibility' => 'public',
	394	'isSpecification' => 'false',
	395	'stereotype' => '',
	396	'isAbstract' => 'false',
	397	'isLeaf' => 'false',
	398	'isRoot' => 'false',
	399	'concurrency' => 'sequential'
400	'parameters' => [
401	{
402	'kind' => 'inout',
403	'isSpecification' => 'false',
404	'stereotype' => '',
405	'name' => 'arg1',
406	'datatype' => undef
407	},
408	{
409	'kind' => 'inout',
410	'isSpecification' => 'false',
411	'stereotype' => '',
412	'name' => 'arg2',
413	'datatype' => undef
414	},
415	{
416	'kind' => 'return',
417	'isSpecification' => 'false',
418	'stereotype' => '',
419	'name' => 'return',
420	'datatype' => undef
421	}
422	],
423	}
424	],
425	}
426
427	=head1 XMI XPath Functions
428
93f4a354	429	The Parser adds the following extra XPath functions for use in the Specs.
f42065cb	430
	431	=head2 xmiDeref
	432
	433	Deals with xmi.id/xmi.idref pairs of attributes. You give it an
	434	xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
	435	tag it points at has an xmi.idref it looks up the tag with that
	436	xmi.id and returns it.
	437
	438	If it doesn't have an xmi.id, the path is returned as normal.
	439
	440	e.g. given
	441
	442	<UML:ModelElement.stereotype>
	443	<UML:Stereotype xmi.idref = 'stTable'/>
	444	</UML:ModelElement.stereotype>
	445	...
	446	<UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
	447	isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
	448	<UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
	449	</UML:Stereotype>
	450
	451	Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
	452	<UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
	453
	454	Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
	455	"Table".
	456
	457	=head1 SEE ALSO
	458
	459	perl(1).
	460
	461	=head1 TODO
	462
	463	=head1 BUGS
	464
	465	=head1 VERSION HISTORY
	466
	467	=head1 AUTHOR
	468
	469	grommit <mark.addison@itn.co.uk>
	470
f42065cb	471	=cut