X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FXMI%2FParser.pm;h=db3a2226f92fd769fed4409dc25dc1a699fd80c5;hb=b178940934ec79968ed16511ec2644f3736c92f2;hp=e3ccb06bb9ec6d5266d17d5009eb2557a7cddeaf;hpb=b4b9f867d24b50010041eddbec14cb5ec3b58db7;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/XMI/Parser.pm b/lib/SQL/Translator/XMI/Parser.pm index e3ccb06..db3a222 100644 --- a/lib/SQL/Translator/XMI/Parser.pm +++ b/lib/SQL/Translator/XMI/Parser.pm @@ -1,296 +1,77 @@ package SQL::Translator::XMI::Parser; +# ------------------------------------------------------------------- +# $Id: Parser.pm,v 1.8 2003-10-06 15:03:07 grommit Exp $ +# ------------------------------------------------------------------- +# Copyright (C) 2003 Mark Addison , +# +# 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- Perl class for blah blah blah +SQL::Translator::XMI::Parser - XMI Parser class for use in SQL Fairy's XMI +parser. =cut use strict; use 5.006_001; -our $VERSION = "0.01"; +use vars qw/$VERSION/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\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. # -# Describes the 2 xmi formats 1.2 and 1.0. Neither is complete! +# 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. # -# There is currently no way to set the data key name for attrib_data, it just +# 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. # - -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}->(@_); } +# XmiSpec( $spec ) # -# The names for the data keys in the specs must match up so that we get the -# same data structure for each version. +# 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. # - -# Class setup -foreach ( values %$SPECS ) { init_specs($_) }; -mk_get_dispatch(); +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 { +sub _init_specs { my $specs = shift; foreach my $spec ( values %$specs ) { @@ -298,7 +79,7 @@ sub init_specs { 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. @@ -308,27 +89,37 @@ sub init_specs { } -# 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}->(@_); - }; +# 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; @@ -340,57 +131,39 @@ sub new { } } $me = { xml_xpath => $xp }; - - # Work out the version of XMI we have and generate the get subs to parse it - my $xmiv = $args{xmi_version} + + # 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"; - $me->{xmi_get_} = mk_gets($SPECS->{$xmiv}); - - return bless $me, $class; -} + $xmiv =~ s/[.]//g; + $class = __PACKAGE__."::V$xmiv"; + eval "use $class;"; + die "Failed to load version sub class $class : $@" if $@; - -# 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; + return bless $me, $class; } -# -# 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! +# _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. -# -use Data::Dumper; -sub mk_get { +# +sub _mk_get { my $spec = shift; - + # get_* closure using $spec return sub { my ($me, %args) = @_; @@ -401,56 +174,109 @@ sub mk_get { #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 "Searching for $spec->{plural} - $_->{name} using:$_->{path}\n"; +#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 - # + + # 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 $data; my $meth = $_->{get_method}; - $data = $me->$meth( _context => $node, _xpath => $_->{path}, + 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 { - $thing->{$_->{name}} = $data || []; + my $kids = $thing->{$_->{name}} = $data || []; + if ( my $key = $_->{"map"} ) { + $thing->{"_map_$_->{name}"} = _mk_map($kids,$key); + } } } + } - push @$things, $thing; + if ( $spec->{isRoot} ) { + push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things; } - return wantarray ? @$things : $things; + return $things; } # /closure sub -} # /mk_get +} # /_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; #=========================================================================== @@ -466,19 +292,21 @@ package XML::XPath::Function; sub xmiDeref { my $self = shift; my ($node, @params) = @_; + my $nodeset; if (@params > 1) { die "xmiDeref() function takes one or no parameters\n"; } elsif (@params) { - my $nodeset = shift(@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") or return $node; + 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 } @@ -598,7 +426,7 @@ Returns a perl data structure including all the kids. e.g. =head1 XMI XPath Functions -The Parser adds the following extra XPath functions for use in the SPECS. +The Parser adds the following extra XPath functions for use in the Specs. =head2 xmiDeref @@ -640,17 +468,4 @@ perl(1). 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