From: Mark Addison Date: Fri, 10 Oct 2003 20:03:24 +0000 (+0000) Subject: Initial code for SQLFairy UML profile for the XMI parser. The name may need X-Git-Tag: v0.04~82 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=55e462b4ab470d78fa3dd86dd6cec2241361daac;p=dbsrgits%2FSQL-Translator.git Initial code for SQLFairy UML profile for the XMI parser. The name may need changing but I wanted to get it in cvs so its safe and I can work on it and worry about the name later. --- diff --git a/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm b/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm new file mode 100644 index 0000000..db87f3f --- /dev/null +++ b/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm @@ -0,0 +1,308 @@ +package SQL::Translator::Parser::XML::XMI::SQLFairy; + +# ------------------------------------------------------------------- +# $Id: SQLFairy.pm,v 1.1 2003-10-10 20:03:24 grommit Exp $ +# ------------------------------------------------------------------- +# Copyright (C) 2003 Mark Addison , +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License as +# published by the Free Software Foundation; version 2. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +# 02111-1307 USA +# ------------------------------------------------------------------- + +=head1 NAME + +SQL::Translator::Parser::XML::XMI::SQLFairy - Create Schema from UML Models. + +=cut + +use strict; + +use vars qw[ $DEBUG $VERSION @EXPORT_OK ]; +$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +$DEBUG = 0 unless defined $DEBUG; +use Exporter; +use base qw(Exporter); +@EXPORT_OK = qw(parse); + +use Data::Dumper; +use SQL::Translator::Parser::XML::XMI; +use SQL::Translator::Utils 'debug'; + +# Set the parg for the conversion sub then use the XMI parser +sub parse { + my ( $translator ) = @_; + local $DEBUG = $translator->debug; + my $pargs = $translator->parser_args; + $pargs->{classes2schema} = \&classes2schema; + return SQL::Translator::Parser::XML::XMI::parse(@_); +} + + + +# TODO We could make the tag names a parser arg so people can use their own. +my %TAGS; +$TAGS{data_type} = "sqlfDataType"; +$TAGS{size} = "sqlfSize"; +$TAGS{is_nullable} = "sqlfIsNullable"; +$TAGS{required} = "sqlfRequired"; +$TAGS{is_auto_increment} = "sqlfIsAutoIncrement"; +$TAGS{default_value} = "sqlfDefaultValue"; + +sub _parameters_in { + my $params = shift; + return grep {$_->{kind} ne "return"} @$params; +} + +sub _resolve_tag { + my ($tag, $things) = @_; + foreach (@$things) { + return $_->{_map_taggedValues}{$tag}{dataValue} + if exists $_->{_map_taggedValues}{$tag}{dataValue}; + } + return; +} + + +sub classes2schema { + my ($schema, $classes) = @_; + + my %associations; + foreach my $class (@$classes) { + # Add the table + debug "Adding class: $class->{name}"; + my $table = $schema->add_table( name => $class->{name} ) + or die "Schema Error: ".$schema->error; + + # Only collect the associations for classes that are tables. Use a hash + # so we only get them once + $associations{$_->{"xmi.id"}} = $_ + foreach map $_->{association}, @{$class->{associationEnds}}; + + # + # Fields from Class attributes + # + my @flds; + push @flds, attr2field($_) for @{$class->{attributes}}; + # TODO Filter this e.g no abstract attr or stereotype check + foreach (@flds) { + my $extra = delete $_->{extra}; + my $field = $table->add_field( %$_ ) or die $schema->error; + $field->extra(%$extra) if $extra; + } + + # + # Primary key + # + my @pkeys; + @pkeys = map $_->{name}, + grep($_->{stereotype} eq "PK", @{$class->{attributes}}); + # if none set with steretype, use first attrib + @pkeys = $class->{attributes}[0]{name} unless @pkeys; + $table->add_constraint( + type => "PRIMARY KEY", + fields => [@pkeys], + ) or die $schema->error; + } + + # + # Relationships from Associations + # + foreach my $assoc (values %associations) { + my @end = @{$assoc->{associationEnds}}; + if ( + $end[0]->{multiplicity}{rangeUpper} == 1 + && $end[1]->{multiplicity}{rangeUpper} == 1 + ) { + # 1:1 or 0:1 + warn "Sorry, 1:1 associations not yet implimented for xmi.id".$assoc->{"xmi.id"}."\n"; + } + elsif ( + $end[0]->{multiplicity}{rangeUpper} == 1 + || $end[1]->{multiplicity}{rangeUpper} == 1 + ) { + # 1:m or 0:m + one2many($schema,$assoc); + } + else + { + # m:n + warn "Sorry, n:m associations not yet implimented for xmi.id".$assoc->{"xmi.id"}."\n"; + } + + } + +} + +sub attr2field { + my $attr = shift; + my $dataType = $attr->{dataType}; + + my %data = ( name => $attr->{name} ); + + $data{data_type} + = _resolve_tag($TAGS{data_type},[$attr,$dataType]) + || $dataType->{name}; + + $data{size} = _resolve_tag($TAGS{size},[$attr,$dataType]); + + $data{default_value} + = $attr->{initialValue} + || _resolve_tag($TAGS{default_value},[$attr,$dataType]); + + my $is_nullable = _resolve_tag($TAGS{is_nullable},[$attr,$dataType]); + my $required = _resolve_tag($TAGS{required},[$attr,$dataType]); + $data{is_nullable} + = defined $is_nullable ? $is_nullable + : ( defined $required ? ($required ? 0 : 1) : undef); + + $data{is_auto_increment} + = $attr->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue} + || $dataType->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue} + || undef; + + # + # Extras + # + my %tagnames; + foreach ( keys %{$attr->{_map_taggedValues}} ) {$tagnames{$_}++; } + delete @tagnames{@TAGS{qw/data_type size default_value is_nullable required is_auto_increment/}}; # Remove the tags we have already done + my %extra = map { + my $val = $attr->{_map_taggedValues}{$_}{dataValue}; + s/^sqlf//; + ($_,$val); + } keys %tagnames; + $data{extra} = \%extra; + + return \%data; +} + +# Maps a 1:M association into the schema +sub one2many { + my ($scma,$assoc) = @_; + my @ends = @{$assoc->{associationEnds}}; + my ($end1) = grep $_->{multiplicity}{rangeUpper} == 1, @ends; + my $endm = $end1->{otherEnd}; + my $table1 = $scma->get_table($end1->{participant}{name}); + my $tablem = $scma->get_table($endm->{participant}{name}); + + # + # Export 1end pkey to many end + # + my $con = $table1->primary_key; + my @flds = $con->fields; + foreach (@flds) { + my $fld = $table1->get_field($_); + my %data; + $data{$_} = $fld->$_() + foreach (qw/name size data_type default_value is_nullable/); + $data{extra} = { $fld->extra }; # Copy extra hash + $data{is_unique} = 0; # FKey on many join so not unique + $data{is_nullable} = $end1->{multiplicity}{rangeLower} == 0 ? 1 : 0; + # 0:m - allow nulluable on fkey + # 1:m - dont allow nullable + + $tablem->add_field(%data) or die $scma->error; + # Export the pkey if full composite (ie identity) relationship + $tablem->primary_key($_) if $end1->{aggregation} eq "composite"; + } + + # + # Add fkey constraint to many end + # + $tablem->add_constraint( + type => "FOREIGN_KEY", + fields => [@flds], + reference_table => $table1->{name}, + reference_fields => [@flds], + ) or die $scma->error; +} + +1; #--------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 SYNOPSIS + + use SQL::Translator; + use SQL::Translator::Parser::XML::XMI; + + my $translator = SQL::Translator->new( + from => 'XML-XMI-SQLFairy', + to => 'MySQL', + filename => 'schema.xmi', + ); + + print $obj->translate; + +=head1 DESCRIPTION + +Converts Class diagrams to Schema trying to use standard UML features as much +as possible, with the minimum use of extension mechanisms (tagged values and +stereotypes) for the database details. The idea is to treat the object model +like a logical database model and map that to a physical model (the sql). Also +tries to make this mapping as configurable as possible and support all the +schema features that SQLFairy does. + +=head2 Tables + +Classes, all of them! (TODO More control over which tables to do.) + +=head2 Fields + +=head3 Datatypes + +Database datatypes are modeled using tagged values; sqlfDataType, +sqlfSize, sqlfIsNullable and sqlfIsAutoIncrement. These can be added either +to the UML datatype or directly on the attribute where they override the value +from the datatype. If no sqlfDataType is given then the name of the UMLDataType +is used. If no default value is found then the UML initialValue is used (even +if a tag is set on the UMLDataType - do we want to do it this way?. + +=head3 Primary Keys + +Primary keys are attributes marked with <>. Add to multiple attribs to make +multi column keys. If none are marked will use the 1st attribute. + +=head2 Relationships + +Modeled using UML associations. Currently only handles 0:m and 1:m joins. That +is associations where one ends multiplicty is '1' or '0..1' and the other end's +multplicity is '0..*' or '1..*' or >1 (e.g '0..3' '1..23' '4..42') etc. + +The pkey from the 1 end is added to the table for the class at the many end as +a foreign key. is_unique is forced to false for the new field. + +If the 1 end is multiplicity '0..1' (ie a 0:m join) then the the fkey is made +nullable, if its multiplicity '1' (1:m) then its made not nullable. + +If the association is a composition then the created fkey is made part of the +many ends pkey. ie It exports the pkey to create an identity join. + +=head1 ARGS + +=head1 BUGS + +=head1 TODO + +=head1 AUTHOR + +Mark D. Addison Emark.addison@itn.co.ukE. + +=head1 SEE ALSO + +perl(1), SQL::Translator::Parser::XML::XMI + +=cut diff --git a/t/28xml-xmi-parser-sqlfairy.t b/t/28xml-xmi-parser-sqlfairy.t new file mode 100644 index 0000000..359f6a6 --- /dev/null +++ b/t/28xml-xmi-parser-sqlfairy.t @@ -0,0 +1,297 @@ +#!/usr/bin/perl -w +# vim:filetype=perl + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +use strict; +use FindBin qw/$Bin/; +use Data::Dumper; + +# run with -d for debug +my %opt; +BEGIN { map { $opt{$_}=1 if s/^-// } @ARGV; } +use constant DEBUG => (exists $opt{d} ? 1 : 0); + +use Test::More; +use Test::Exception; +use SQL::Translator; +use SQL::Translator::Schema::Constants; + +# Usefull test subs for the schema objs +#============================================================================= + +sub test_field { + my ($f1,$test) = @_; + unless ($f1) { + fail " Field '$test->{name}' doesn't exist!"; + # TODO Do a skip on the following tests + return; + } + + is( $f1->name, $test->{name}, " Field name '$test->{name}'" ); + + is( $f1->data_type, $test->{data_type}, " Type is '$test->{data_type}'" ) + if exists $test->{data_type}; + + is( $f1->size, $test->{size}, " Size is '$test->{size}'" ) + if exists $test->{size}; + + is( $f1->default_value, $test->{default_value}, + " Default value is ".(defined($test->{default_value}) ? "'$test->{default_value}'" : "UNDEF" ) ) + if exists $test->{default_value}; + + is( $f1->is_nullable, $test->{is_nullable}, + " ".($test->{is_nullable} ? 'can' : 'cannot').' be null' ) + if exists $test->{is_nullable}; + + is( $f1->is_unique, $test->{is_unique}, + " ".($test->{is_unique} ? 'can' : 'cannot').' be unique' ) + if exists $test->{is_unique}; + + is( $f1->is_primary_key, $test->{is_primary_key}, + " is ".($test->{is_primary_key} ? '' : 'not').' a primary_key' ) + if exists $test->{is_primary_key}; + + is( $f1->is_foreign_key, $test->{is_foreign_key}, + " is ".($test->{is_foreign_key} ? '' : 'not').' a foreign_key' ) + if exists $test->{is_foreign_key}; + + is( $f1->is_auto_increment, $test->{is_auto_increment}, + " is ".($test->{is_auto_increment} ? '' : 'not').' an auto_increment' ) + if exists $test->{is_auto_increment}; +} + +sub constraint_ok { + my ($con,$test) = @_; + #$test->{name} ||= ""; + + if ( exists $test->{name} ) { + is( $con->name, $test->{name}, " Constraint '$test->{name}'" ); + } + else { + ok( $con, " Constraint" ); + } + + is( $con->type, $test->{type}, " type is '$test->{type}'" ) + if exists $test->{type}; + + is( $con->table->name, $test->{table}, " table is '$test->{table}'" ) + if exists $test->{table}; + + is( join(",",$con->fields), $test->{fields}, + " fields is '$test->{fields}'" ) + if exists $test->{fields}; + + is( $con->reference_table, $test->{reference_table}, + " reference_table is '$test->{reference_table}'" ) + if exists $test->{reference_table}; + + is( join(",",$con->reference_fields), $test->{reference_fields}, + " reference_fields is '$test->{reference_fields}'" ) + if exists $test->{reference_fields}; + + is( $con->match_type, $test->{match_type}, + " match_type is '$test->{match_type}'" ) + if exists $test->{match_type}; + + is( $con->on_delete_do, $test->{on_delete_do}, + " on_delete_do is '$test->{on_delete_do}'" ) + if exists $test->{on_delete_do}; + + is( $con->on_update_do, $test->{on_update_do}, + " on_update_do is '$test->{on_update_do}'" ) + if exists $test->{on_update_do}; +} + +sub test_table { + my $tbl = shift; + my %arg = @_; + $arg{constraints} ||= []; + my $name = $arg{name} || die "Need a table name to test."; + + my @fldnames = map { $_->{name} } @{$arg{fields}}; + is_deeply( [ map {$_->name} $tbl->get_fields ], + [ map {$_->{name}} @{$arg{fields}} ], + "Table $name\'s fields" ); + foreach ( @{$arg{fields}} ) { + my $name = $_->{name} || die "Need a field name to test."; + test_field( $tbl->get_field($name), $_ ); + } + + if ( my @tcons = @{$arg{constraints}} ) { + my @cons = $tbl->get_constraints; + is(scalar(@cons), scalar(@tcons), + "Table $name has ".scalar(@tcons)." Constraints"); + foreach ( @cons ) { + my $ans = { table => $tbl->name, %{shift @tcons}}; + constraint_ok( $_, $ans ); + } + } +} + +# Testing 1,2,3,.. +#============================================================================= + +plan tests => 89; + +my $testschema = "$Bin/data/xmi/OrderDB.sqlfairy.poseidon2.xmi"; +die "Can't find test schema $testschema" unless -e $testschema; + +my $obj; +$obj = SQL::Translator->new( + filename => $testschema, + from => 'XML-XMI-SQLFairy', + to => 'MySQL', + debug => DEBUG, + show_warnings => 1, +); +my $sql = $obj->translate; +ok( $sql, "Got some SQL"); +print $sql if DEBUG; + + +# +# Test the schema +# +my $scma = $obj->schema; +is( $scma->is_valid, 1, 'Schema is valid' ); +my @tblnames = map {$_->name} $scma->get_tables; +is(scalar(@{$scma->get_tables}), scalar(@tblnames), "Right number of tables"); +is_deeply( \@tblnames, [qw/Order OrderLine Customer/] + ,"tables"); + +test_table( $scma->get_table("Customer"), + name => "Customer", + fields => [ + { + name => "customerID", + data_type => "INT", + size => 20, + default_value => undef, + is_nullable => 0, + is_primary_key => 1, + }, + { + name => "name", + data_type => "VARCHAR", + size => 255, + default_value => undef, + is_nullable => 0, + is_primary_key => 0, + }, + { + name => "email", + data_type => "VARCHAR", + size => 255, + default_value => undef, + is_nullable => 1, + is_primary_key => 0, + }, + ], + constraints => [ + { + type => "PRIMARY KEY", + fields => "customerID", + }, + #{ + # name => "UniqueEmail", + # type => "UNIQUE", + # fields => "email", + #}, + ], +); + +test_table( $scma->get_table("Order"), + name => "Order", + fields => [ + { + name => "orderDate", + data_type => "DATE", + default_value => undef, + is_nullable => 0, + is_primary_key => 0, + }, + { + name => "orderID", + data_type => "INT", + size => 10, + default_value => undef, + is_nullable => 0, + is_primary_key => 1, + }, + { + name => "customerID", + data_type => "INT", + size => 20, + default_value => undef, + is_nullable => 0, + is_primary_key => 0, + is_foreign_key => 1, + }, + ], + constraints => [ + { + type => "PRIMARY KEY", + fields => "orderID", + }, + { + type => "FOREIGN KEY", + fields => "customerID", + reference_table => "Customer", + reference_fields => "customerID", + }, + ], + # TODO + #indexes => [ + # { + # name => "idxOrderDate", + # type => "INDEX", + # fields => "orderDate", + # }, + #], +); + + +test_table( $scma->get_table("OrderLine"), + name => "OrderLine", + fields => [ + { + name => "lineNumber", + data_type => "INT", + size => 255, + default_value => 1, + is_nullable => 0, + is_primary_key => 1, + }, + { + name => "quantity", + data_type => "INT", + size => 255, + default_value => 1, + is_nullable => 0, + is_primary_key => 0, + }, + { + name => "orderID", + data_type => "INT", + size => 10, + default_value => undef, + is_nullable => 1, + is_primary_key => 0, + is_foreign_key => 1, + }, + ], + constraints => [ + { + type => "PRIMARY KEY", + fields => "lineNumber,orderID", + }, + { + type => "FOREIGN KEY", + fields => "orderID", + reference_table => "Order", + reference_fields => "orderID", + }, + ], +); diff --git a/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi b/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi new file mode 100644 index 0000000..acf3007 --- /dev/null +++ b/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi @@ -0,0 +1,452 @@ + + + + + Netbeans XMI Writer + 1.0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + + + + + + + + + + + + + + + + + + 1 + + + + + + + + + + + + + + + + 0 + + + + + + + + + + + + + + + + + + + + 20 + + + + + + ZEROFILL + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + VARCHAR + + + + + + 255 + + + + + + 1 + + + + + + + + + + INT + + + + + + 10 + + + + + + 1 + + + + + + 0 + + + + + + + + + + DATE + + + + + + + + + + INT + + + + + + 255 + + + + + + + + ModelElement + + + + + + + + + + + + + + + + + + + VARCHAR + + + + + + 255 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +