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