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

   1 package SQL::Translator::Parser::XML::XMI;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: XMI.pm,v 1.7 2003-09-17 16:27:21 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 Currently pulls out all the Classes as tables.
  46
  47 Any attributes of the class will be used as fields. The datatype of the
  48 attribute must be a UML datatype and not an object, with the datatype's name
  49 being used to set the data_type value in the schema.
  50
  51 =head2 XMI Format
  52
  53 The parser has been built using XMI 1.2 generated by PoseidonUML 2beta, which
  54 says it uses UML 2. So the current conformance is down to Poseidon's idea
  55 of XMI!
  56
  57 It should also parse XMI 1.0, such as you get from Rose, but this has had
  58 little testing!
  59
  60 =head1 ARGS
  61
  62 =over 4
  63
  64 =item visibility
  65
  66  visibilty=public|protected|private
  67
  68 What visibilty of stuff to translate. e.g when set to 'public' any private
  69 and package Classes will be ignored and not turned into tables. Applies
  70 to Classes and Attributes.
  71
  72 If not set or false (the default) no checks will be made and everything is
  73 translated.
  74
  75 =back
  76
  77 =cut
  78
  79 # -------------------------------------------------------------------
  80
  81 use strict;
  82
  83 use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
  84 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
  85 $DEBUG   = 0 unless defined $DEBUG;
  86
  87 use Data::Dumper;
  88 use Exporter;
  89 use base qw(Exporter);
  90 @EXPORT_OK = qw(parse);
  91
  92 use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
  93 use SQL::Translator::Utils 'debug';
  94 use SQL::Translator::XMI::Parser;
  95
  96
  97 # SQLFairy Parser
  98 #-----------------------------------------------------------------------------
  99
 100 # is_visible - Used to check visibility in filter subs
 101 {
 102     my %vislevel = (
 103         public => 1,
 104         protected => 2,
 105         private => 3,
 106     );
 107
 108     sub is_visible {
 109                 my ($nodevis, $vis) = @_;
 110         $nodevis = ref $_[0] ? $_[0]->{visibility} : $_[0];
 111         return 1 unless $vis;
 112         return 1 if $vislevel{$vis} >= $vislevel{$nodevis};
 113         return 0;
 114     }
 115 }
 116
 117 my ($schema, $pargs);
 118
 119 sub parse {
 120     my ( $translator, $data ) = @_;
 121     local $DEBUG  = $translator->debug;
 122     $schema    = $translator->schema;
 123     $pargs     = $translator->parser_args;
 124
 125     debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
 126
 127     my $xmip = SQL::Translator::XMI::Parser->new(xml => $data);
 128
 129     # TODO
 130     # - Options to set the initial context node so we don't just
 131     #   blindly do all the classes. e.g. Select a diag name to do.
 132
 133     my $classes = $xmip->get_classes(
 134         filter => sub {
 135             return unless $_->{name};
 136             return unless is_visible($_, $pargs->{visibility});
 137             return 1;
 138         },
 139         filter_attributes => sub {
 140             return unless $_->{name};
 141             return unless is_visible($_, $pargs->{visibility});
 142             return 1;
 143         },
 144     );
 145
 146     debug "Found ".scalar(@$classes)." Classes: ".join(", ",
 147         map {$_->{"name"}} @$classes) if $DEBUG;
 148     debug "Classes:",Dumper($classes);
 149     #print "Classes:",Dumper($classes),"\n";
 150
 151         #
 152         # Turn the data from get_classes into a Schema
 153         #
 154         profile_default($classes);
 155
 156
 157     return 1;
 158 }
 159
 160 sub profile_default {
 161         my ($classes) = @_;
 162
 163         foreach my $class (@$classes) {
 164         # Add the table
 165         debug "Adding class: $class->{name}" if $DEBUG;
 166         my $table = $schema->add_table( name => $class->{name} )
 167             or die "Schema Error: ".$schema->error;
 168
 169         #
 170         # Fields from Class attributes
 171         #
 172         foreach my $attr ( @{$class->{attributes}} ) {
 173                         my %data = (
 174                 name           => $attr->{name},
 175                 data_type      => $attr->{datatype},
 176                 is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
 177                 #is_foreign_key => $stereotype eq "FK" ? 1 : 0,
 178             );
 179                         $data{default_value} = $attr->{initialValue}
 180                                 if exists $attr->{initialValue};
 181
 182             debug "Adding field:",Dumper(\%data);
 183             my $field = $table->add_field( %data ) or die $schema->error;
 184
 185             $table->primary_key( $field->name ) if $data{'is_primary_key'};
 186             #
 187             # TODO:
 188             # - We should be able to make the table obj spot this when
 189             #   we use add_field.
 190             #
 191         }
 192
 193     } # Classes loop
 194 }
 195
 196 sub profile_rational {
 197         my ($classes) = @_;
 198
 199         foreach my $class (@$classes) {
 200         next unless $class->{stereotype} eq "Table";
 201
 202                 # Add the table
 203         debug "Adding class: $class->{name}" if $DEBUG;
 204         my $table = $schema->add_table( name => $class->{name} )
 205             or die "Schema Error: ".$schema->error;
 206
 207         #
 208         # Fields from Class attributes
 209         #
 210         foreach my $attr ( @{$class->{attributes}} ) {
 211                         next unless $attr->{stereotype} eq "Column"
 212                                 or $attr->{stereotype} eq "PK"
 213                                 or $attr->{stereotype} eq "FK"
 214                                 or $attr->{stereotype} eq "PFK";
 215
 216                         my $ispk =
 217                             $attr->{stereotype} eq "PK" or $attr->{stereotype} eq "PFK"
 218                                 ? 1 : 0;
 219                         my %data = (
 220                 name           => $attr->{name},
 221                 data_type      => $attr->{datatype},
 222                 is_primary_key => $ispk,
 223             );
 224                         $data{default_value} = $attr->{initialValue}
 225                                 if exists $attr->{initialValue};
 226
 227             my $field = $table->add_field( %data ) or die $schema->error;
 228             $table->primary_key( $field->name ) if $data{'is_primary_key'};
 229                 }
 230
 231                 #
 232                 # Constraints and indexes from Operations
 233                 #
 234         foreach my $op ( @{$class->{operations}} ) {
 235                         next unless my $stereo = $op->{stereotype};
 236                         my @fields = map {$_->{name}} @{$op->{parameters}};
 237                         my %data = (
 238                 name      => $op->{name},
 239                 type      => "",
 240                                 fields    => [@fields],
 241             );
 242
 243                         # Work out type and any other data
 244                         if ( $stereo eq "Unique" ) {
 245                                 $data{type} = "UNIQUE";
 246                         }
 247                         elsif ( $stereo eq "PK" ) {
 248                                 $data{type} = "PRIMARY_KEY";
 249                         }
 250                         # TODO We need to work out the ref table
 251                         #elsif ( $stereo eq "FK" ) {
 252                         #       $data{type} = "FOREIGN_KEY";
 253                         #}
 254
 255                         # Add the constraint or index
 256                         if ( $data{type} ) {
 257                                 $table->add_constraint( %data ) or die $schema->error;
 258                         }
 259                         elsif ( $stereo eq "Index" ) {
 260                 $data{type} = "NORMAL";
 261                                 $table->add_index( %data ) or die $schema->error;
 262                         }
 263
 264
 265                 } # Ops loop
 266
 267     } # Classes loop
 268 }
 269
 270 1; #---------------------------------------------------------------------------
 271
 272 __END__
 273
 274 =pod
 275
 276 =head1 BUGS
 277
 278 Seems to be slow. I think this is because the XMI files can get pretty
 279 big and complex, especially all the diagram info, and XPath needs to load the
 280 whole tree.
 281
 282 =head1 TODO
 283
 284 B<field sizes> Don't think UML does this directly so may need to include
 285 it in the datatype names.
 286
 287 B<table_visibility and field_visibility args> Seperate control over what is
 288 parsed, setting visibility arg will set both.
 289
 290 Everything else! Relations, fkeys, constraints, indexes, etc...
 291
 292 =head1 AUTHOR
 293
 294 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
 295
 296 =head1 SEE ALSO
 297
 298 perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
 299 SQL::Translator::Schema.
 300
 301 =cut
 302
 303