From: Mark Addison Date: Tue, 16 Sep 2003 16:29:50 +0000 (+0000) Subject: Split out XMI parsing to SQL::Translator::XMI::Parser. All the XPath is X-Git-Tag: v0.04~180 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f42065cb56fea229cd51539e2cf96f632e5f7307;p=dbsrgits%2FSQL-Translator.git Split out XMI parsing to SQL::Translator::XMI::Parser. All the XPath is hidden in this mod so we can transparently handle XMI1.0 and XMI1.2. Schema gen is now based on the perl data structure returned from SQL::Translator::XMI::Parser::get_classes(). Basic XMI1.0 support. Removed <> stereotype checks on Classes as this will be profile specific. --- diff --git a/lib/SQL/Translator/Parser/XML/XMI.pm b/lib/SQL/Translator/Parser/XML/XMI.pm index 68932de..f62a911 100644 --- a/lib/SQL/Translator/Parser/XML/XMI.pm +++ b/lib/SQL/Translator/Parser/XML/XMI.pm @@ -1,7 +1,7 @@ package SQL::Translator::Parser::XML::XMI; # ------------------------------------------------------------------- -# $Id: XMI.pm,v 1.5 2003-09-09 01:37:25 grommit Exp $ +# $Id: XMI.pm,v 1.6 2003-09-16 16:29:49 grommit Exp $ # ------------------------------------------------------------------- # Copyright (C) 2003 Mark Addison , # @@ -42,22 +42,21 @@ Class diagrams stored in XMI format. =head1 DESCRIPTION -=head2 UML Data Modeling - -To tell the parser which Classes are tables give them a <
> stereotype. +Currently pulls out all the Classes as tables. 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 <> stereotype. - =head2 XMI Format -The parser has been built using XMI generated by PoseidonUML 2beta, which +The parser has been built using XMI 1.2 generated by PoseidonUML 2beta, which says it uses UML 2. So the current conformance is down to Poseidon's idea of XMI! +It should also parse XMI 1.0, such as you get from Rose, but this has had +little testing! + =head1 ARGS =over 4 @@ -82,7 +81,7 @@ translated. use strict; use vars qw[ $DEBUG $VERSION @EXPORT_OK ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/; $DEBUG = 0 unless defined $DEBUG; use Data::Dumper; @@ -92,213 +91,70 @@ use base qw(Exporter); 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. -# +use SQL::Translator::XMI::Parser; -# _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) = @_; +# SQLFairy Parser +#----------------------------------------------------------------------------- - 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); +# is_visible - Used to check visibility in filter subs +{ + my %vislevel = ( + public => 1, + protected => 2, + private => 3, + ); - $parameter->{datatype} = "".$node->find( - 'xmiDeref(UML:Parameter.type/UML:DataType)/@name'); - - push @$parameters, $parameter; + sub is_visible { + my ($nodevis, $vis) = @_; + $nodevis = ref $_[0] ? $_[0]->{visibility} : $_[0]; + return 1 unless $vis; + return 1 if $vislevel{$vis} >= $vislevel{$nodevis}; + return 0; } - 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; - + local $DEBUG = $translator->debug; + my $schema = $translator->schema; + my $pargs = $translator->parser_args; + + eval { + debug "Visibility Level:$pargs->{visibility}" if $DEBUG; - my $xp = XML::XPath->new(xml => $data); - $xp->set_namespace("UML", "org.omg.xmi.namespace.UML"); - # + my $xmip = SQL::Translator::XMI::Parser->new(xml => $data); + # 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); - + + my $classes = $xmip->get_classes( + filter => sub { + return unless $_->{name}; + return unless is_visible($_, $pargs->{visibility}); + return 1; + }, + filter_attributes => sub { + return unless $_->{name}; + return unless is_visible($_, $pargs->{visibility}); + return 1; + }, + ); + debug "Found ".scalar(@$classes)." Classes: ".join(", ", map {$_->{"name"}} @$classes) if $DEBUG; - debug "Classes:",Dumper($classes); + debug "Classes:",Dumper($classes); + #print "Classes:",Dumper($classes),"\n"; # # Turn the data from get_classes into a Schema # + # TODO This is where we will applie different strategies for different UML + # data modeling profiles. + # 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} ) @@ -307,9 +163,6 @@ sub parse { # # 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}, @@ -332,145 +185,29 @@ sub parse { } } # Classes loop + + }; + print "ERROR:$@" if $@; 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 - - - - - ... - - Class - - -Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the - 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. +big and complex, especially all the diagram info, and XPath needs to load the +whole tree. =head1 TODO B Don't think UML does this directly so may need to include it in the datatype names. -B I have taken them from looking -at Poseidon so need to check against XMI spec. - B Seperate control over what is parsed, setting visibility arg will set both. diff --git a/lib/SQL/Translator/XMI/Parser.pm b/lib/SQL/Translator/XMI/Parser.pm new file mode 100644 index 0000000..8e1b6da --- /dev/null +++ b/lib/SQL/Translator/XMI/Parser.pm @@ -0,0 +1,645 @@ +package SQL::Translator::XMI::Parser; + +=pod + +=head1 NAME + +SQL::Translator::XMI::Parser- Perl class for blah blah blah + +=cut + +use strict; +use 5.006_001; +our $VERSION = "0.01"; + +use XML::XPath; +use XML::XPath::XMLParser; +use Storable qw/dclone/; + +# Spec +#============================================================================= +# +# Describes 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. +# +# 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. +# + +my $SPECS = {}; + +my $spec12 = $SPECS->{"1.2"} = {}; + +$spec12->{class} = { + name => "class", + plural => "classes", + default_path => '//UML:Class[@xmi.id]', + attrib_data => + [qw/name visibility isSpecification isRoot isLeaf isAbstract isActive/], + path_data => [ + { + name => "stereotype", + path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name', + default => "", + }, + ], + kids => [ + { + name => "attributes", + # name in data returned + path => "UML:Classifier.feature/UML:Attribute", + class => "attribute", + # Points to class in spec. get_attributes() called to parse it and + # adds filter_attributes to the args for get_classes(). + multiplicity => "*", + # How many we get back. Use '1' for 1 and '*' for lots. + # TODO If not set then decide depening on the return? + }, + { + name => "operations", + path => "UML:Classifier.feature/UML:Operation", + class => "operation", + multiplicity => "*", + }, + { + name => "taggedValues", + path => 'UML:ModelElement.taggedValue/UML:TaggedValue', + class => "taggedValue", + multiplicity => "*", + # Nice if we could say that the list should me folded into a hash + # on the name key. type=>"hash", hash_key=>"name" or something! + }, + ], +}; + +$spec12->{taggedValue} = { + name => "taggedValue", + plural => "taggedValues", + default_path => '//UML:TaggedValue[@xmi.id]', + attrib_data => [qw/isSpecification/], + path_data => [ + { + name => "dataValue", + path => 'UML:TaggedValue.dataValue/text()', + }, + { + name => "name", + path => 'xmiDeref(UML:TaggedValue.type/UML:TagDefinition)/@name', + }, + ], +}; + +$spec12->{attribute} = { + name => "attribute", + plural => "attributes", + default_path => '//UML:Classifier.feature/UML:Attribute[@xmi.id]', + attrib_data => + [qw/name visibility isSpecification ownerScope/], + path_data => [ + { + name => "stereotype", + path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name', + default => "", + }, + { + name => "datatype", + path => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name', + }, + { + name => "initialValue", + path => 'UML:Attribute.initialValue/UML:Expression/@body', + }, + ], + kids => [ + { + name => "taggedValues", + path => 'UML:ModelElement.taggedValue/UML:TaggedValue', + class => "taggedValue", + multiplicity => "*", + }, + ], +}; + +$spec12->{operation} = { + name => "operation", + plural => "operations", + default_path => '//UML:Classifier.feature/UML:Operation[@xmi.id]', + attrib_data => + [qw/name visibility isSpecification ownerScope isQuery + concurrency isRoot isLeaf isAbstract/], + path_data => [ + { + name => "stereotype", + path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name', + default => "", + }, + ], + kids => [ + { + name => "parameters", + path => "UML:BehavioralFeature.parameter/UML:Parameter", + class => "parameter", + multiplicity => "*", + }, + { + name => "taggedValues", + path => 'UML:ModelElement.taggedValue/UML:TaggedValue', + class => "taggedValue", + multiplicity => "*", + }, + ], +}; + +$spec12->{parameter} = { + name => "parameter", + plural => "parameters", + default_path => '//UML:BehavioralFeature.parameter/UML:Parameter[@xmi.id]', + attrib_data => [qw/name isSpecification kind/], + path_data => [ + { + name => "stereotype", + path => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name', + default => "", + }, + { + name => "datatype", + path => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name', + }, + ], +}; + +#----------------------------------------------------------------------------- + +my $spec10 = $SPECS->{"1.0"} = {}; + +$spec10->{class} = { + name => "class", + plural => "classes", + default_path => '//Foundation.Core.Class[@xmi.id]', + attrib_data => [], + path_data => [ + { + name => "name", + path => 'Foundation.Core.ModelElement.name/text()', + }, + { + name => "visibility", + path => 'Foundation.Core.ModelElement.visibility/@xmi.value', + }, + { + name => "isSpecification", + path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value', + }, + { + name => "isRoot", + path => 'Foundation.Core.GeneralizableElement.isRoot/@xmi.value', + }, + { + name => "isLeaf", + path => 'Foundation.Core.GeneralizableElement.isLeaf/@xmi.value', + }, + { + name => "isAbstract", + path => 'Foundation.Core.GeneralizableElement.isAbstract/@xmi.value', + }, + { + name => "isActive", + path => 'Foundation.Core.Class.isActive/@xmi.value', + }, + ], + kids => [ + { + name => "attributes", + path => + 'Foundation.Core.Classifier.feature/Foundation.Core.Attribute', + class => "attribute", + multiplicity => "*", + }, + # { + # name => "operations", + # path => "UML:Classifier.feature/UML:Operation", + # class => "operation", + # multiplicity => "*", + # }, + ], +}; + +$spec10->{attribute} = { + name => "attribute", + plural => "attributes", + default_path => '//Foundation.Core.Attribute[@xmi.id]', + path_data => [ + { + name => "name", + path => 'Foundation.Core.ModelElement.name/text()', + }, + { + name => "visibility", + path => 'Foundation.Core.ModelElement.visibility/@xmi.value', + }, + { + name => "isSpecification", + path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value', + }, + { + name => "ownerScope", + path => 'Foundation.Core.Feature.ownerScope/@xmi.value', + }, + { + name => "initialValue", + path => 'Foundation.Core.Attribute.initialValue/Foundation.Data_Types.Expression/Foundation.Data_Types.Expression.body/text()', + }, + #{ + # name => "datatype", + # path => 'xmiDeref(Foundation.Core.StructuralFeature.type/Foundation.Core.Classifier)/Foundation.Core.DataType/Foundation.Core.ModelElement.name/text()', + #}, + ], +}; + +#============================================================================= + +# +# How this works! +#================= +# +# The parser supports xmi1.0 and xmi1.2 based on the specs above. At new() time +# the version is read from the XMI tag and picks out a spec e.g. +# $SPECS->{"1.2"} and feeds it to mk_gets() which returns a hash ref of subs +# (think strategy pattern), one for each entry in the specs hash. This is held +# in $self->{xmi_get_}. +# +# When the class is use'd it sets dispatch methods with +# mk_get_dispatch() that return the call using the corresponding sub in +# $self->{xmi_get_}. e.g. +# +# sub get_classes { $_[0]->{xmi_get_}{classes}->(@_); } +# sub get_attributes { $_[0]->{xmi_get_}{attributes}->(@_); } +# sub get_classes { $_[0]->{xmi_get_}{classes}->(@_); } +# +# The names for the data keys in the specs must match up so that we get the +# same data structure for each version. +# + +# Class setup +foreach ( values %$SPECS ) { init_specs($_) }; +mk_get_dispatch(); + +# Build lookups etc. Its important that each spec item becomes self contained +# so we can build good closures, therefor we do all the lookups 1st. +sub init_specs { + my $specs = shift; + + foreach my $spec ( values %$specs ) { + foreach ( @{$spec->{kids}} ) { + $_->{get_method} = "get_".$specs->{$_->{class}}{plural}; + } + } + +} + +# Generate get_* subs to dispach the calls to the subs held in $me->{xmi_get_} +sub mk_get_dispatch { + foreach ( values %{$SPECS->{"1.2"}} ) { + my $name = $_->{plural}; + no strict "refs"; + + # get_ on parser + *{"get_$name"} = sub { + #my $me = shift; + #$me->{xmi_get_}{$name}->($me,@_); + $_[0]->{xmi_get_}{$name}->(@_); + }; + } +} + +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 generate the get subs to parse it + my $xmiv = "".$xp->findvalue('/XMI/@xmi.version') + or die "Can't find XMI version"; + $me->{xmi_get_} = mk_gets($SPECS->{$xmiv}); + + return bless $me, $class; +} + + +# Returns hashref of get subs from set of specs e.g. $SPECS->{"1.2"} +# +# TODO +# * Add a memoize so we don't keep regenerating the subs for every use. +sub mk_gets { + my $specs = shift; + my $gets; + 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($_); + + # Add the sub + $gets->{$spec->{plural}} = mk_get($spec); + } + return $gets; +} + +# +# mk_get +# +# Generates and returns a get_ sub for the spec given. e.g. give it +# $SPECS->{"1.2"}->{classes} to get the code for xmi 1.2 get_classes. So, if +# you want to change how the get methods 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. +# +use Data::Dumper; +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); + return unless @nodes; + + for my $node (@nodes) { + my $thing = {}; + # my $thing = { xpNode => $node }; + + # Get the Tag attributes + foreach ( @{$spec->{attrib_data}} ) { + $thing->{$_} = $node->getAttribute($_); + } + + # Add the path data + foreach ( @{$spec->{path_data}} ) { +#warn "Searching for $spec->{plural} - $_->{name} using:$_->{path}\n"; + my @nodes = $node->findnodes($_->{path}); + $thing->{$_->{name}} = @nodes ? $nodes[0]->getData + : (exists $_->{default} ? $_->{default} : undef); + } + + # 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); + } + + # Kids + # + foreach ( @{$spec->{kids}} ) { + my $data; + my $meth = $_->{get_method}; + $data = $me->$meth( _context => $node, _xpath => $_->{path}, + filter => $args{"filter_$_->{name}"} ); + + if ( $_->{multiplicity} eq "1" ) { + $thing->{$_->{name}} = shift @$data; + } + else { + $thing->{$_->{name}} = $data || []; + } + } + + push @$things, $thing; + } + return wantarray ? @$things : $things; +} # /closure sub + +} # /mk_get + +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) = @_; + 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.'"]'); +} + + +# 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 filename, xml or ioref for the XMI data you +want to parse. + +=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 + + + + + ... + + Class + + +Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the + 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 + +=head1 LICENSE + +This package is free software and is provided "as is" without express or +implied warranty. It may be used, redistributed and/or modified under the +terms of either; + +a) the Perl Artistic License. + +See F + +b) the terms of the GNU General Public License as published by the Free Software +Foundation; either version 1, or (at your option) any later version. + +=cut diff --git a/t/21xml-xmi-parser.t b/t/21xml-xmi-parser.t index 9e9491a..d5f6429 100644 --- a/t/21xml-xmi-parser.t +++ b/t/21xml-xmi-parser.t @@ -119,7 +119,7 @@ print $sql if DEBUG; # my $scma = $obj->schema; my @tblnames = map {$_->name} $scma->get_tables; -is_deeply( \@tblnames, [qw/Foo PrivateFoo Recording Track ProtectedFoo/] +is_deeply( \@tblnames, [qw/Foo PrivateFoo Recording CD Track ProtectedFoo/] ,"tables"); # @@ -230,13 +230,13 @@ test_table( $scma->get_table("Track"), # Classes my @testd = ( - "" => [qw/Foo PrivateFoo Recording Track ProtectedFoo/], + "" => [qw/Foo PrivateFoo Recording CD Track ProtectedFoo/], [qw/fooid name protectedname privatename/], - "public" => [qw/Foo Recording Track/], + "public" => [qw/Foo Recording CD Track/], [qw/fooid name /], - "protected" => [qw/Foo Recording Track ProtectedFoo/], + "protected" => [qw/Foo Recording CD Track ProtectedFoo/], [qw/fooid name protectedname/], - "private" => [qw/Foo PrivateFoo Recording Track ProtectedFoo/], + "private" => [qw/Foo PrivateFoo Recording CD Track ProtectedFoo/], [qw/fooid name protectedname privatename/], ); while ( my ($vis,$tables,$foofields) = splice @testd,0,3 ) { diff --git a/t/data/xmi/Foo.poseidon2.xmi b/t/data/xmi/Foo.poseidon2.xmi index d2b6975..e6f218e 100644 --- a/t/data/xmi/Foo.poseidon2.xmi +++ b/t/data/xmi/Foo.poseidon2.xmi @@ -1,5 +1,5 @@ - + Netbeans XMI Writer @@ -12,7 +12,7 @@ - Class - - - - <p> -No &lt;&lt;Table&gt;&gt; so the parser should ignore it. -</p> - - - - - - - @@ -274,12 +259,6 @@ No &lt;&lt;Table&gt;&gt; so the parser should ignore it. - -