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

   1 package SQL::Translator::Parser::XML::XMI;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: XMI.pm,v 1.3 2003-09-08 17:10:07 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.3 $ =~ /(\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 #
  99 # get_classes( XPATHOBJ, ARGS );
 100 #
 101 # XPATHOBJ - An XML::XPath object setup and ready to use. You can also use any
 102 #            Node to search from as this sub just calls findnodes() on the arg.
 103 #
 104 # ARGS     - Name/Value list of args.
 105 #
 106 # xpath  =>  The xpath to use for finding classes. Default is //UML:Classes
 107 #            which will find all the classes in the XMI.
 108 #
 109 # attribute_test => An XPath predicate (ie the bit between [] ) to test the
 110 #            attributes with to decide if we should parse them. ie
 111 #            attribute_test => '@name="foo"' would only pass out attribs
 112 #            with a name of foo.
 113 #
 114 sub get_classes {
 115         my ($xp,%args) = @_;
 116         my $classes = [];
 117
 118         my $xpath = $args{xpath} ||= '//UML:Class'; # Default: all classes
 119         $xpath .= "[$args{class_test}]" if $args{class_test};
 120
 121         my @nodes = $xp->findnodes($xpath);
 122         return unless @nodes;
 123
 124         for my $classnode (@nodes) {
 125         my $class = {};
 126
 127                 # <UML:Class> attributes
 128                 foreach (
 129                         qw/name visibility isSpecification
 130                            isRoot isLeaf isAbstract isActive/
 131                 ) {
 132                         $class->{$_} = $classnode->getAttribute($_);
 133                 }
 134
 135                 # Stereotype
 136                 $class->{stereotype} = "".$classnode->find(
 137             'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');
 138
 139                 #
 140                 # Class Attributes
 141                 #
 142                 my $xpath = 'UML:Classifier.feature/UML:Attribute';
 143                 $xpath .= "[$args{attribute_test}]" if $args{attribute_test};
 144                 foreach my $attrnode ( $classnode->findnodes($xpath) ) {
 145                         my $attr = {};
 146                         # <UML:Attributes> attributes
 147                         foreach (qw/name visibility isSpecification ownerScope/) {
 148                                 $attr->{$_} = $attrnode->getAttribute($_);
 149                         }
 150
 151                         $attr->{stereotype} = "".$attrnode->findvalue(
 152                 'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');
 153
 154                         $attr->{datatype} = "".$attrnode->find(
 155                   'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name');
 156             if ( my @body = $attrnode->findnodes(
 157                 'UML:Attribute.initialValue/UML:Expression/@body')
 158             ) {
 159                 $attr->{initialValue} = $body[0]->getData;
 160             }
 161
 162                         push @{$class->{attributes}}, $attr;
 163                 }
 164
 165                 push @$classes, $class;
 166         }
 167
 168         return $classes;
 169 };
 170
 171 sub parse {
 172         eval {
 173
 174     my ( $translator, $data ) = @_;
 175     local $DEBUG    = $translator->debug;
 176     my $schema      = $translator->schema;
 177     my $pargs       = $translator->parser_args;
 178
 179     debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
 180
 181     my $xp = XML::XPath->new(xml => $data);
 182     $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
 183     #
 184     # TODO
 185     # - Options to set the initial context node so we don't just
 186     #   blindly do all the classes. e.g. Select a diag name to do.
 187
 188         #
 189     # Build an XPath for the classes and attributes we want...
 190         #
 191     my @tests = ('@xmi.id'); # Only classes with an id so we don't get any
 192                                  #     refs to classes ie xmi.idref classes
 193         push @tests, '@name';    # Only Classes with a name
 194         push @tests, "xmiVisible('$pargs->{visibility}')" if $pargs->{visibility};
 195         my $path = '//UML:Class['.join(' and ',@tests).']';
 196
 197         my $attrib_test = '@name';
 198         $attrib_test .= " and xmiVisible('$pargs->{visibility}')"
 199             if $pargs->{visibility};
 200
 201         # ...and parse them out
 202         debug "Searching for Classes using:$path";
 203         my $classes = get_classes( $xp,
 204                 xpath => $path, attribute_test => $attrib_test);
 205
 206     debug "Found ".scalar(@$classes)." Classes: ".join(", ",
 207         map {$_->{"name"}} @$classes) if $DEBUG;
 208         debug "Classes:",Dumper($classes);
 209
 210         #
 211         # Turn the data from get_classes into a Schema
 212         #
 213         foreach my $class (@$classes) {
 214         next unless $class->{stereotype} eq "Table";
 215
 216         # Add the table
 217         debug "Adding class: $class->{name}" if $DEBUG;
 218         my $table = $schema->add_table( name => $class->{name} )
 219             or die "Schema Error: ".$schema->error;
 220
 221         #
 222         # Fields from Class attributes
 223         #
 224         # name data_type size default_value is_nullable
 225         # is_auto_increment is_primary_key is_foreign_key comments
 226         #
 227         foreach my $attr ( @{$class->{attributes}} ) {
 228                         my %data = (
 229                 name           => $attr->{name},
 230                 data_type      => $attr->{datatype},
 231                 is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
 232                 #is_foreign_key => $stereotype eq "FK" ? 1 : 0,
 233             );
 234                         $data{default_value} = $attr->{initialValue}
 235                                 if exists $attr->{initialValue};
 236
 237             debug "Adding field:",Dumper(\%data);
 238             my $field = $table->add_field( %data ) or die $schema->error;
 239
 240             $table->primary_key( $field->name ) if $data{'is_primary_key'};
 241             #
 242             # TODO:
 243             # - We should be able to make the table obj spot this when
 244             #   we use add_field.
 245             #
 246         }
 247
 248     } # Classes loop
 249
 250     return 1;
 251
 252         };
 253         print "ERROR: $@\n" if $@;
 254         return 1;
 255 }
 256
 257 1;
 258
 259 #=============================================================================
 260 #
 261 # XML::XPath extensions
 262 #
 263 #=============================================================================
 264
 265 package XML::XPath::Function;
 266
 267 =head1 XMI XPath Functions
 268
 269 The Parser adds the following extra XPath functions.
 270
 271 =head2 xmiDeref
 272
 273 Deals with xmi.id/xmi.idref pairs of attributes. You give it an
 274 xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
 275 tag it points at has an xmi.idref it looks up the tag with that
 276 xmi.id and returns it.
 277
 278 If it doesn't have an xmi.id, the path is returned as normal.
 279
 280 e.g. given
 281
 282  <UML:ModelElement.stereotype>
 283      <UML:Stereotype xmi.idref = 'stTable'/>
 284  </UML:ModelElement.stereotype>
 285   ...
 286  <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
 287      isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
 288      <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 289  </UML:Stereotype>
 290
 291 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
 292 <UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.
 293
 294 Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
 295 "Table".
 296
 297 =head xmiVisible
 298
 299  is_visible( VISLEVEL )
 300
 301 Returns true or false for whether the visibility of something e.g. a Class or
 302 Attribute, is visible at the level given. e.g.
 303
 304  //UML:Class[xmiVisible('public')]       - Find all public classes
 305  //UML:Class[xmiVisible('protected')]    - Find all public and protected classes
 306
 307 Supports the 3 UML visibility levels of public, protected and private.
 308
 309 Note: Currently any element tested that doesn't have a visibility="" attribute
 310 is assumed to be visible and so xmiVisible will return true. This is probably
 311 the wrong thing to do and is very likley to change. It is probably best to
 312 throw an error if we try to test something that doesn't do visibility.
 313
 314 =cut
 315
 316 sub xmiDeref {
 317     my $self = shift;
 318     my ($node, @params) = @_;
 319     if (@params > 1) {
 320         die "xmiDeref() function takes one or no parameters\n";
 321     }
 322     elsif (@params) {
 323         my $nodeset = shift(@params);
 324         return $nodeset unless $nodeset->size;
 325         $node = $nodeset->get_node(1);
 326     }
 327     die "xmiDeref() needs an Element node."
 328     unless $node->isa("XML::XPath::Node::Element");
 329
 330     my $id = $node->getAttribute("xmi.idref") or return $node;
 331     return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
 332 }
 333
 334 {
 335     my %vislevel = (
 336         public => 1,
 337         protected => 2,
 338         private => 3,
 339     );
 340
 341     sub xmiVisible {
 342                 my $self = shift;
 343                 my ($node, @params) = @_;
 344                 if (@params < 1 or @params > 2) {
 345                         die "xmiVisible() function takes 1 or 2 parameters\n";
 346                 }
 347                 elsif (@params == 2) {
 348                         my $nodeset = shift(@params);
 349                         return unless $nodeset->size;
 350                         $node = $nodeset->get_node(1);
 351                 }
 352                 die "xmiVisible() needs an Element node."
 353                 unless $node->isa("XML::XPath::Node::Element");
 354
 355                 my $vis = shift(@params) || return XML::XPath::Boolean->True;
 356                 my $nodevis = $node->getAttribute("visibility")
 357                         || return XML::XPath::Boolean->True;
 358         return XML::XPath::Boolean->True
 359                         if $vislevel{$vis} >= $vislevel{$nodevis};
 360         return XML::XPath::Boolean->False;
 361     }
 362 }
 363
 364 # Test of custom xpath function.
 365 sub hello {
 366     return XML::XPath::Literal->new("Hello World");
 367 }
 368
 369 #=============================================================================
 370 package main;
 371
 372
 373 =pod
 374
 375 =head1 BUGS
 376
 377 Seems to be slow. I think this is because the XMI files can get pretty
 378 big and complex, especially all the diagram info.
 379
 380 =head1 TODO
 381
 382 B<field sizes> Don't think UML does this directly so may need to include
 383 it in the datatype names.
 384
 385 B<table_visibility and field_visibility args> Seperate control over what is
 386 parsed, setting visibility arg will set both.
 387
 388 Everything else! Relations, fkeys, constraints, indexes, etc...
 389
 390 =head1 AUTHOR
 391
 392 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 393
 394 =head1 SEE ALSO
 395
 396 perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
 397 SQL::Translator::Schema.
 398
 399 =cut
 400
 401