1 package SQL::Translator::XMI::Parser;
7 SQL::Translator::XMI::Parser
13 our $VERSION = "0.01";
16 use XML::XPath::XMLParser;
17 use Storable qw/dclone/;
20 #=============================================================================
22 # Describes the 2 xmi formats 1.2 and 1.0. Neither is complete!
24 # NB The names of the data keys MUST be the same for both specs so the
25 # data structures returned are the same.
27 # There is currently no way to set the data key name for attrib_data, it just
28 # uses the attribute name from the XMI. This isn't a problem at the moment as
29 # xmi1.0 names all these things with tags so we don't need the attrib data!
30 # Also use of names seems to be consistant between the versions.
35 my $spec12 = $SPECS->{"1.2"} = {};
41 default_path => '//UML:Class[@xmi.id]',
43 [qw/name visibility isSpecification isRoot isLeaf isAbstract isActive/],
47 path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
54 # name in data returned
55 path => "UML:Classifier.feature/UML:Attribute",
57 # Points to class in spec. get_attributes() called to parse it and
58 # adds filter_attributes to the args for get_classes().
60 # How many we get back. Use '1' for 1 and '*' for lots.
61 # TODO If not set then decide depening on the return?
65 path => "UML:Classifier.feature/UML:Operation",
70 name => "taggedValues",
71 path => 'UML:ModelElement.taggedValue/UML:TaggedValue',
72 class => "taggedValue",
75 # Add a _map_taggedValues to the data. Its a hash of the name data
76 # which refs the normal list of kids
81 $spec12->{taggedValue} = {
82 name => "taggedValue",
83 plural => "taggedValues",
84 default_path => '//UML:TaggedValue[@xmi.id]',
85 attrib_data => [qw/isSpecification/],
89 path => 'UML:TaggedValue.dataValue/text()',
93 path => 'xmiDeref(UML:TaggedValue.type/UML:TagDefinition)/@name',
98 $spec12->{attribute} = {
100 plural => "attributes",
101 default_path => '//UML:Classifier.feature/UML:Attribute[@xmi.id]',
103 [qw/name visibility isSpecification ownerScope/],
106 name => "stereotype",
107 path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
112 path => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name',
115 name => "initialValue",
116 path => 'UML:Attribute.initialValue/UML:Expression/@body',
121 name => "taggedValues",
122 path => 'UML:ModelElement.taggedValue/UML:TaggedValue',
123 class => "taggedValue",
130 $spec12->{operation} = {
132 plural => "operations",
133 default_path => '//UML:Classifier.feature/UML:Operation[@xmi.id]',
135 [qw/name visibility isSpecification ownerScope isQuery
136 concurrency isRoot isLeaf isAbstract/],
139 name => "stereotype",
140 path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
146 name => "parameters",
147 path => "UML:BehavioralFeature.parameter/UML:Parameter",
148 class => "parameter",
152 name => "taggedValues",
153 path => 'UML:ModelElement.taggedValue/UML:TaggedValue',
154 class => "taggedValue",
161 $spec12->{parameter} = {
163 plural => "parameters",
164 default_path => '//UML:Parameter[@xmi.id]',
165 attrib_data => [qw/name isSpecification kind/],
168 name => "stereotype",
169 path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
174 path => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name',
179 #-----------------------------------------------------------------------------
181 my $spec10 = $SPECS->{"1.0"} = {};
186 default_path => '//Foundation.Core.Class[@xmi.id]',
191 path => 'Foundation.Core.ModelElement.name/text()',
194 name => "visibility",
195 path => 'Foundation.Core.ModelElement.visibility/@xmi.value',
198 name => "isSpecification",
199 path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value',
203 path => 'Foundation.Core.GeneralizableElement.isRoot/@xmi.value',
207 path => 'Foundation.Core.GeneralizableElement.isLeaf/@xmi.value',
210 name => "isAbstract",
211 path => 'Foundation.Core.GeneralizableElement.isAbstract/@xmi.value',
215 path => 'Foundation.Core.Class.isActive/@xmi.value',
220 name => "attributes",
222 'Foundation.Core.Classifier.feature/Foundation.Core.Attribute',
223 class => "attribute",
227 # name => "operations",
228 # path => "UML:Classifier.feature/UML:Operation",
229 # class => "operation",
230 # multiplicity => "*",
235 $spec10->{attribute} = {
237 plural => "attributes",
238 default_path => '//Foundation.Core.Attribute[@xmi.id]',
242 path => 'Foundation.Core.ModelElement.name/text()',
245 name => "visibility",
246 path => 'Foundation.Core.ModelElement.visibility/@xmi.value',
249 name => "isSpecification",
250 path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value',
253 name => "ownerScope",
254 path => 'Foundation.Core.Feature.ownerScope/@xmi.value',
257 name => "initialValue",
258 path => 'Foundation.Core.Attribute.initialValue/Foundation.Data_Types.Expression/Foundation.Data_Types.Expression.body/text()',
261 # name => "datatype",
262 # path => 'xmiDeref(Foundation.Core.StructuralFeature.type/Foundation.Core.Classifier)/Foundation.Core.DataType/Foundation.Core.ModelElement.name/text()',
267 #=============================================================================
273 # The parser supports xmi1.0 and xmi1.2 based on the specs above. At new() time
274 # the version is read from the XMI tag and picks out a spec e.g.
275 # $SPECS->{"1.2"} and feeds it to mk_gets() which returns a hash ref of subs
276 # (think strategy pattern), one for each entry in the specs hash. This is held
277 # in $self->{xmi_get_}.
279 # When the class is use'd it sets dispatch methods with
280 # mk_get_dispatch() that return the call using the corresponding sub in
281 # $self->{xmi_get_}. e.g.
283 # sub get_classes { $_[0]->{xmi_get_}{classes}->(@_); }
284 # sub get_attributes { $_[0]->{xmi_get_}{attributes}->(@_); }
285 # sub get_classes { $_[0]->{xmi_get_}{classes}->(@_); }
287 # The names for the data keys in the specs must match up so that we get the
288 # same data structure for each version.
292 foreach ( values %$SPECS ) { init_specs($_) };
295 # Build lookups etc. Its important that each spec item becomes self contained
296 # so we can build good closures, therefore we do all the lookups 1st.
300 foreach my $spec ( values %$specs ) {
301 # Look up for kids get method
302 foreach ( @{$spec->{kids}} ) {
303 $_->{get_method} = "get_".$specs->{$_->{class}}{plural};
306 # Add xmi.id ti all specs. Everything we want at the moment (in both
307 # versions) has an id. The tags that don't seem to be used for
309 my $attrib_data = $spec->{attrib_data} ||= [];
310 push @$attrib_data, "xmi.id";
315 # Generate get_* subs to dispach the calls to the subs held in $me->{xmi_get_}
316 sub mk_get_dispatch {
317 foreach ( values %{$SPECS->{"1.2"}} ) {
318 my $name = $_->{plural};
323 $_[0]->{xmi_get_}{$name}->(@_);
325 *{"get_$name"} = $code;
331 my $class = ref($proto) || $proto;
335 # Create the XML::XPath object
336 # TODO Docs recommend we only use 1 XPath object per application
338 foreach (qw/filename xml ioref/) {
340 $xp = XML::XPath->new( $_ => $args{$_});
341 $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
345 $me = { xml_xpath => $xp };
347 # Work out the version of XMI we have and generate the get subs to parse it
348 my $xmiv = $args{xmi_version}
349 || "".$xp->findvalue('/XMI/@xmi.version')
350 || die "Can't find XMI version";
351 $me->{xmi_get_} = mk_gets($SPECS->{$xmiv});
353 return bless $me, $class;
357 # Returns hashref of get subs from set of specs e.g. $SPECS->{"1.2"}
360 # * Add a memoize so we don't keep regenerating the subs for every use.
364 foreach ( values %$specs ) {
365 # Clone from specs so we get a proper closure.
366 my $spec = dclone($_);
369 $gets->{$spec->{plural}} = mk_get($spec);
377 # Generates and returns a get_ sub for the spec given. e.g. give it
378 # $SPECS->{"1.2"}->{classes} to get the code for xmi 1.2 get_classes. So, if
379 # you want to change how the get methods work do it here!
381 # The get methods made have the args described in the docs and 2 private args
382 # used internally, to call other get methods from paths in the spec.
384 # NB: DO NOT use publicly as you will break the version independance. e.g. When
385 # using _xpath you need to know which version of XMI to use. This is handled by
386 # the use of different paths in the specs.
388 # _context => The context node to use, if not given starts from root.
390 # _xpath => The xpath to use for finding stuff.
396 # get_* closure using $spec
398 my ($me, %args) = @_;
399 my $xp = delete $args{_context} || $me->{xml_xpath};
402 my $xpath = $args{_xpath} ||= $spec->{default_path};
403 #warn "Searching for $spec->{plural} using:$xpath\n";
405 my @nodes = $xp->findnodes($xpath);
406 #warn "None.\n" unless @nodes;
407 return unless @nodes;
409 for my $node (@nodes) {
410 #warn " Found $spec->{name} xmi.id=".$node->getAttribute("xmi.id")." name=".$node->getAttribute("name")."\n";
412 # my $thing = { xpNode => $node };
414 # Have we seen this before? If so just use the ref we have.
415 if ( my $id = $node->getAttribute("xmi.id") ) {
416 if ( my $foo = $me->{model}{things}{$id} ) {
417 #warn " Reffing from model **********************\n";
423 # Get the Tag attributes
424 foreach ( @{$spec->{attrib_data}} ) {
425 $thing->{$_} = $node->getAttribute($_);
429 foreach ( @{$spec->{path_data}} ) {
430 #warn " $spec->{name} - $_->{name} using:$_->{path}\n";
431 my @nodes = $node->findnodes($_->{path});
432 $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
433 : (exists $_->{default} ? $_->{default} : undef);
436 # Run any filters set
438 # Should we do this after the kids as we may want to test them?
439 # e.g. test for number of attribs
440 if ( my $filter = $args{filter} ) {
442 next unless $filter->($thing);
445 # Add anything with an id to the things lookup
446 push @$things, $thing;
447 if ( exists $thing->{"xmi.id"} and defined $thing->{"xmi.id"}
448 and my $id = $thing->{"xmi.id"}
450 $me->{model}{things}{$id} = $thing; }
454 foreach ( @{$spec->{kids}} ) {
456 my $meth = $_->{get_method};
457 my $path = $_->{path};
459 # Variable subs on the path from thing
460 $path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
461 $data = $me->$meth( _context => $node, _xpath => $path,
462 filter => $args{"filter_$_->{name}"} );
464 if ( $_->{multiplicity} eq "1" ) {
465 $thing->{$_->{name}} = shift @$data;
468 my $kids = $thing->{$_->{name}} = $data || [];
469 if ( my $key = $_->{"map"} ) {
470 $thing->{"_map_$_->{name}"} = _mk_map($kids,$key);
476 if ( $spec->{isRoot} ) {
477 push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things;
485 my ($kids,$key) = @_;
488 $map->{$_->{$key}} = $_ if exists $_->{$key};
493 1; #===========================================================================
496 package XML::XPath::Function;
499 # May need to look at doing deref on all paths just to be on the safe side!
501 # Will also want some caching as these calls are expensive as the whole doc
502 # is used but the same ref will likley be requested lots of times.
506 my ($node, @params) = @_;
508 die "xmiDeref() function takes one or no parameters\n";
511 my $nodeset = shift(@params);
512 return $nodeset unless $nodeset->size;
513 $node = $nodeset->get_node(1);
515 die "xmiDeref() needs an Element node."
516 unless $node->isa("XML::XPath::Node::Element");
518 my $id = $node->getAttribute("xmi.idref") or return $node;
519 return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
530 use SQL::Translator::XMI::Parser;
531 my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
532 my $classes = $xmip->get_classes();
536 Parses XMI files (XML version of UML diagrams) to perl data structures and
537 provides hooks to filter the data down to what you want.
541 Pass in name/value arg of either C<filename>, C<xml> or C<ioref> for the XMI
542 data you want to parse.
544 The version of XMI to use either 1.0 or 1.2 is worked out from the file. You
545 can also use a C<xmi_version> arg to set it explicitley.
549 Doc below is for classes method, all the other calls follow this form.
551 =head2 get_classes( ARGS )
553 ARGS - Name/Value list of args.
555 filter => A sub to filter the node to see if we want it. Has the nodes data,
556 before kids are added, referenced to $_. Should return true if you
557 want it, false otherwise.
559 e.g. To find only classes with a "Foo" stereotype.
561 filter => sub { return $_->{stereotype} eq "Foo"; }
563 filter_attributes => A filter sub to pass onto get_attributes.
565 filter_operations => A filter sub to pass onto get_operations.
567 Returns a perl data structure including all the kids. e.g.
571 'visibility' => 'public',
572 'isActive' => 'false',
573 'isAbstract' => 'false',
574 'isSpecification' => 'false',
575 'stereotype' => 'Table',
581 'stereotype' => 'PK',
583 'ownerScope' => 'instance',
584 'visibility' => 'public',
585 'initialValue' => undef,
586 'isSpecification' => 'false',
591 'datatype' => 'varchar'
592 'ownerScope' => 'instance',
593 'visibility' => 'public',
594 'initialValue' => '',
595 'isSpecification' => 'false',
601 'isQuery' => 'false',
602 'ownerScope' => 'instance',
603 'visibility' => 'public',
604 'isSpecification' => 'false',
606 'isAbstract' => 'false',
609 'concurrency' => 'sequential'
613 'isSpecification' => 'false',
620 'isSpecification' => 'false',
627 'isSpecification' => 'false',
637 =head1 XMI XPath Functions
639 The Parser adds the following extra XPath functions for use in the SPECS.
643 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
644 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
645 tag it points at has an xmi.idref it looks up the tag with that
646 xmi.id and returns it.
648 If it doesn't have an xmi.id, the path is returned as normal.
652 <UML:ModelElement.stereotype>
653 <UML:Stereotype xmi.idref = 'stTable'/>
654 </UML:ModelElement.stereotype>
656 <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
657 isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
658 <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
661 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
662 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
664 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
675 =head1 VERSION HISTORY
679 grommit <mark.addison@itn.co.uk>
683 This package is free software and is provided "as is" without express or
684 implied warranty. It may be used, redistributed and/or modified under the
687 a) the Perl Artistic License.
689 See F<http://www.perl.com/perl/misc/Artistic.html>
691 b) the terms of the GNU General Public License as published by the Free Software
692 Foundation; either version 1, or (at your option) any later version.