lib/SQL/Translator/XMI/Parser.pm

   1 package SQL::Translator::XMI::Parser;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Parser.pm,v 1.5 2003-09-29 12:02:35 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.5 $ =~ /(\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 # e.g. of overriding both versions.
 114 #sub get_classes {
 115 #       print "HELLO Both\n";
 116 #       return shift->_get_classes(@_);
 117 #}
 118
 119 #
 120 # Sets up the XML::XPath object and then checks the version of the XMI file and
 121 # blesses its self into either the V10 or V12 class.
 122 #
 123 sub new {
 124     my $proto = shift;
 125     my $class = ref($proto) || $proto;
 126     my %args = @_;
 127     my $me = {};
 128
 129     # Create the XML::XPath object
 130     # TODO Docs recommend we only use 1 XPath object per application
 131     my $xp;
 132     foreach (qw/filename xml ioref/) {
 133         if ($args{$_}) {
 134             $xp = XML::XPath->new( $_ => $args{$_});
 135             $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
 136             last;
 137         }
 138     }
 139     $me = { xml_xpath => $xp };
 140
 141     # Work out the version of XMI we have and return as that sub class
 142         my $xmiv = $args{xmi_version}
 143             || "".$xp->findvalue('/XMI/@xmi.version')
 144         || die "Can't find XMI version";
 145         $xmiv =~ s/[.]//g;
 146         $class = __PACKAGE__."::V$xmiv";
 147         eval "use $class;";
 148         die "Failed to load version sub class $class : $@" if $@;
 149
 150         return bless $me, $class;
 151 }
 152
 153 #
 154 # mk_get
 155 #
 156 # Generates and returns a get_ sub for the spec given.
 157 # So, if you want to change how the get methods (e.g. get_classes) work do it
 158 # here!
 159 #
 160 # The get methods made have the args described in the docs and 2 private args
 161 # used internally, to call other get methods from paths in the spec.
 162 # NB: DO NOT use publicly as you will break the version independance. e.g. When
 163 # using _xpath you need to know which version of XMI to use. This is handled by
 164 # the use of different paths in the specs.
 165 #
 166 #  _context => The context node to use, if not given starts from root.
 167 #
 168 #  _xpath   => The xpath to use for finding stuff.
 169 #
 170 sub mk_get {
 171     my $spec = shift;
 172
 173     # get_* closure using $spec
 174     return sub {
 175         my ($me, %args) = @_;
 176     my $xp = delete $args{_context} || $me->{xml_xpath};
 177         my $things;
 178
 179         my $xpath = $args{_xpath} ||= $spec->{default_path};
 180 #warn "Searching for $spec->{plural} using:$xpath\n";
 181
 182     my @nodes = $xp->findnodes($xpath);
 183 #warn "None.\n" unless @nodes;
 184         return unless @nodes;
 185
 186         for my $node (@nodes) {
 187 #warn "    Found $spec->{name} xmi.id=".$node->getAttribute("xmi.id")." name=".$node->getAttribute("name")."\n";
 188                 my $thing = {};
 189         # my $thing = { xpNode => $node };
 190
 191                 # Have we seen this before? If so just use the ref we have.
 192         if ( my $id = $node->getAttribute("xmi.id") ) {
 193             if ( my $foo = $me->{model}{things}{$id} ) {
 194 #warn "    Reffing from model **********************\n";
 195                 push @$things, $foo;
 196                                 next;
 197                         }
 198         }
 199
 200                 # Get the Tag attributes
 201         foreach ( @{$spec->{attrib_data}} ) {
 202                         $thing->{$_} = $node->getAttribute($_);
 203                 }
 204
 205         # Add the path data
 206         foreach ( @{$spec->{path_data}} ) {
 207 #warn "          $spec->{name} - $_->{name} using:$_->{path}\n";
 208             my @nodes = $node->findnodes($_->{path});
 209             $thing->{$_->{name}} = @nodes ? $nodes[0]->getData
 210                 : (exists $_->{default} ? $_->{default} : undef);
 211         }
 212
 213         # Run any filters set
 214         #
 215         # Should we do this after the kids as we may want to test them?
 216         # e.g. test for number of attribs
 217         if ( my $filter = $args{filter} ) {
 218             local $_ = $thing;
 219             next unless $filter->($thing);
 220         }
 221
 222         # Add anything with an id to the things lookup
 223         push @$things, $thing;
 224                 if ( exists $thing->{"xmi.id"} and defined $thing->{"xmi.id"}
 225             and my $id = $thing->{"xmi.id"}
 226         ) {
 227                         $me->{model}{things}{$id} = $thing; }
 228
 229         # Kids
 230         #
 231         foreach ( @{$spec->{kids}} ) {
 232                         my $data;
 233             my $meth = $_->{get_method};
 234             my $path = $_->{path};
 235
 236                         # Variable subs on the path from thing
 237                         $path =~ s/\$\{(.*?)\}/$thing->{$1}/g;
 238                         $data = $me->$meth( _context => $node, _xpath => $path,
 239                 filter => $args{"filter_$_->{name}"} );
 240
 241             if ( $_->{multiplicity} eq "1" ) {
 242                 $thing->{$_->{name}} = shift @$data;
 243             }
 244             else {
 245                 my $kids = $thing->{$_->{name}} = $data || [];
 246                                 if ( my $key = $_->{"map"} ) {
 247                                         $thing->{"_map_$_->{name}"} = _mk_map($kids,$key);
 248                                 }
 249             }
 250         }
 251         }
 252
 253         if ( $spec->{isRoot} ) {
 254                 push(@{$me->{model}{$spec->{plural}}}, $_) foreach @$things;
 255         }
 256         return $things;
 257 } # /closure sub
 258
 259 } # /mk_get
 260
 261 sub _mk_map {
 262         my ($kids,$key) = @_;
 263         my $map = {};
 264         foreach (@$kids) {
 265                 $map->{$_->{$key}} = $_ if exists $_->{$key};
 266         }
 267         return $map;
 268 }
 269
 270 1; #===========================================================================
 271
 272
 273 package XML::XPath::Function;
 274
 275 #
 276 # May need to look at doing deref on all paths just to be on the safe side!
 277 #
 278 # Will also want some caching as these calls are expensive as the whole doc
 279 # is used but the same ref will likley be requested lots of times.
 280 #
 281 sub xmiDeref {
 282     my $self = shift;
 283     my ($node, @params) = @_;
 284     if (@params > 1) {
 285         die "xmiDeref() function takes one or no parameters\n";
 286     }
 287     elsif (@params) {
 288         my $nodeset = shift(@params);
 289         return $nodeset unless $nodeset->size;
 290         $node = $nodeset->get_node(1);
 291     }
 292     die "xmiDeref() needs an Element node."
 293     unless $node->isa("XML::XPath::Node::Element");
 294
 295     my $id = $node->getAttribute("xmi.idref") or return $node;
 296     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 297 }
 298
 299
 300 # compile please
 301 1;
 302
 303 __END__
 304
 305 =head1 SYNOPSIS
 306
 307  use SQL::Translator::XMI::Parser;
 308  my $xmip = SQL::Translator::XMI::Parser->new( xml => $xml );
 309  my $classes = $xmip->get_classes();
 310
 311 =head1 DESCRIPTION
 312
 313 Parses XMI files (XML version of UML diagrams) to perl data structures and
 314 provides hooks to filter the data down to what you want.
 315
 316 =head2 new
 317
 318 Pass in name/value arg of either C<filename>, C<xml> or C<ioref> for the XMI
 319 data you want to parse.
 320
 321 The version of XMI to use either 1.0 or 1.2 is worked out from the file. You
 322 can also use a C<xmi_version> arg to set it explicitley.
 323
 324 =head2 get_* methods
 325
 326 Doc below is for classes method, all the other calls follow this form.
 327
 328 =head2 get_classes( ARGS )
 329
 330  ARGS     - Name/Value list of args.
 331
 332  filter   => A sub to filter the node to see if we want it. Has the nodes data,
 333              before kids are added, referenced to $_. Should return true if you
 334              want it, false otherwise.
 335
 336              e.g. To find only classes with a "Foo" stereotype.
 337
 338               filter => sub { return $_->{stereotype} eq "Foo"; }
 339
 340  filter_attributes => A filter sub to pass onto get_attributes.
 341
 342  filter_operations => A filter sub to pass onto get_operations.
 343
 344 Returns a perl data structure including all the kids. e.g.
 345
 346  {
 347    'name' => 'Foo',
 348    'visibility' => 'public',
 349    'isActive' => 'false',
 350    'isAbstract' => 'false',
 351    'isSpecification' => 'false',
 352    'stereotype' => 'Table',
 353    'isRoot' => 'false',
 354    'isLeaf' => 'false',
 355    'attributes' => [
 356        {
 357          'name' => 'fooid',
 358          'stereotype' => 'PK',
 359          'datatype' => 'int'
 360          'ownerScope' => 'instance',
 361          'visibility' => 'public',
 362          'initialValue' => undef,
 363          'isSpecification' => 'false',
 364        },
 365        {
 366          'name' => 'name',
 367          'stereotype' => '',
 368          'datatype' => 'varchar'
 369          'ownerScope' => 'instance',
 370          'visibility' => 'public',
 371          'initialValue' => '',
 372          'isSpecification' => 'false',
 373        },
 374    ]
 375    'operations' => [
 376        {
 377          'name' => 'magic',
 378          'isQuery' => 'false',
 379          'ownerScope' => 'instance',
 380          'visibility' => 'public',
 381          'isSpecification' => 'false',
 382          'stereotype' => '',
 383          'isAbstract' => 'false',
 384          'isLeaf' => 'false',
 385          'isRoot' => 'false',
 386          'concurrency' => 'sequential'
 387          'parameters' => [
 388              {
 389                'kind' => 'inout',
 390                'isSpecification' => 'false',
 391                'stereotype' => '',
 392                'name' => 'arg1',
 393                'datatype' => undef
 394              },
 395              {
 396                'kind' => 'inout',
 397                'isSpecification' => 'false',
 398                'stereotype' => '',
 399                'name' => 'arg2',
 400                'datatype' => undef
 401              },
 402              {
 403                'kind' => 'return',
 404                'isSpecification' => 'false',
 405                'stereotype' => '',
 406                'name' => 'return',
 407                'datatype' => undef
 408              }
 409          ],
 410        }
 411    ],
 412  }
 413
 414 =head1 XMI XPath Functions
 415
 416 The Parser adds the following extra XPath functions for use in the Specs.
 417
 418 =head2 xmiDeref
 419
 420 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
 421 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
 422 tag it points at has an xmi.idref it looks up the tag with that
 423 xmi.id and returns it.
 424
 425 If it doesn't have an xmi.id, the path is returned as normal.
 426
 427 e.g. given
 428
 429  <UML:ModelElement.stereotype>
 430      <UML:Stereotype xmi.idref = 'stTable'/>
 431  </UML:ModelElement.stereotype>
 432   ...
 433  <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
 434      isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
 435      <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 436  </UML:Stereotype>
 437
 438 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
 439 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
 440
 441 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
 442 "Table".
 443
 444 =head1 SEE ALSO
 445
 446 perl(1).
 447
 448 =head1 TODO
 449
 450 =head1 BUGS
 451
 452 =head1 VERSION HISTORY
 453
 454 =head1 AUTHOR
 455
 456 grommit <mark.addison@itn.co.uk>
 457
 458 =cut