From: Mark Addison Date: Mon, 13 Oct 2003 17:05:55 +0000 (+0000) Subject: PKeys automatically generated for Classes that don't set them explicitly with X-Git-Tag: v0.04~81 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f992cfaad5c4873d9eb3c504886351fb4bd3f87d;p=dbsrgits%2FSQL-Translator.git PKeys automatically generated for Classes that don't set them explicitly with <>. Re-wrote datatypes section in the docs. --- diff --git a/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm b/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm index db87f3f..6bf9c3b 100644 --- a/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm +++ b/lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm @@ -1,7 +1,7 @@ package SQL::Translator::Parser::XML::XMI::SQLFairy; # ------------------------------------------------------------------- -# $Id: SQLFairy.pm,v 1.1 2003-10-10 20:03:24 grommit Exp $ +# $Id: SQLFairy.pm,v 1.2 2003-10-13 17:05:55 grommit Exp $ # ------------------------------------------------------------------- # Copyright (C) 2003 Mark Addison , # @@ -29,7 +29,7 @@ SQL::Translator::Parser::XML::XMI::SQLFairy - Create Schema from UML Models. use strict; use vars qw[ $DEBUG $VERSION @EXPORT_OK ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/; +$VERSION = sprintf "%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/; $DEBUG = 0 unless defined $DEBUG; use Exporter; use base qw(Exporter); @@ -39,13 +39,33 @@ use Data::Dumper; use SQL::Translator::Parser::XML::XMI; use SQL::Translator::Utils 'debug'; +# Globals for the subs to use, set in parse() and classes2schema() +# +# TODO Should we be giving classes2schema the schema or should they use their +# parse() to get it. Obj parsers maybe? +#our ($schema,$pargs); +use vars qw[ $schema $pargs ]; + # 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; + local $pargs = $translator->parser_args; + #local $schema = $translator->schema; $pargs->{classes2schema} = \&classes2schema; - return SQL::Translator::Parser::XML::XMI::parse(@_); + $pargs->{derive_pkey} ||= "stereotype,auto,first"; + $pargs->{auto_pkey} ||= { + name => sub { + my $class = shift; + $class->{name}."ID"; + }, + data_type => "INT", + size => 10, + is_nullable => 0, + is_auto_increment => 1, + }; + + return SQL::Translator::Parser::XML::XMI::parse(@_); } @@ -75,8 +95,12 @@ sub _resolve_tag { sub classes2schema { - my ($schema, $classes) = @_; + local $schema = shift; + my $classes = shift; + # + # Create tablles from Classes and collect their associations + # my %associations; foreach my $class (@$classes) { # Add the table @@ -101,18 +125,8 @@ sub classes2schema { $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; + # Add a pkey + add_pkey($class,$table); } # @@ -121,29 +135,30 @@ sub classes2schema { foreach my $assoc (values %associations) { my @end = @{$assoc->{associationEnds}}; if ( - $end[0]->{multiplicity}{rangeUpper} == 1 - && $end[1]->{multiplicity}{rangeUpper} == 1 + $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"; + 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 + $end[0]->{multiplicity}{rangeUpper} == 1 + || $end[1]->{multiplicity}{rangeUpper} == 1 ) { # 1:m or 0:m - one2many($schema,$assoc); + one2many($assoc); } else { # m:n - warn "Sorry, n:m associations not yet implimented for xmi.id".$assoc->{"xmi.id"}."\n"; + warn "Sorry, n:m associations not yet implimented for xmi.id=".$assoc->{"xmi.id"}."\n"; } - } + } } +# Take an attribute and return the field data for it sub attr2field { my $attr = shift; my $dataType = $attr->{dataType}; @@ -157,8 +172,8 @@ sub attr2field { $data{size} = _resolve_tag($TAGS{size},[$attr,$dataType]); $data{default_value} - = $attr->{initialValue} - || _resolve_tag($TAGS{default_value},[$attr,$dataType]); + = _resolve_tag($TAGS{default_value},[$attr,$dataType]) + || $attr->{initialValue}; my $is_nullable = _resolve_tag($TAGS{is_nullable},[$attr,$dataType]); my $required = _resolve_tag($TAGS{required},[$attr,$dataType]); @@ -187,32 +202,61 @@ sub attr2field { return \%data; } +# Add a pkey to a table for the class +sub add_pkey { + my ($class,$table) = @_; + + my @pkeys; + foreach ( split(",", $pargs->{derive_pkey}) ) { + if ( $_ eq "stereotype" ) { + @pkeys = map $_->{name}, + grep($_->{stereotype} eq "PK", @{$class->{attributes}}); + } + elsif( $_ eq "first" ) { + @pkeys = $class->{attributes}[0]{name} unless @pkeys; + } + elsif( $_ eq "auto" ) { + if ( my %data = %{$pargs->{auto_pkey}} ) { + $data{name} = $data{name}->($class,$table); + my $field = $table->add_field(%data) or die $table->error; + @pkeys = $field->name; + } + } + last if @pkeys; + } + + $table->add_constraint( + type => "PRIMARY KEY", + fields => [@pkeys], + ) or die $table->error; +} + # Maps a 1:M association into the schema sub one2many { - my ($scma,$assoc) = @_; + my ($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}); + my $table1 = $schema->get_table($end1->{participant}{name}); + my $tablem = $schema->get_table($endm->{participant}{name}); # # Export 1end pkey to many end - # - my $con = $table1->primary_key; + # + 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/); + 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; + $tablem->add_field(%data) or die $tablem->error; # Export the pkey if full composite (ie identity) relationship $tablem->primary_key($_) if $end1->{aggregation} eq "composite"; } @@ -225,7 +269,7 @@ sub one2many { fields => [@flds], reference_table => $table1->{name}, reference_fields => [@flds], - ) or die $scma->error; + ) or die $schema->error; } 1; #--------------------------------------------------------------------------- @@ -254,7 +298,7 @@ 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. +schema features of SQLFairy. =head2 Tables @@ -262,34 +306,69 @@ Classes, all of them! (TODO More control over which tables to do.) =head2 Fields -=head3 Datatypes +The attributes of the class will be converted to fields of the same name. + +=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?. +sqlfSize, sqlfIsNullable and sqlfIsAutoIncrement added to the attribute. +The default value is the UML initial value of the attribute or can be overridden +using a sqlfDefaultValue tagged value if you want to have a different default +in the database then the object uses. + +For more advanced datatype modeling you can use UML data types by adding the +tagged values to the UML data types in your model and then giving your +attributes those datatypes. Any tagged values set on attributes will override +any they get from their datatype. This allows you to use UML datatypes like +domains. If no sqlfDataType is given then the name of the UMLDataType is used. =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. +If no attribute is marked explicity on the Class as a pkey then one is added. +The default is an INT(10) auto number named after the class with ID on the end. +For many cases this is enough as you don't normally need to model pkeys +explicitly in your object models as its a database thing. + +The pkey created can be controlled by setting the C parser arg to a +hash ref describing the field. The name key is a sub that gets given a ref to +the class (from the xmi) and the table it has been mapped to, and should return the pkey name. e.g. the defualt looks like; + + { + name => sub { + my $class = shift; + $class->{name}."ID"; + }, + data_type => "INT", + size => 10, + is_nullable => 0, + is_auto_increment => 1, + } + +NB You need to return a unique name for the key if it will be used to build +relationships as it will be exported to other tables (see Relationships). + +You can also set them explicitly by marking attributes with a <> stereotype. +Add to multiple attribs to make multi column keys. Usefull when your object +contains an attribute that makes a good candidate for a pkey, e.g. email. =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. +multplicity is more than 1 e.g '*', '0..*', '1..*', '0..3', '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. +The pkey field from the 1 end is added to the table for the class at the many +end as a foreign key with is_unique and auto number turned off. 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. +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 EXAMPLE + +TODO An example to help make sense of the above! Probably based on the test. =head1 ARGS @@ -297,6 +376,14 @@ many ends pkey. ie It exports the pkey to create an identity join. =head1 TODO +1:1 and m:m joins. + +Generalizations. + +Support for the format_X_name subs in the Translator. + +Lots more... + =head1 AUTHOR Mark D. Addison Emark.addison@itn.co.ukE. diff --git a/t/28xml-xmi-parser-sqlfairy.t b/t/28xml-xmi-parser-sqlfairy.t index 359f6a6..a3e2f21 100644 --- a/t/28xml-xmi-parser-sqlfairy.t +++ b/t/28xml-xmi-parser-sqlfairy.t @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl -w # vim:filetype=perl # Before `make install' is performed this script should be runnable with @@ -30,34 +30,34 @@ sub test_field { } 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}, + + 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}, + + 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( $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( $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( $f1->is_auto_increment, $test->{is_auto_increment}, " is ".($test->{is_auto_increment} ? '' : 'not').' an auto_increment' ) if exists $test->{is_auto_increment}; } @@ -72,33 +72,33 @@ sub constraint_ok { 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}; @@ -109,7 +109,7 @@ sub test_table { 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}} ], @@ -118,7 +118,7 @@ sub test_table { 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), @@ -133,7 +133,7 @@ sub test_table { # Testing 1,2,3,.. #============================================================================= -plan tests => 89; +plan tests => 94; my $testschema = "$Bin/data/xmi/OrderDB.sqlfairy.poseidon2.xmi"; die "Can't find test schema $testschema" unless -e $testschema; @@ -165,14 +165,6 @@ 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, @@ -188,11 +180,19 @@ test_table( $scma->get_table("Customer"), is_nullable => 1, is_primary_key => 0, }, + { + name => "CustomerID", + data_type => "INT", + size => 10, + default_value => undef, + is_nullable => 0, + is_primary_key => 1, + }, ], constraints => [ { type => "PRIMARY KEY", - fields => "customerID", + fields => "CustomerID", }, #{ # name => "UniqueEmail", @@ -206,24 +206,24 @@ test_table( $scma->get_table("Order"), name => "Order", fields => [ { - name => "orderDate", - data_type => "DATE", + name => "invoiceNumber", + data_type => "INT", + size => 10, default_value => undef, is_nullable => 0, - is_primary_key => 0, + is_primary_key => 1, }, { - name => "orderID", - data_type => "INT", - size => 10, + name => "orderDate", + data_type => "DATE", default_value => undef, is_nullable => 0, - is_primary_key => 1, + is_primary_key => 0, }, { - name => "customerID", + name => "CustomerID", data_type => "INT", - size => 20, + size => 10, default_value => undef, is_nullable => 0, is_primary_key => 0, @@ -233,13 +233,13 @@ test_table( $scma->get_table("Order"), constraints => [ { type => "PRIMARY KEY", - fields => "orderID", + fields => "invoiceNumber", }, { type => "FOREIGN KEY", - fields => "customerID", + fields => "CustomerID", reference_table => "Customer", - reference_fields => "customerID", + reference_fields => "CustomerID", }, ], # TODO @@ -262,7 +262,7 @@ test_table( $scma->get_table("OrderLine"), size => 255, default_value => 1, is_nullable => 0, - is_primary_key => 1, + is_primary_key => 0, }, { name => "quantity", @@ -273,25 +273,32 @@ test_table( $scma->get_table("OrderLine"), is_primary_key => 0, }, { - name => "orderID", + name => "OrderLineID", + data_type => "INT", + size => 10, + default_value => undef, + is_nullable => 0, + is_primary_key => 1, + }, + { + name => "invoiceNumber", data_type => "INT", size => 10, default_value => undef, is_nullable => 1, - is_primary_key => 0, - is_foreign_key => 1, + is_primary_key => 1, }, ], constraints => [ { type => "PRIMARY KEY", - fields => "lineNumber,orderID", + fields => "OrderLineID,invoiceNumber", }, { type => "FOREIGN KEY", - fields => "orderID", + fields => "invoiceNumber", reference_table => "Order", - reference_fields => "orderID", + reference_fields => "invoiceNumber", }, ], ); diff --git a/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi b/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi index acf3007..55ea6bf 100644 --- a/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi +++ b/t/data/xmi/OrderDB.sqlfairy.poseidon2.xmi @@ -1,5 +1,5 @@ - + Netbeans XMI Writer @@ -34,6 +34,15 @@ isSpecification = 'false' isRoot = 'false' isLeaf = 'false' isAbstract = 'false' isActive = 'false'> + + + + + + + + @@ -48,15 +57,6 @@ - - - - - - - - 0 - + @@ -106,26 +106,6 @@ - - - - 20 - - - - - - ZEROFILL - - - - - - - - - @@ -253,7 +233,7 @@ 0 - +