[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / XML / XMI / SQLFairy.pm

package SQL::Translator::Parser::XML::XMI::SQLFairy;

# -------------------------------------------------------------------
# $Id: SQLFairy.pm,v 1.3 2003-10-14 23:19:43 grommit Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
#
# 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.3 $ =~ /(\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';

# 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;
    local $pargs  = $translator->parser_args;
    #local $schema = $translator->schema;
	$pargs->{classes2schema} = \&classes2schema;
    $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(@_);
}


# 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 {
    local $schema = shift;
	my $classes = shift;

    #
    # Create tablles from Classes and collect their associations
    #
    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;
        }

        # Add a pkey
        add_pkey($class,$table);
    }

    #
    # 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($assoc);
        }
        else
        {
            # m:n
            many2many($assoc);
            #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};

    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} 
        = _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]);
    $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;
}

# 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 ($assoc) = @_;
    my @ends = @{$assoc->{associationEnds}};
    my ($end1) = grep $_->{multiplicity}{rangeUpper} == 1, @ends;
    my $endm = $end1->{otherEnd};
    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 @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 $tablem->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 $schema->error;
}

# Maps m:n into schema by building a link table.
sub many2many
{
    my ($assoc) = @_;
    my @end = @{$assoc->{associationEnds}};

    # Create the link table
    my $name = $end[0]->{participant}{name}."_".$end[1]->{participant}{name};
    my $link_table = $schema->add_table( name => $name )
    or die "Schema Error: ".$schema->error;

    # Export the pkey(s) from the ends into the link table
    my @pkeys;
    foreach (@end) {
        my $table = $schema->get_table($_->{participant}{name});
        my @fkeys = $table->primary_key->fields;
        push @pkeys,@fkeys;
        foreach ( @fkeys ) {
            my $fld = $table->get_field($_);
            my %data;
            $data{$_} = $fld->$_()
                foreach (
                qw/name size data_type default_value is_nullable is_unique/);
            $data{is_auto_increment} = 0;
            $data{extra} = { $fld->extra }; # Copy
            $link_table->add_field(%data) or die $table->error;
        }
        $link_table->add_constraint(
            type   => "FOREIGN_KEY",
            fields => [@fkeys],
            reference_table => $table->{name},
            reference_fields => [@fkeys],
        ) or die $schema->error;

    }
    # Add pkey constraint
    $link_table->add_constraint( type => "PRIMARY KEY", fields => [@pkeys] )
    or die $link_table->error;


    # Add fkeys to our participants
}
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 of SQLFairy.

=head2 Tables

Classes, all of them! (TODO More control over which tables to do.)

=head2 Fields

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 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

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<auto_pkey> 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 <<PK>> 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 more than 1 e.g '*', '0..*', '1..*', '0..3', '4..42' etc.

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.

=head1 EXAMPLE

TODO An example to help make sense of the above! Probably based on the test.

=head1 ARGS

=head1 BUGS

=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 E<lt>mark.addison@itn.co.ukE<gt>.

=head1 SEE ALSO

perl(1), SQL::Translator::Parser::XML::XMI

=cut
Commit	Line	Data
55e462b4	1	package SQL::Translator::Parser::XML::XMI::SQLFairy;
	2
	3	# -------------------------------------------------------------------
ae15bb99	4	# $Id: SQLFairy.pm,v 1.3 2003-10-14 23:19:43 grommit Exp $
55e462b4	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::SQLFairy - Create Schema from UML Models.
	26
	27	=cut
	28
	29	use strict;
	30
	31	use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
ae15bb99	32	$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
55e462b4	33	$DEBUG = 0 unless defined $DEBUG;
	34	use Exporter;
	35	use base qw(Exporter);
	36	@EXPORT_OK = qw(parse);
	37
	38	use Data::Dumper;
	39	use SQL::Translator::Parser::XML::XMI;
	40	use SQL::Translator::Utils 'debug';
	41
f992cfaa	42	# Globals for the subs to use, set in parse() and classes2schema()
	43	#
	44	# TODO Should we be giving classes2schema the schema or should they use their
	45	# parse() to get it. Obj parsers maybe?
	46	#our ($schema,$pargs);
	47	use vars qw[ $schema $pargs ];
	48
55e462b4	49	# Set the parg for the conversion sub then use the XMI parser
	50	sub parse {
	51	my ( $translator ) = @_;
	52	local $DEBUG = $translator->debug;
f992cfaa	53	local $pargs = $translator->parser_args;
f992cfaa	54	#local $schema = $translator->schema;
55e462b4	55	$pargs->{classes2schema} = \&classes2schema;
f992cfaa	56	$pargs->{derive_pkey} \|\|= "stereotype,auto,first";
	57	$pargs->{auto_pkey} \|\|= {
	58	name => sub {
	59	my $class = shift;
	60	$class->{name}."ID";
	61	},
	62	data_type => "INT",
	63	size => 10,
	64	is_nullable => 0,
	65	is_auto_increment => 1,
	66	};
	67
	68	return SQL::Translator::Parser::XML::XMI::parse(@_);
55e462b4	69	}
	70
	71
	72
	73	# TODO We could make the tag names a parser arg so people can use their own.
	74	my %TAGS;
	75	$TAGS{data_type} = "sqlfDataType";
	76	$TAGS{size} = "sqlfSize";
	77	$TAGS{is_nullable} = "sqlfIsNullable";
	78	$TAGS{required} = "sqlfRequired";
	79	$TAGS{is_auto_increment} = "sqlfIsAutoIncrement";
	80	$TAGS{default_value} = "sqlfDefaultValue";
	81
	82	sub _parameters_in {
	83	my $params = shift;
	84	return grep {$_->{kind} ne "return"} @$params;
	85	}
	86
	87	sub _resolve_tag {
	88	my ($tag, $things) = @_;
	89	foreach (@$things) {
	90	return $_->{_map_taggedValues}{$tag}{dataValue}
	91	if exists $_->{_map_taggedValues}{$tag}{dataValue};
	92	}
	93	return;
	94	}
	95
	96
	97	sub classes2schema {
f992cfaa	98	local $schema = shift;
f992cfaa	99	my $classes = shift;
55e462b4	100
f992cfaa	101	#
	102	# Create tablles from Classes and collect their associations
	103	#
55e462b4	104	my %associations;
	105	foreach my $class (@$classes) {
	106	# Add the table
	107	debug "Adding class: $class->{name}";
	108	my $table = $schema->add_table( name => $class->{name} )
	109	or die "Schema Error: ".$schema->error;
	110
	111	# Only collect the associations for classes that are tables. Use a hash
	112	# so we only get them once
	113	$associations{$_->{"xmi.id"}} = $_
	114	foreach map $_->{association}, @{$class->{associationEnds}};
	115
	116	#
	117	# Fields from Class attributes
	118	#
	119	my @flds;
	120	push @flds, attr2field($_) for @{$class->{attributes}};
	121	# TODO Filter this e.g no abstract attr or stereotype check
	122	foreach (@flds) {
	123	my $extra = delete $_->{extra};
	124	my $field = $table->add_field( %$_ ) or die $schema->error;
	125	$field->extra(%$extra) if $extra;
	126	}
	127
f992cfaa	128	# Add a pkey
f992cfaa	129	add_pkey($class,$table);
55e462b4	130	}
	131
	132	#
	133	# Relationships from Associations
	134	#
	135	foreach my $assoc (values %associations) {
	136	my @end = @{$assoc->{associationEnds}};
	137	if (
f992cfaa	138	$end[0]->{multiplicity}{rangeUpper} == 1
f992cfaa	139	&& $end[1]->{multiplicity}{rangeUpper} == 1
55e462b4	140	) {
55e462b4	141	# 1:1 or 0:1
f992cfaa	142	warn "Sorry, 1:1 associations not yet implimented for xmi.id=".$assoc->{"xmi.id"}."\n";
55e462b4	143	}
55e462b4	144	elsif (
f992cfaa	145	$end[0]->{multiplicity}{rangeUpper} == 1
f992cfaa	146	\|\| $end[1]->{multiplicity}{rangeUpper} == 1
55e462b4	147	) {
55e462b4	148	# 1:m or 0:m
f992cfaa	149	one2many($assoc);
55e462b4	150	}
	151	else
	152	{
	153	# m:n
ae15bb99	154	many2many($assoc);
ae15bb99	155	#warn "Sorry, n:m associations not yet implimented for xmi.id=".$assoc->{"xmi.id"}."\n";
55e462b4	156	}
55e462b4	157
f992cfaa	158	}
55e462b4	159
	160	}
	161
f992cfaa	162	# Take an attribute and return the field data for it
55e462b4	163	sub attr2field {
	164	my $attr = shift;
	165	my $dataType = $attr->{dataType};
	166
	167	my %data = ( name => $attr->{name} );
	168
	169	$data{data_type}
	170	= _resolve_tag($TAGS{data_type},[$attr,$dataType])
	171	\|\| $dataType->{name};
	172
	173	$data{size} = _resolve_tag($TAGS{size},[$attr,$dataType]);
	174
	175	$data{default_value}
f992cfaa	176	= _resolve_tag($TAGS{default_value},[$attr,$dataType])
f992cfaa	177	\|\| $attr->{initialValue};
55e462b4	178
	179	my $is_nullable = _resolve_tag($TAGS{is_nullable},[$attr,$dataType]);
	180	my $required = _resolve_tag($TAGS{required},[$attr,$dataType]);
	181	$data{is_nullable}
	182	= defined $is_nullable ? $is_nullable
	183	: ( defined $required ? ($required ? 0 : 1) : undef);
	184
	185	$data{is_auto_increment}
	186	= $attr->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue}
	187	\|\| $dataType->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue}
	188	\|\| undef;
	189
	190	#
	191	# Extras
	192	#
	193	my %tagnames;
	194	foreach ( keys %{$attr->{_map_taggedValues}} ) {$tagnames{$_}++; }
	195	delete @tagnames{@TAGS{qw/data_type size default_value is_nullable required is_auto_increment/}}; # Remove the tags we have already done
	196	my %extra = map {
	197	my $val = $attr->{_map_taggedValues}{$_}{dataValue};
	198	s/^sqlf//;
	199	($_,$val);
	200	} keys %tagnames;
	201	$data{extra} = \%extra;
	202
	203	return \%data;
	204	}
	205
f992cfaa	206	# Add a pkey to a table for the class
	207	sub add_pkey {
	208	my ($class,$table) = @_;
	209
	210	my @pkeys;
	211	foreach ( split(",", $pargs->{derive_pkey}) ) {
	212	if ( $_ eq "stereotype" ) {
	213	@pkeys = map $_->{name},
	214	grep($_->{stereotype} eq "PK", @{$class->{attributes}});
	215	}
	216	elsif( $_ eq "first" ) {
	217	@pkeys = $class->{attributes}[0]{name} unless @pkeys;
	218	}
	219	elsif( $_ eq "auto" ) {
	220	if ( my %data = %{$pargs->{auto_pkey}} ) {
	221	$data{name} = $data{name}->($class,$table);
	222	my $field = $table->add_field(%data) or die $table->error;
	223	@pkeys = $field->name;
	224	}
	225	}
	226	last if @pkeys;
	227	}
	228
	229	$table->add_constraint(
	230	type => "PRIMARY KEY",
	231	fields => [@pkeys],
	232	) or die $table->error;
	233	}
	234
55e462b4	235	# Maps a 1:M association into the schema
ae15bb99	236	sub one2many
ae15bb99	237	{
f992cfaa	238	my ($assoc) = @_;
55e462b4	239	my @ends = @{$assoc->{associationEnds}};
	240	my ($end1) = grep $_->{multiplicity}{rangeUpper} == 1, @ends;
	241	my $endm = $end1->{otherEnd};
f992cfaa	242	my $table1 = $schema->get_table($end1->{participant}{name});
f992cfaa	243	my $tablem = $schema->get_table($endm->{participant}{name});
55e462b4	244
	245	#
	246	# Export 1end pkey to many end
f992cfaa	247	#
f992cfaa	248	my $con = $table1->primary_key;
55e462b4	249	my @flds = $con->fields;
	250	foreach (@flds) {
	251	my $fld = $table1->get_field($_);
	252	my %data;
	253	$data{$_} = $fld->$_()
f992cfaa	254	foreach (qw/name size data_type default_value is_nullable/);
55e462b4	255	$data{extra} = { $fld->extra }; # Copy extra hash
	256	$data{is_unique} = 0; # FKey on many join so not unique
	257	$data{is_nullable} = $end1->{multiplicity}{rangeLower} == 0 ? 1 : 0;
	258	# 0:m - allow nulluable on fkey
	259	# 1:m - dont allow nullable
	260
f992cfaa	261	$tablem->add_field(%data) or die $tablem->error;
55e462b4	262	# Export the pkey if full composite (ie identity) relationship
	263	$tablem->primary_key($_) if $end1->{aggregation} eq "composite";
	264	}
	265
	266	#
	267	# Add fkey constraint to many end
	268	#
	269	$tablem->add_constraint(
	270	type => "FOREIGN_KEY",
	271	fields => [@flds],
	272	reference_table => $table1->{name},
	273	reference_fields => [@flds],
f992cfaa	274	) or die $schema->error;
55e462b4	275	}
55e462b4	276
ae15bb99	277	# Maps m:n into schema by building a link table.
	278	sub many2many
	279	{
	280	my ($assoc) = @_;
	281	my @end = @{$assoc->{associationEnds}};
	282
	283	# Create the link table
	284	my $name = $end[0]->{participant}{name}."_".$end[1]->{participant}{name};
	285	my $link_table = $schema->add_table( name => $name )
	286	or die "Schema Error: ".$schema->error;
	287
	288	# Export the pkey(s) from the ends into the link table
	289	my @pkeys;
	290	foreach (@end) {
	291	my $table = $schema->get_table($_->{participant}{name});
	292	my @fkeys = $table->primary_key->fields;
	293	push @pkeys,@fkeys;
	294	foreach ( @fkeys ) {
	295	my $fld = $table->get_field($_);
	296	my %data;
	297	$data{$_} = $fld->$_()
	298	foreach (
	299	qw/name size data_type default_value is_nullable is_unique/);
	300	$data{is_auto_increment} = 0;
	301	$data{extra} = { $fld->extra }; # Copy
	302	$link_table->add_field(%data) or die $table->error;
	303	}
	304	$link_table->add_constraint(
	305	type => "FOREIGN_KEY",
	306	fields => [@fkeys],
	307	reference_table => $table->{name},
	308	reference_fields => [@fkeys],
	309	) or die $schema->error;
	310
	311	}
	312	# Add pkey constraint
	313	$link_table->add_constraint( type => "PRIMARY KEY", fields => [@pkeys] )
	314	or die $link_table->error;
	315
	316
	317	# Add fkeys to our participants
	318	}
55e462b4	319	1; #---------------------------------------------------------------------------
	320
	321	__END__
	322
	323	=pod
	324
	325	=head1 SYNOPSIS
	326
	327	use SQL::Translator;
	328	use SQL::Translator::Parser::XML::XMI;
	329
	330	my $translator = SQL::Translator->new(
	331	from => 'XML-XMI-SQLFairy',
	332	to => 'MySQL',
	333	filename => 'schema.xmi',
	334	);
	335
	336	print $obj->translate;
	337
	338	=head1 DESCRIPTION
	339
	340	Converts Class diagrams to Schema trying to use standard UML features as much
	341	as possible, with the minimum use of extension mechanisms (tagged values and
	342	stereotypes) for the database details. The idea is to treat the object model
	343	like a logical database model and map that to a physical model (the sql). Also
	344	tries to make this mapping as configurable as possible and support all the
f992cfaa	345	schema features of SQLFairy.
55e462b4	346
	347	=head2 Tables
	348
	349	Classes, all of them! (TODO More control over which tables to do.)
	350
	351	=head2 Fields
	352
f992cfaa	353	The attributes of the class will be converted to fields of the same name.
	354
	355	=head3 Datatypes
55e462b4	356
55e462b4	357	Database datatypes are modeled using tagged values; sqlfDataType,
f992cfaa	358	sqlfSize, sqlfIsNullable and sqlfIsAutoIncrement added to the attribute.
	359	The default value is the UML initial value of the attribute or can be overridden
	360	using a sqlfDefaultValue tagged value if you want to have a different default
	361	in the database then the object uses.
	362
	363	For more advanced datatype modeling you can use UML data types by adding the
	364	tagged values to the UML data types in your model and then giving your
	365	attributes those datatypes. Any tagged values set on attributes will override
	366	any they get from their datatype. This allows you to use UML datatypes like
	367	domains. If no sqlfDataType is given then the name of the UMLDataType is used.
55e462b4	368
	369	=head3 Primary Keys
	370
f992cfaa	371	If no attribute is marked explicity on the Class as a pkey then one is added.
	372	The default is an INT(10) auto number named after the class with ID on the end.
	373	For many cases this is enough as you don't normally need to model pkeys
	374	explicitly in your object models as its a database thing.
	375
	376	The pkey created can be controlled by setting the C<auto_pkey> parser arg to a
	377	hash ref describing the field. The name key is a sub that gets given a ref to
	378	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;
	379
	380	{
	381	name => sub {
	382	my $class = shift;
	383	$class->{name}."ID";
	384	},
	385	data_type => "INT",
	386	size => 10,
	387	is_nullable => 0,
	388	is_auto_increment => 1,
	389	}
	390
	391	NB You need to return a unique name for the key if it will be used to build
	392	relationships as it will be exported to other tables (see Relationships).
	393
	394	You can also set them explicitly by marking attributes with a <<PK>> stereotype.
	395	Add to multiple attribs to make multi column keys. Usefull when your object
	396	contains an attribute that makes a good candidate for a pkey, e.g. email.
55e462b4	397
	398	=head2 Relationships
	399
	400	Modeled using UML associations. Currently only handles 0:m and 1:m joins. That
	401	is associations where one ends multiplicty is '1' or '0..1' and the other end's
f992cfaa	402	multplicity is more than 1 e.g '', '0..', '1..*', '0..3', '4..42' etc.
55e462b4	403
f992cfaa	404	The pkey field from the 1 end is added to the table for the class at the many
f992cfaa	405	end as a foreign key with is_unique and auto number turned off.
55e462b4	406
	407	If the 1 end is multiplicity '0..1' (ie a 0:m join) then the the fkey is made
	408	nullable, if its multiplicity '1' (1:m) then its made not nullable.
	409
f992cfaa	410	If the association is a composition then the created fkey is made part of the
	411	many ends pkey. ie It exports the pkey to create an identity join.
	412
	413	=head1 EXAMPLE
	414
	415	TODO An example to help make sense of the above! Probably based on the test.
55e462b4	416
	417	=head1 ARGS
	418
	419	=head1 BUGS
	420
	421	=head1 TODO
	422
f992cfaa	423	1:1 and m:m joins.
	424
	425	Generalizations.
	426
	427	Support for the format_X_name subs in the Translator.
	428
	429	Lots more...
	430
55e462b4	431	=head1 AUTHOR
	432
	433	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
	434
	435	=head1 SEE ALSO
	436
	437	perl(1), SQL::Translator::Parser::XML::XMI
	438
	439	=cut