lib/SQL/Translator/XMI/Parser.pm

   1 package SQL::Translator::XMI::Parser;
   2
   3 # -------------------------------------------------------------------
   4 # $Id$
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 SQL::Translator::XMI::Parser - XMI Parser class for use in SQL Fairy's XMI
  28 parser.
  29
  30 =cut
  31
  32 use strict;
  33 use 5.006_001;
  34 use vars qw/$VERSION/;
  35 $VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/;
  36
  37 use Data::Dumper;
  38 use XML::XPath;
  39 use XML::XPath::XMLParser;
  40 use Storable qw/dclone/;
  41
  42 # Spec
  43 #------
  44 # See SQL::Translator::XMI::Parser::V12 and SQL::Translator::XMI::Parser:V10
  45 # for examples.
  46 #
  47 # Hash ref used to describe the 2 xmi formats 1.2 and 1.0. Neither is complete!
  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 #
  52 # TODO
  53 #
  54 # * There is currently no way to set the data key name for attrib_data, it just
  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 #
  59 #
  60 # XmiSpec( $spec )
  61 #
  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.
  65 #
  66 sub XmiSpec {
  67         my ($me,$spec) = @_;
  68         _init_specs($spec);
  69         $me->_mk_gets($spec);
  70 }
  71
  72 # Build lookups etc. Its important that each spec item becomes self contained
  73 # so we can build good closures, therefore we do all the lookups 1st.
  74 sub _init_specs {
  75         my $specs = shift;
  76
  77         foreach my $spec ( values %$specs ) {
  78                 # Look up for kids get method
  79                 foreach ( @{$spec->{kids}} ) {
  80             $_->{get_method} = "get_".$specs->{$_->{class}}{plural};
  81         }
  82
  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";
  88         }
  89
  90 }
  91
  92 # Create get methods from spec
  93 #
  94 sub _mk_gets {
  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}";
 107                 *{$meth} = _mk_get($spec);
 108                 *{__PACKAGE__."::get_$spec->{plural}"} = sub {shift->$meth(@_);}
 109                         unless $class->can("get_$spec->{plural}");
 110     }
 111 }
 112
 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 #
 117 sub new {
 118     my $proto = shift;
 119     my $class = ref($proto) || $proto;
 120     my %args = @_;
 121     my $me = {};
 122
 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 };
 134
 135     # Work out the version of XMI we have and return as that sub class
 136         my $xmiv = $args{xmi_version}
 137             || "".$xp->findvalue('/XMI/@xmi.version')
 138         || die "Can't find XMI version";
 139         $xmiv =~ s/[.]//g;
 140         $class = __PACKAGE__."::V$xmiv";
 141         eval "use $class;";
 142         die "Failed to load version sub class $class : $@" if $@;
 143
 144         return bless $me, $class;
 145 }
 146
 147 #
 148 # _mk_get
 149 #
 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!
 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.
 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.
 159 #
 160 #  _context => The context node to use, if not given starts from root.
 161 #
 162 #  _xpath   => The xpath to use for finding stuff.
 163 #
 164 sub _mk_get {
 165     my $spec = shift;
 166
 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);
 177 #warn "None.\n" unless @nodes;
 178         return unless @nodes;
 179
 180         for my $node (@nodes) {
 181 #warn "    Found $spec->{name} xmi.id=".$node->getAttribute("xmi.id")." name=".$node->getAttribute("name")."\n";
 182                 my $thing = {};
 183         # my $thing = { xpNode => $node };
 184
 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
 194                 # Get the Tag attributes
 195 #warn "    getting attribs: ",join(" ",@{$spec->{attrib_data}}),"\n";
 196         foreach ( @{$spec->{attrib_data}} ) {
 197                         $thing->{$_} = $node->getAttribute($_);
 198                 }
 199 #warn "    got attribs: ",(map "$_=$thing->{$_}", keys %$thing),"\n";
 200
 201         # Add the path data
 202         foreach ( @{$spec->{path_data}} ) {
 203 #warn "    getting path data $_->{name} : $_->{path}\n";
 204             my @nodes = $node->findnodes($_->{path});
 205             $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
 206                 : (exists $_->{default} ? $_->{default} : undef);
 207 #warn "    got path data $_->{name}=$thing->{$_->{name}}\n";
 208         }
 209
 210         # Run any filters set
 211         #
 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         }
 218
 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
 226         # Kids
 227         #
 228         foreach ( @{$spec->{kids}} ) {
 229                         my $data;
 230             my $meth = $_->{get_method};
 231             my $path = $_->{path};
 232
 233                         # Variable subs on the path from thing
 234                         $path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
 235                         $data = $me->$meth( _context => $node, _xpath => $path,
 236                 filter => $args{"filter_$_->{name}"} );
 237             if ( $_->{multiplicity} eq "1" ) {
 238                 $thing->{$_->{name}} = shift @$data;
 239             }
 240             else {
 241                 my $kids = $thing->{$_->{name}} = $data || [];
 242                                 if ( my $key = $_->{"map"} ) {
 243                                         $thing->{"_map_$_->{name}"} = _mk_map($kids,$key);
 244                                 }
 245             }
 246         }
 247         }
 248
 249         if ( $spec->{isRoot} ) {
 250                 push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things;
 251         }
 252         return $things;
 253 } # /closure sub
 254
 255 } # /_mk_get
 256
 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
 266 sub get_associations {
 267         my $assoc = shift->_get_associations(@_);
 268         foreach (@$assoc) {
 269                 next unless defined $_->{associationEnds}; # Wait until we get all of an association
 270                 my @ends = @{$_->{associationEnds}};
 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
 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) = @_;
 295     my $nodeset;
 296     if (@params > 1) {
 297         die "xmiDeref() function takes one or no parameters\n";
 298     }
 299     elsif (@params) {
 300         $nodeset = shift(@params);
 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
 307     my $id = $node->getAttribute("xmi.idref") || return ($nodeset || $node);
 308     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 309     # TODO We should use the tag name to search from the source
 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
 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.
 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
 429 The Parser adds the following extra XPath functions for use in the Specs.
 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
 471 =cut