lib/SQL/Translator/Parser/XML/XMI.pm

   1 package SQL::Translator::Parser::XML::XMI;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: XMI.pm,v 1.4 2003-09-09 01:00:44 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 =head1 NAME
  24
  25 SQL::Translator::Parser::XML::XMI - Parser to create Schema from UML
  26 Class diagrams stored in XMI format.
  27
  28 =head1 SYNOPSIS
  29
  30   use SQL::Translator;
  31   use SQL::Translator::Parser::XML::XMI;
  32
  33   my $translator     = SQL::Translator->new(
  34       from           => 'XML-XMI',
  35       to             => 'MySQL',
  36       filename       => 'schema.xmi',
  37       show_warnings  => 1,
  38       add_drop_table => 1,
  39   );
  40
  41   print $obj->translate;
  42
  43 =head1 DESCRIPTION
  44
  45 =head2 UML Data Modeling
  46
  47 To tell the parser which Classes are tables give them a <<Table>> stereotype.
  48
  49 Any attributes of the class will be used as fields. The datatype of the
  50 attribute must be a UML datatype and not an object, with the datatype's name
  51 being used to set the data_type value in the schema.
  52
  53 Primary keys are attributes marked with <<PK>> stereotype.
  54
  55 =head2 XMI Format
  56
  57 The parser has been built using XMI generated by PoseidonUML 2beta, which
  58 says it uses UML 2. So the current conformance is down to Poseidon's idea
  59 of XMI!
  60
  61 =head1 ARGS
  62
  63 =over 4
  64
  65 =item visibility
  66
  67  visibilty=public|protected|private
  68
  69 What visibilty of stuff to translate. e.g when set to 'public' any private
  70 and package Classes will be ignored and not turned into tables. Applies
  71 to Classes and Attributes.
  72
  73 If not set or false (the default) no checks will be made and everything is
  74 translated.
  75
  76 =back
  77
  78 =cut
  79
  80 # -------------------------------------------------------------------
  81
  82 use strict;
  83
  84 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  85 $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
  86 $DEBUG   = 0 unless defined $DEBUG;
  87
  88 use Data::Dumper;
  89 use Exporter;
  90 use base qw(Exporter);
  91 @EXPORT_OK = qw(parse);
  92
  93 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
  94 use SQL::Translator::Utils 'debug';
  95 use XML::XPath;
  96 use XML::XPath::XMLParser;
  97
  98 # XMI XPath parsing
  99 #-----------------------------------------------------------------------------
 100
 101 #
 102 # get_classes( XPATHOBJ, ARGS );
 103 #
 104 # XPATHOBJ - An XML::XPath object setup and ready to use. You can also use any
 105 #            Node to search from as this sub just calls findnodes() on the arg.
 106 #
 107 # ARGS     - Name/Value list of args.
 108 #
 109 # xpath  =>  The xpath to use for finding classes. Default is //UML:Classes
 110 #            which will find all the classes in the XMI.
 111 #
 112 # test   =>  An XPath predicate (ie the bit between [] ) to test the
 113 #            classes with to decide if we should parse them. ie
 114 #            test => '@name' would only pass out classes with a name.
 115 #            Can also give it an array ref and it will and the tests.
 116 #            It gets tacked onto to xpath so don't put any [] on
 117 #            xpath if you use test as well.
 118 #
 119 # attribute_test => An XPath predicate to pass onto get_attributes.
 120 #
 121
 122 # _add_xpath_tests $path, [qw/@name xmiVisible("public")/]; # and
 123 # _add_xpath_tests $path, [qw/@name xmiVisible("public")/], "or";
 124 sub _add_xpath_tests {
 125     my ($path,$tests,$join) = @_;
 126         return $path unless defined $tests;
 127         my @tests = ref($tests) ? @$tests : $tests;
 128         return $path unless @tests;
 129     $join ||= "and";
 130     return $path."[".join(" $join ", @tests)."]";
 131 }
 132
 133 sub get_stereotype {
 134     my ($xp) = @_;
 135     return "".$xp->findvalue(
 136         'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');
 137     # TODO Test for difference between it existing or being "" ?
 138 }
 139
 140 sub get_classes {
 141         my ($xp,%args) = @_;
 142         my $classes;
 143
 144         my $xpath = $args{xpath} ||= '//UML:Class'; # Default: all classes
 145     $xpath = _add_xpath_tests $xpath, $args{test};
 146         debug "Searching for Classes using:$xpath";
 147
 148         my @nodes = $xp->findnodes($xpath);
 149         return unless @nodes;
 150
 151         for my $classnode (@nodes) {
 152         my $class = {};
 153
 154         foreach (
 155                         qw/name visibility isSpecification
 156                            isRoot isLeaf isAbstract isActive/
 157                 ) {
 158                         $class->{$_} = $classnode->getAttribute($_);
 159                 }
 160                 $class->{stereotype} = get_stereotype($classnode);
 161
 162                 # Class Attributes
 163                 my $xpath = 'UML:Classifier.feature/UML:Attribute';
 164         $class->{attributes} = get_attributes( $classnode,
 165             xpath => $xpath, test => $args{attribute_test} );
 166
 167                 push @$classes, $class;
 168         }
 169         return wantarray ? @$classes : $classes;
 170 };
 171
 172 sub get_attributes {
 173     my ($xp, %args) = @_;
 174
 175         my $xpath = $args{xpath} ||= '//UML:Classifier.feature/UML:Attribute';
 176     $xpath = _add_xpath_tests $xpath, $args{test};
 177         debug "Searching for Attributes using:$xpath";
 178
 179     my $attributes;
 180     foreach my $node ( $xp->findnodes($xpath) ) {
 181         my $attr = {};
 182
 183         foreach (qw/name visibility isSpecification ownerScope/) {
 184             $attr->{$_} = $node->getAttribute($_);
 185         }
 186         $attr->{stereotype} = get_stereotype($node);
 187
 188         # Get datatype name and the name body of the initial value
 189         $attr->{datatype} = "".$node->find(
 190               'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name');
 191         if ( my @body = $node->findnodes(
 192             'UML:Attribute.initialValue/UML:Expression/@body')
 193         ) {
 194             $attr->{initialValue} = $body[0]->getData;
 195         }
 196
 197         push @$attributes, $attr;
 198     }
 199     return wantarray ? @$attributes : $attributes;
 200 }
 201
 202
 203
 204 # SQLFairy Parser
 205 #-----------------------------------------------------------------------------
 206
 207 sub parse {
 208         eval {
 209
 210     my ( $translator, $data ) = @_;
 211     local $DEBUG    = $translator->debug;
 212     my $schema      = $translator->schema;
 213     my $pargs       = $translator->parser_args;
 214
 215     debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
 216
 217     my $xp = XML::XPath->new(xml => $data);
 218     $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
 219     #
 220     # TODO
 221     # - Options to set the initial context node so we don't just
 222     #   blindly do all the classes. e.g. Select a diag name to do.
 223
 224         #
 225     # Build an XPath for the classes and attributes we want...
 226         #
 227     # Only classes with an id (so we don't get any refs to classes ie
 228     # xmi.idref classes). They also need a name to be usefull.
 229     my @tests = ('@xmi.id and @name');
 230         push @tests, "xmiVisible('$pargs->{visibility}')" if $pargs->{visibility};
 231
 232         my $attrib_test = '@name and @xmi.id';
 233         $attrib_test .= " and xmiVisible('$pargs->{visibility}')"
 234             if $pargs->{visibility};
 235
 236         # ...and parse them out
 237         my $classes = get_classes( $xp,
 238                 xpath => "//UML:Class", test => [@tests], attribute_test => $attrib_test);
 239
 240     debug "Found ".scalar(@$classes)." Classes: ".join(", ",
 241         map {$_->{"name"}} @$classes) if $DEBUG;
 242         debug "Classes:",Dumper($classes);
 243
 244         #
 245         # Turn the data from get_classes into a Schema
 246         #
 247         foreach my $class (@$classes) {
 248         next unless $class->{stereotype} eq "Table";
 249
 250         # Add the table
 251         debug "Adding class: $class->{name}" if $DEBUG;
 252         my $table = $schema->add_table( name => $class->{name} )
 253             or die "Schema Error: ".$schema->error;
 254
 255         #
 256         # Fields from Class attributes
 257         #
 258         # name data_type size default_value is_nullable
 259         # is_auto_increment is_primary_key is_foreign_key comments
 260         #
 261         foreach my $attr ( @{$class->{attributes}} ) {
 262                         my %data = (
 263                 name           => $attr->{name},
 264                 data_type      => $attr->{datatype},
 265                 is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
 266                 #is_foreign_key => $stereotype eq "FK" ? 1 : 0,
 267             );
 268                         $data{default_value} = $attr->{initialValue}
 269                                 if exists $attr->{initialValue};
 270
 271             debug "Adding field:",Dumper(\%data);
 272             my $field = $table->add_field( %data ) or die $schema->error;
 273
 274             $table->primary_key( $field->name ) if $data{'is_primary_key'};
 275             #
 276             # TODO:
 277             # - We should be able to make the table obj spot this when
 278             #   we use add_field.
 279             #
 280         }
 281
 282     } # Classes loop
 283
 284     return 1;
 285
 286         };
 287         print "ERROR: $@\n" if $@;
 288         return 1;
 289 }
 290
 291 1;
 292
 293 #=============================================================================
 294 #
 295 # XML::XPath extensions
 296 #
 297 #=============================================================================
 298
 299 package XML::XPath::Function;
 300
 301 =head1 XMI XPath Functions
 302
 303 The Parser adds the following extra XPath functions.
 304
 305 =head2 xmiDeref
 306
 307 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
 308 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
 309 tag it points at has an xmi.idref it looks up the tag with that
 310 xmi.id and returns it.
 311
 312 If it doesn't have an xmi.id, the path is returned as normal.
 313
 314 e.g. given
 315
 316  <UML:ModelElement.stereotype>
 317      <UML:Stereotype xmi.idref = 'stTable'/>
 318  </UML:ModelElement.stereotype>
 319   ...
 320  <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
 321      isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
 322      <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 323  </UML:Stereotype>
 324
 325 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
 326 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
 327
 328 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
 329 "Table".
 330
 331 =head xmiVisible
 332
 333  is_visible( VISLEVEL )
 334
 335 Returns true or false for whether the visibility of something e.g. a Class or
 336 Attribute, is visible at the level given. e.g.
 337
 338  //UML:Class[xmiVisible('public')]       - Find all public classes
 339  //UML:Class[xmiVisible('protected')]    - Find all public and protected classes
 340
 341 Supports the 3 UML visibility levels of public, protected and private.
 342
 343 Note: Currently any element tested that doesn't have a visibility="" attribute
 344 is assumed to be visible and so xmiVisible will return true. This is probably
 345 the wrong thing to do and is very likley to change. It is probably best to
 346 throw an error if we try to test something that doesn't do visibility.
 347
 348 =cut
 349
 350 sub xmiDeref {
 351     my $self = shift;
 352     my ($node, @params) = @_;
 353     if (@params > 1) {
 354         die "xmiDeref() function takes one or no parameters\n";
 355     }
 356     elsif (@params) {
 357         my $nodeset = shift(@params);
 358         return $nodeset unless $nodeset->size;
 359         $node = $nodeset->get_node(1);
 360     }
 361     die "xmiDeref() needs an Element node."
 362     unless $node->isa("XML::XPath::Node::Element");
 363
 364     my $id = $node->getAttribute("xmi.idref") or return $node;
 365     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 366 }
 367
 368 {
 369     my %vislevel = (
 370         public => 1,
 371         protected => 2,
 372         private => 3,
 373     );
 374
 375     sub xmiVisible {
 376                 my $self = shift;
 377                 my ($node, @params) = @_;
 378                 if (@params < 1 or @params > 2) {
 379                         die "xmiVisible() function takes 1 or 2 parameters\n";
 380                 }
 381                 elsif (@params == 2) {
 382                         my $nodeset = shift(@params);
 383                         return unless $nodeset->size;
 384                         $node = $nodeset->get_node(1);
 385                 }
 386                 die "xmiVisible() needs an Element node."
 387                 unless $node->isa("XML::XPath::Node::Element");
 388
 389                 my $vis = shift(@params) || return XML::XPath::Boolean->True;
 390                 my $nodevis = $node->getAttribute("visibility")
 391                         || return XML::XPath::Boolean->True;
 392         return XML::XPath::Boolean->True
 393                         if $vislevel{$vis} >= $vislevel{$nodevis};
 394         return XML::XPath::Boolean->False;
 395     }
 396 }
 397
 398 # Test of custom xpath function.
 399 sub hello {
 400     return XML::XPath::Literal->new("Hello World");
 401 }
 402
 403 #=============================================================================
 404 package main;
 405
 406
 407 =pod
 408
 409 =head1 BUGS
 410
 411 Seems to be slow. I think this is because the XMI files can get pretty
 412 big and complex, especially all the diagram info.
 413
 414 =head1 TODO
 415
 416 B<field sizes> Don't think UML does this directly so may need to include
 417 it in the datatype names.
 418
 419 B<table_visibility and field_visibility args> Seperate control over what is
 420 parsed, setting visibility arg will set both.
 421
 422 Everything else! Relations, fkeys, constraints, indexes, etc...
 423
 424 =head1 AUTHOR
 425
 426 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 427
 428 =head1 SEE ALSO
 429
 430 perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
 431 SQL::Translator::Schema.
 432
 433 =cut
 434
 435