lib/SQL/Translator/XMI/Parser.pm

   1 package SQL::Translator::XMI::Parser;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Parser.pm,v 1.6 2003-10-01 17:45:47 grommit Exp $
   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: 1.6 $ =~ /(\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         foreach ( @{$spec->{attrib_data}} ) {
 196                         $thing->{$_} = $node->getAttribute($_);
 197                 }
 198
 199         # Add the path data
 200         foreach ( @{$spec->{path_data}} ) {
 201 #warn "          $spec->{name} - $_->{name} using:$_->{path}\n";
 202             my @nodes = $node->findnodes($_->{path});
 203             $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
 204                 : (exists $_->{default} ? $_->{default} : undef);
 205         }
 206
 207         # Run any filters set
 208         #
 209         # Should we do this after the kids as we may want to test them?
 210         # e.g. test for number of attribs
 211         if ( my $filter = $args{filter} ) {
 212             local $_ = $thing;
 213             next unless $filter->($thing);
 214         }
 215
 216         # Add anything with an id to the things lookup
 217         push @$things, $thing;
 218                 if ( exists $thing->{"xmi.id"} and defined $thing->{"xmi.id"}
 219             and my $id = $thing->{"xmi.id"}
 220         ) {
 221                         $me->{model}{things}{$id} = $thing; }
 222
 223         # Kids
 224         #
 225         foreach ( @{$spec->{kids}} ) {
 226                         my $data;
 227             my $meth = $_->{get_method};
 228             my $path = $_->{path};
 229
 230                         # Variable subs on the path from thing
 231                         $path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
 232                         $data = $me->$meth( _context => $node, _xpath => $path,
 233                 filter => $args{"filter_$_->{name}"} );
 234
 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 $_->{ends}; # Wait until we get all of an association
 268                 my @ends = @{$_->{ends}};
 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     if (@params > 1) {
 294         die "xmiDeref() function takes one or no parameters\n";
 295     }
 296     elsif (@params) {
 297         my $nodeset = shift(@params);
 298         return $nodeset unless $nodeset->size;
 299         $node = $nodeset->get_node(1);
 300     }
 301     die "xmiDeref() needs an Element node."
 302     unless $node->isa("XML::XPath::Node::Element");
 303
 304     my $id = $node->getAttribute("xmi.idref") or return $node;
 305     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 306 }
 307
 308
 309 # compile please
 310 1;
 311
 312 __END__
 313
 314 =head1 SYNOPSIS
 315
 316  use SQL::Translator::XMI::Parser;
 317  my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
 318  my $classes = $xmip->get_classes();
 319
 320 =head1 DESCRIPTION
 321
 322 Parses XMI files (XML version of UML diagrams) to perl data structures and
 323 provides hooks to filter the data down to what you want.
 324
 325 =head2 new
 326
 327 Pass in name/value arg of either C<filename>, C<xml> or C<ioref> for the XMI
 328 data you want to parse.
 329
 330 The version of XMI to use either 1.0 or 1.2 is worked out from the file. You
 331 can also use a C<xmi_version> arg to set it explicitley.
 332
 333 =head2 get_* methods
 334
 335 Doc below is for classes method, all the other calls follow this form.
 336
 337 =head2 get_classes( ARGS )
 338
 339  ARGS     - Name/Value list of args.
 340
 341  filter   => A sub to filter the node to see if we want it. Has the nodes data,
 342              before kids are added, referenced to $_. Should return true if you
 343              want it, false otherwise.
 344
 345              e.g. To find only classes with a "Foo" stereotype.
 346
 347               filter => sub { return $_->{stereotype} eq "Foo"; }
 348
 349  filter_attributes => A filter sub to pass onto get_attributes.
 350
 351  filter_operations => A filter sub to pass onto get_operations.
 352
 353 Returns a perl data structure including all the kids. e.g.
 354
 355  {
 356    'name' => 'Foo',
 357    'visibility' => 'public',
 358    'isActive' => 'false',
 359    'isAbstract' => 'false',
 360    'isSpecification' => 'false',
 361    'stereotype' => 'Table',
 362    'isRoot' => 'false',
 363    'isLeaf' => 'false',
 364    'attributes' => [
 365        {
 366          'name' => 'fooid',
 367          'stereotype' => 'PK',
 368          'datatype' => 'int'
 369          'ownerScope' => 'instance',
 370          'visibility' => 'public',
 371          'initialValue' => undef,
 372          'isSpecification' => 'false',
 373        },
 374        {
 375          'name' => 'name',
 376          'stereotype' => '',
 377          'datatype' => 'varchar'
 378          'ownerScope' => 'instance',
 379          'visibility' => 'public',
 380          'initialValue' => '',
 381          'isSpecification' => 'false',
 382        },
 383    ]
 384    'operations' => [
 385        {
 386          'name' => 'magic',
 387          'isQuery' => 'false',
 388          'ownerScope' => 'instance',
 389          'visibility' => 'public',
 390          'isSpecification' => 'false',
 391          'stereotype' => '',
 392          'isAbstract' => 'false',
 393          'isLeaf' => 'false',
 394          'isRoot' => 'false',
 395          'concurrency' => 'sequential'
 396          'parameters' => [
 397              {
 398                'kind' => 'inout',
 399                'isSpecification' => 'false',
 400                'stereotype' => '',
 401                'name' => 'arg1',
 402                'datatype' => undef
 403              },
 404              {
 405                'kind' => 'inout',
 406                'isSpecification' => 'false',
 407                'stereotype' => '',
 408                'name' => 'arg2',
 409                'datatype' => undef
 410              },
 411              {
 412                'kind' => 'return',
 413                'isSpecification' => 'false',
 414                'stereotype' => '',
 415                'name' => 'return',
 416                'datatype' => undef
 417              }
 418          ],
 419        }
 420    ],
 421  }
 422
 423 =head1 XMI XPath Functions
 424
 425 The Parser adds the following extra XPath functions for use in the Specs.
 426
 427 =head2 xmiDeref
 428
 429 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
 430 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
 431 tag it points at has an xmi.idref it looks up the tag with that
 432 xmi.id and returns it.
 433
 434 If it doesn't have an xmi.id, the path is returned as normal.
 435
 436 e.g. given
 437
 438  <UML:ModelElement.stereotype>
 439      <UML:Stereotype xmi.idref = 'stTable'/>
 440  </UML:ModelElement.stereotype>
 441   ...
 442  <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
 443      isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
 444      <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 445  </UML:Stereotype>
 446
 447 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
 448 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
 449
 450 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
 451 "Table".
 452
 453 =head1 SEE ALSO
 454
 455 perl(1).
 456
 457 =head1 TODO
 458
 459 =head1 BUGS
 460
 461 =head1 VERSION HISTORY
 462
 463 =head1 AUTHOR
 464
 465 grommit <mark.addison@itn.co.uk>
 466
 467 =cut