lib/SQL/Translator/XMI/Parser.pm

   1 package SQL::Translator::XMI::Parser;
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 SQL::Translator::XMI::Parser- Perl class for blah blah blah
   8
   9 =cut
  10
  11 use strict;
  12 use 5.006_001;
  13 our $VERSION = "0.01";
  14
  15 use XML::XPath;
  16 use XML::XPath::XMLParser;
  17 use Storable qw/dclone/;
  18
  19 # Spec
  20 #=============================================================================
  21 #
  22 # Describes the 2 xmi formats 1.2 and 1.0. Neither is complete!
  23 #
  24 # NB The names of the data keys MUST be the same for both specs so the
  25 # data structures returned are the same.
  26 #
  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.
  31 #
  32
  33 my $SPECS = {};
  34
  35 my $spec12 = $SPECS->{"1.2"} = {};
  36
  37 $spec12->{class} = {
  38     name   => "class",
  39     plural => "classes",
  40     default_path => '//UML:Class[@xmi.id]',
  41     attrib_data =>
  42         [qw/name visibility isSpecification isRoot isLeaf isAbstract isActive/],
  43     path_data => [
  44         {
  45             name  => "stereotype",
  46             path  => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
  47             default => "",
  48         },
  49     ],
  50     kids => [
  51         {
  52             name  => "attributes",
  53             # name in data returned
  54             path  => "UML:Classifier.feature/UML:Attribute",
  55             class => "attribute",
  56             # Points to class in spec. get_attributes() called to parse it and
  57             # adds filter_attributes to the args for get_classes().
  58             multiplicity => "*",
  59             # How many we get back. Use '1' for 1 and '*' for lots.
  60                         # TODO If not set then decide depening on the return?
  61         },
  62         {
  63             name  => "operations",
  64             path  => "UML:Classifier.feature/UML:Operation",
  65             class => "operation",
  66             multiplicity => "*",
  67         },
  68         {
  69             name  => "taggedValues",
  70             path  => 'UML:ModelElement.taggedValue/UML:TaggedValue',
  71             class => "taggedValue",
  72             multiplicity => "*",
  73                         # Nice if we could say that the list should me folded into a hash
  74                         # on the name key. type=>"hash", hash_key=>"name" or something!
  75         },
  76     ],
  77 };
  78
  79 $spec12->{taggedValue} = {
  80     name   => "taggedValue",
  81     plural => "taggedValues",
  82     default_path => '//UML:TaggedValue[@xmi.id]',
  83     attrib_data  => [qw/isSpecification/],
  84     path_data => [
  85         {
  86             name  => "dataValue",
  87             path  => 'UML:TaggedValue.dataValue/text()',
  88         },
  89         {
  90             name  => "name",
  91             path  => 'xmiDeref(UML:TaggedValue.type/UML:TagDefinition)/@name',
  92         },
  93     ],
  94 };
  95
  96 $spec12->{attribute} = {
  97     name => "attribute",
  98     plural => "attributes",
  99     default_path => '//UML:Classifier.feature/UML:Attribute[@xmi.id]',
 100     attrib_data =>
 101         [qw/name visibility isSpecification ownerScope/],
 102     path_data => [
 103         {
 104             name  => "stereotype",
 105             path  => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
 106             default => "",
 107         },
 108         {
 109             name  => "datatype",
 110             path  => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name',
 111         },
 112         {
 113             name  => "initialValue",
 114             path  => 'UML:Attribute.initialValue/UML:Expression/@body',
 115         },
 116     ],
 117     kids => [
 118         {
 119             name  => "taggedValues",
 120             path  => 'UML:ModelElement.taggedValue/UML:TaggedValue',
 121             class => "taggedValue",
 122             multiplicity => "*",
 123         },
 124     ],
 125 };
 126
 127 $spec12->{operation} = {
 128     name => "operation",
 129     plural => "operations",
 130     default_path => '//UML:Classifier.feature/UML:Operation[@xmi.id]',
 131     attrib_data =>
 132         [qw/name visibility isSpecification ownerScope isQuery
 133             concurrency isRoot isLeaf isAbstract/],
 134     path_data => [
 135         {
 136             name  => "stereotype",
 137             path  => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
 138             default => "",
 139         },
 140     ],
 141     kids => [
 142         {
 143             name  => "parameters",
 144             path  => "UML:BehavioralFeature.parameter/UML:Parameter",
 145             class => "parameter",
 146             multiplicity => "*",
 147         },
 148         {
 149             name  => "taggedValues",
 150             path  => 'UML:ModelElement.taggedValue/UML:TaggedValue',
 151             class => "taggedValue",
 152             multiplicity => "*",
 153         },
 154     ],
 155 };
 156
 157 $spec12->{parameter} = {
 158     name   => "parameter",
 159     plural => "parameters",
 160     default_path => '//UML:BehavioralFeature.parameter/UML:Parameter[@xmi.id]',
 161     attrib_data  => [qw/name isSpecification kind/],
 162     path_data => [
 163         {
 164             name  => "stereotype",
 165             path  => 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name',
 166             default => "",
 167         },
 168         {
 169             name  => "datatype",
 170             path  => 'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name',
 171         },
 172     ],
 173 };
 174
 175 #-----------------------------------------------------------------------------
 176
 177 my $spec10 = $SPECS->{"1.0"} = {};
 178
 179 $spec10->{class} = {
 180     name   => "class",
 181     plural => "classes",
 182     default_path => '//Foundation.Core.Class[@xmi.id]',
 183     attrib_data => [],
 184     path_data => [
 185         {
 186             name  => "name",
 187             path  => 'Foundation.Core.ModelElement.name/text()',
 188         },
 189         {
 190             name => "visibility",
 191             path => 'Foundation.Core.ModelElement.visibility/@xmi.value',
 192         },
 193         {
 194             name => "isSpecification",
 195             path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value',
 196         },
 197         {
 198             name => "isRoot",
 199             path => 'Foundation.Core.GeneralizableElement.isRoot/@xmi.value',
 200         },
 201         {
 202             name => "isLeaf",
 203             path => 'Foundation.Core.GeneralizableElement.isLeaf/@xmi.value',
 204         },
 205         {
 206             name => "isAbstract",
 207             path => 'Foundation.Core.GeneralizableElement.isAbstract/@xmi.value',
 208         },
 209         {
 210             name => "isActive",
 211             path => 'Foundation.Core.Class.isActive/@xmi.value',
 212         },
 213     ],
 214     kids => [
 215             {
 216             name  => "attributes",
 217             path  =>
 218                 'Foundation.Core.Classifier.feature/Foundation.Core.Attribute',
 219             class => "attribute",
 220             multiplicity => "*",
 221         },
 222     #    {
 223     #        name  => "operations",
 224     #        path  => "UML:Classifier.feature/UML:Operation",
 225     #        class => "operation",
 226     #        multiplicity => "*",
 227     #    },
 228     ],
 229 };
 230
 231 $spec10->{attribute} = {
 232     name => "attribute",
 233     plural => "attributes",
 234     default_path => '//Foundation.Core.Attribute[@xmi.id]',
 235     path_data => [
 236         {
 237             name  => "name",
 238             path  => 'Foundation.Core.ModelElement.name/text()',
 239         },
 240         {
 241             name => "visibility",
 242             path => 'Foundation.Core.ModelElement.visibility/@xmi.value',
 243         },
 244         {
 245             name => "isSpecification",
 246             path => 'Foundation.Core.ModelElement.isSpecification/@xmi.value',
 247         },
 248         {
 249             name => "ownerScope",
 250             path => 'Foundation.Core.Feature.ownerScope/@xmi.value',
 251         },
 252                 {
 253             name  => "initialValue",
 254             path  => 'Foundation.Core.Attribute.initialValue/Foundation.Data_Types.Expression/Foundation.Data_Types.Expression.body/text()',
 255         },
 256                 #{
 257         #    name  => "datatype",
 258         #    path  => 'xmiDeref(Foundation.Core.StructuralFeature.type/Foundation.Core.Classifier)/Foundation.Core.DataType/Foundation.Core.ModelElement.name/text()',
 259         #},
 260     ],
 261 };
 262
 263 #=============================================================================
 264
 265 #
 266 # How this works!
 267 #=================
 268 #
 269 # The parser supports xmi1.0 and xmi1.2 based on the specs above. At new() time
 270 # the version is read from the XMI tag and picks out a spec e.g.
 271 # $SPECS->{"1.2"} and feeds it to mk_gets() which returns a hash ref of subs
 272 # (think strategy pattern), one for each entry in the specs hash. This is held
 273 # in $self->{xmi_get_}.
 274 #
 275 # When the class is use'd it sets dispatch methods with
 276 # mk_get_dispatch() that return the call using the corresponding sub in
 277 # $self->{xmi_get_}. e.g.
 278 #
 279 # sub get_classes    { $_[0]->{xmi_get_}{classes}->(@_); }
 280 # sub get_attributes { $_[0]->{xmi_get_}{attributes}->(@_); }
 281 # sub get_classes    { $_[0]->{xmi_get_}{classes}->(@_); }
 282 #
 283 # The names for the data keys in the specs must match up so that we get the
 284 # same data structure for each version.
 285 #
 286
 287 # Class setup
 288 foreach ( values %$SPECS ) { init_specs($_) };
 289 mk_get_dispatch();
 290
 291 # Build lookups etc. Its important that each spec item becomes self contained
 292 # so we can build good closures, therefor we do all the lookups 1st.
 293 sub init_specs {
 294         my $specs = shift;
 295
 296         foreach my $spec ( values %$specs ) {
 297         foreach ( @{$spec->{kids}} ) {
 298             $_->{get_method} = "get_".$specs->{$_->{class}}{plural};
 299         }
 300         }
 301
 302 }
 303
 304 # Generate get_* subs to dispach the calls to the subs held in $me->{xmi_get_}
 305 sub mk_get_dispatch {
 306     foreach ( values %{$SPECS->{"1.2"}} ) {
 307         my $name = $_->{plural};
 308         no strict "refs";
 309
 310         # get_ on parser
 311         *{"get_$name"} = sub {
 312                         #my $me = shift;
 313             #$me->{xmi_get_}{$name}->($me,@_);
 314             $_[0]->{xmi_get_}{$name}->(@_);
 315         };
 316     }
 317 }
 318
 319 sub new {
 320     my $proto = shift;
 321     my $class = ref($proto) || $proto;
 322     my %args = @_;
 323     my $me = {};
 324
 325     # Create the XML::XPath object
 326     # TODO Docs recommend we only use 1 XPath object per application
 327     my $xp;
 328     foreach (qw/filename xml ioref/) {
 329         if ($args{$_}) {
 330             $xp = XML::XPath->new( $_ => $args{$_});
 331             $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
 332             last;
 333         }
 334     }
 335     $me = { xml_xpath => $xp };
 336
 337     # Work out the version of XMI we have and generate the get subs to parse it
 338     my $xmiv = "".$xp->findvalue('/XMI/@xmi.version')
 339         or die "Can't find XMI version";
 340     $me->{xmi_get_} = mk_gets($SPECS->{$xmiv});
 341
 342     return bless $me, $class;
 343 }
 344
 345
 346 # Returns hashref of get subs from set of specs e.g. $SPECS->{"1.2"}
 347 #
 348 # TODO
 349 # * Add a memoize so we don't keep regenerating the subs for every use.
 350 sub mk_gets {
 351     my $specs = shift;
 352     my $gets;
 353     foreach ( values %$specs ) {
 354         # Clone from specs and sort out the lookups into it so we get a
 355         # self contained spec to use as a proper closure.
 356         my $spec = dclone($_);
 357
 358         # Add the sub
 359         $gets->{$spec->{plural}} = mk_get($spec);
 360     }
 361     return $gets;
 362 }
 363
 364 #
 365 # mk_get
 366 #
 367 # Generates and returns a get_ sub for the spec given. e.g. give it
 368 # $SPECS->{"1.2"}->{classes} to get the code for xmi 1.2 get_classes. So, if
 369 # you want to change how the get methods work do it here!
 370 #
 371 # The get methods made have the args described in the docs and 2 private args
 372 # used internally, to call other get methods from paths in the spec.
 373 #
 374 # NB: DO NOT use publicly as you will break the version independance. e.g. When
 375 # using _xpath you need to know which version of XMI to use. This is handled by
 376 # the use of different paths in the specs.
 377 #
 378 #  _context => The context node to use, if not given starts from root.
 379 #
 380 #  _xpath   => The xpath to use for finding stuff.
 381 #
 382 use Data::Dumper;
 383 sub mk_get {
 384     my $spec = shift;
 385
 386     # get_* closure using $spec
 387     return sub {
 388         my ($me, %args) = @_;
 389     my $xp = delete $args{_context} || $me->{xml_xpath};
 390         my $things;
 391
 392         my $xpath = $args{_xpath} ||= $spec->{default_path};
 393 #warn "Searching for $spec->{plural} using:$xpath\n";
 394
 395     my @nodes = $xp->findnodes($xpath);
 396         return unless @nodes;
 397
 398         for my $node (@nodes) {
 399                 my $thing = {};
 400         # my $thing = { xpNode => $node };
 401
 402                 # Get the Tag attributes
 403         foreach ( @{$spec->{attrib_data}} ) {
 404                         $thing->{$_} = $node->getAttribute($_);
 405                 }
 406
 407         # Add the path data
 408         foreach ( @{$spec->{path_data}} ) {
 409 #warn "Searching for $spec->{plural} - $_->{name} using:$_->{path}\n";
 410             my @nodes = $node->findnodes($_->{path});
 411             $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
 412                 : (exists $_->{default} ? $_->{default} : undef);
 413         }
 414
 415         # Run any filters set
 416         #
 417         # Should we do this after the kids as we may want to test them?
 418         # e.g. test for number of attribs
 419         if ( my $filter = $args{filter} ) {
 420             local $_ = $thing;
 421             next unless $filter->($thing);
 422         }
 423
 424         # Kids
 425         #
 426         foreach ( @{$spec->{kids}} ) {
 427             my $data;
 428             my $meth = $_->{get_method};
 429             $data = $me->$meth( _context => $node, _xpath => $_->{path},
 430                 filter => $args{"filter_$_->{name}"} );
 431
 432             if ( $_->{multiplicity} eq "1" ) {
 433                 $thing->{$_->{name}} = shift @$data;
 434             }
 435             else {
 436                 $thing->{$_->{name}} = $data || [];
 437             }
 438         }
 439
 440         push @$things, $thing;
 441         }
 442         return wantarray ? @$things : $things;
 443 } # /closure sub
 444
 445 } # /mk_get
 446
 447 1; #===========================================================================
 448
 449
 450 package XML::XPath::Function;
 451
 452 #
 453 # May need to look at doing deref on all paths just to be on the safe side!
 454 #
 455 # Will also want some caching as these calls are expensive as the whole doc
 456 # is used but the same ref will likley be requested lots of times.
 457 #
 458 sub xmiDeref {
 459     my $self = shift;
 460     my ($node, @params) = @_;
 461     if (@params > 1) {
 462         die "xmiDeref() function takes one or no parameters\n";
 463     }
 464     elsif (@params) {
 465         my $nodeset = shift(@params);
 466         return $nodeset unless $nodeset->size;
 467         $node = $nodeset->get_node(1);
 468     }
 469     die "xmiDeref() needs an Element node."
 470     unless $node->isa("XML::XPath::Node::Element");
 471
 472     my $id = $node->getAttribute("xmi.idref") or return $node;
 473     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 474 }
 475
 476
 477 # compile please
 478 1;
 479
 480 __END__
 481
 482 =head1 SYNOPSIS
 483
 484  use SQL::Translator::XMI::Parser;
 485  my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
 486  my $classes = $xmip->get_classes();
 487
 488 =head1 DESCRIPTION
 489
 490 Parses XMI files (XML version of UML diagrams) to perl data structures and
 491 provides hooks to filter the data down to what you want.
 492
 493 =head2 new
 494
 495 Pass in name/value arg of either filename, xml or ioref for the XMI data you
 496 want to parse.
 497
 498 =head2 get_* methods
 499
 500 Doc below is for classes method, all the other calls follow this form.
 501
 502 =head2 get_classes( ARGS )
 503
 504  ARGS     - Name/Value list of args.
 505
 506  filter   => A sub to filter the node to see if we want it. Has the nodes data,
 507              before kids are added, referenced to $_. Should return true if you
 508              want it, false otherwise.
 509
 510              e.g. To find only classes with a "Foo" stereotype.
 511
 512               filter => sub { return $_->{stereotype} eq "Foo"; }
 513
 514  filter_attributes => A filter sub to pass onto get_attributes.
 515
 516  filter_operations => A filter sub to pass onto get_operations.
 517
 518 Returns a perl data structure including all the kids. e.g.
 519
 520  {
 521    'name' => 'Foo',
 522    'visibility' => 'public',
 523    'isActive' => 'false',
 524    'isAbstract' => 'false',
 525    'isSpecification' => 'false',
 526    'stereotype' => 'Table',
 527    'isRoot' => 'false',
 528    'isLeaf' => 'false',
 529    'attributes' => [
 530        {
 531          'name' => 'fooid',
 532          'stereotype' => 'PK',
 533          'datatype' => 'int'
 534          'ownerScope' => 'instance',
 535          'visibility' => 'public',
 536          'initialValue' => undef,
 537          'isSpecification' => 'false',
 538        },
 539        {
 540          'name' => 'name',
 541          'stereotype' => '',
 542          'datatype' => 'varchar'
 543          'ownerScope' => 'instance',
 544          'visibility' => 'public',
 545          'initialValue' => '',
 546          'isSpecification' => 'false',
 547        },
 548    ]
 549    'operations' => [
 550        {
 551          'name' => 'magic',
 552          'isQuery' => 'false',
 553          'ownerScope' => 'instance',
 554          'visibility' => 'public',
 555          'isSpecification' => 'false',
 556          'stereotype' => '',
 557          'isAbstract' => 'false',
 558          'isLeaf' => 'false',
 559          'isRoot' => 'false',
 560          'concurrency' => 'sequential'
 561          'parameters' => [
 562              {
 563                'kind' => 'inout',
 564                'isSpecification' => 'false',
 565                'stereotype' => '',
 566                'name' => 'arg1',
 567                'datatype' => undef
 568              },
 569              {
 570                'kind' => 'inout',
 571                'isSpecification' => 'false',
 572                'stereotype' => '',
 573                'name' => 'arg2',
 574                'datatype' => undef
 575              },
 576              {
 577                'kind' => 'return',
 578                'isSpecification' => 'false',
 579                'stereotype' => '',
 580                'name' => 'return',
 581                'datatype' => undef
 582              }
 583          ],
 584        }
 585    ],
 586  }
 587
 588 =head1 XMI XPath Functions
 589
 590 The Parser adds the following extra XPath functions for use in the SPECS.
 591
 592 =head2 xmiDeref
 593
 594 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
 595 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
 596 tag it points at has an xmi.idref it looks up the tag with that
 597 xmi.id and returns it.
 598
 599 If it doesn't have an xmi.id, the path is returned as normal.
 600
 601 e.g. given
 602
 603  <UML:ModelElement.stereotype>
 604      <UML:Stereotype xmi.idref = 'stTable'/>
 605  </UML:ModelElement.stereotype>
 606   ...
 607  <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
 608      isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
 609      <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 610  </UML:Stereotype>
 611
 612 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
 613 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
 614
 615 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
 616 "Table".
 617
 618 =head1 SEE ALSO
 619
 620 perl(1).
 621
 622 =head1 TODO
 623
 624 =head1 BUGS
 625
 626 =head1 VERSION HISTORY
 627
 628 =head1 AUTHOR
 629
 630 grommit <mark.addison@itn.co.uk>
 631
 632 =head1 LICENSE
 633
 634 This package is free software and is provided "as is" without express or
 635 implied warranty. It may be used, redistributed and/or modified under the
 636 terms of either;
 637
 638 a) the Perl Artistic License.
 639
 640 See F<http://www.perl.com/perl/misc/Artistic.html>
 641
 642 b) the terms of the GNU General Public License as published by the Free Software
 643 Foundation; either version 1, or (at your option) any later version.
 644
 645 =cut