1 package SQL::Translator::Parser::XML::XMI;
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>,
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.
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.
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
21 # -------------------------------------------------------------------
25 SQL::Translator::Parser::XML::XMI - Parser to create Schema from UML
26 Class diagrams stored in XMI format.
31 use SQL::Translator::Parser::XML::XMI;
33 my $translator = SQL::Translator->new(
36 filename => 'schema.xmi',
41 print $obj->translate;
45 Currently pulls out all the Classes as tables.
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.
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
57 It should also parse XMI 1.0, such as you get from Rose, but this has had
66 visibilty=public|protected|private
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.
72 If not set or false (the default) no checks will be made and everything is
79 # -------------------------------------------------------------------
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;
89 use base qw(Exporter);
90 @EXPORT_OK = qw(parse);
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;
98 #-----------------------------------------------------------------------------
100 # is_visible - Used to check visibility in filter subs
109 my ($nodevis, $vis) = @_;
110 $nodevis = ref $_[0] ? $_[0]->{visibility} : $_[0];
111 return 1 unless $vis;
112 return 1 if $vislevel{$vis} >= $vislevel{$nodevis};
117 my ($schema, $pargs);
120 my ( $translator, $data ) = @_;
121 local $DEBUG = $translator->debug;
122 $schema = $translator->schema;
123 $pargs = $translator->parser_args;
125 debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
127 my $xmip = SQL::Translator::XMI::Parser->new(xml => $data);
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.
133 my $classes = $xmip->get_classes(
135 return unless $_->{name};
136 return unless is_visible($_, $pargs->{visibility});
139 filter_attributes => sub {
140 return unless $_->{name};
141 return unless is_visible($_, $pargs->{visibility});
146 debug "Found ".scalar(@$classes)." Classes: ".join(", ",
147 map {$_->{"name"}} @$classes) if $DEBUG;
148 debug "Classes:",Dumper($classes);
149 #print "Classes:",Dumper($classes),"\n";
152 # Turn the data from get_classes into a Schema
154 profile_default($classes);
160 sub profile_default {
163 foreach my $class (@$classes) {
165 debug "Adding class: $class->{name}" if $DEBUG;
166 my $table = $schema->add_table( name => $class->{name} )
167 or die "Schema Error: ".$schema->error;
170 # Fields from Class attributes
172 foreach my $attr ( @{$class->{attributes}} ) {
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,
179 $data{default_value} = $attr->{initialValue}
180 if exists $attr->{initialValue};
182 debug "Adding field:",Dumper(\%data);
183 my $field = $table->add_field( %data ) or die $schema->error;
185 $table->primary_key( $field->name ) if $data{'is_primary_key'};
188 # - We should be able to make the table obj spot this when
196 sub profile_rational {
199 foreach my $class (@$classes) {
200 next unless $class->{stereotype} eq "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;
208 # Fields from Class attributes
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";
217 $attr->{stereotype} eq "PK" or $attr->{stereotype} eq "PFK"
220 name => $attr->{name},
221 data_type => $attr->{datatype},
222 is_primary_key => $ispk,
224 $data{default_value} = $attr->{initialValue}
225 if exists $attr->{initialValue};
227 my $field = $table->add_field( %data ) or die $schema->error;
228 $table->primary_key( $field->name ) if $data{'is_primary_key'};
232 # Constraints and indexes from Operations
234 foreach my $op ( @{$class->{operations}} ) {
235 next unless my $stereo = $op->{stereotype};
236 my @fields = map {$_->{name}} @{$op->{parameters}};
243 # Work out type and any other data
244 if ( $stereo eq "Unique" ) {
245 $data{type} = "UNIQUE";
247 elsif ( $stereo eq "PK" ) {
248 $data{type} = "PRIMARY_KEY";
250 # TODO We need to work out the ref table
251 #elsif ( $stereo eq "FK" ) {
252 # $data{type} = "FOREIGN_KEY";
255 # Add the constraint or index
257 $table->add_constraint( %data ) or die $schema->error;
259 elsif ( $stereo eq "Index" ) {
260 $data{type} = "NORMAL";
261 $table->add_index( %data ) or die $schema->error;
270 1; #---------------------------------------------------------------------------
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
284 B<field sizes> Don't think UML does this directly so may need to include
285 it in the datatype names.
287 B<table_visibility and field_visibility args> Seperate control over what is
288 parsed, setting visibility arg will set both.
290 Everything else! Relations, fkeys, constraints, indexes, etc...
294 Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
298 perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
299 SQL::Translator::Schema.