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

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 <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.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 <<PK>>. 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 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	# -------------------------------------------------------------------
	4	# $Id: SQLFairy.pm,v 1.1 2003-10-10 20:03:24 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::SQLFairy - Create Schema from UML Models.
	26
	27	=cut
	28
	29	use strict;
	30
	31	use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
	32	$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
	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
	42	# Set the parg for the conversion sub then use the XMI parser
	43	sub parse {
	44	my ( $translator ) = @_;
	45	local $DEBUG = $translator->debug;
	46	my $pargs = $translator->parser_args;
	47	$pargs->{classes2schema} = \&classes2schema;
	48	return SQL::Translator::Parser::XML::XMI::parse(@_);
	49	}
	50
	51
	52
	53	# TODO We could make the tag names a parser arg so people can use their own.
	54	my %TAGS;
	55	$TAGS{data_type} = "sqlfDataType";
	56	$TAGS{size} = "sqlfSize";
	57	$TAGS{is_nullable} = "sqlfIsNullable";
	58	$TAGS{required} = "sqlfRequired";
	59	$TAGS{is_auto_increment} = "sqlfIsAutoIncrement";
	60	$TAGS{default_value} = "sqlfDefaultValue";
	61
	62	sub _parameters_in {
	63	my $params = shift;
	64	return grep {$_->{kind} ne "return"} @$params;
65	}
66
67	sub _resolve_tag {
68	my ($tag, $things) = @_;
69	foreach (@$things) {
70	return $_->{_map_taggedValues}{$tag}{dataValue}
71	if exists $_->{_map_taggedValues}{$tag}{dataValue};
72	}
73	return;
74	}
75
76
77	sub classes2schema {
78	my ($schema, $classes) = @_;
79
80	my %associations;
81	foreach my $class (@$classes) {
82	# Add the table
83	debug "Adding class: $class->{name}";
84	my $table = $schema->add_table( name => $class->{name} )
85	or die "Schema Error: ".$schema->error;
86
87	# Only collect the associations for classes that are tables. Use a hash
88	# so we only get them once
89	$associations{$_->{"xmi.id"}} = $_
90	foreach map $_->{association}, @{$class->{associationEnds}};
91
92	#
93	# Fields from Class attributes
94	#
95	my @flds;
96	push @flds, attr2field($_) for @{$class->{attributes}};
97	# TODO Filter this e.g no abstract attr or stereotype check
98	foreach (@flds) {
99	my $extra = delete $_->{extra};
100	my $field = $table->add_field( %$_ ) or die $schema->error;
101	$field->extra(%$extra) if $extra;
102	}
103
104	#
105	# Primary key
106	#
107	my @pkeys;
108	@pkeys = map $_->{name},
109	grep($_->{stereotype} eq "PK", @{$class->{attributes}});
110	# if none set with steretype, use first attrib
111	@pkeys = $class->{attributes}[0]{name} unless @pkeys;
112	$table->add_constraint(
113	type => "PRIMARY KEY",
114	fields => [@pkeys],
115	) or die $schema->error;
116	}
117
118	#
119	# Relationships from Associations
120	#
121	foreach my $assoc (values %associations) {
122	my @end = @{$assoc->{associationEnds}};
123	if (
124	$end[0]->{multiplicity}{rangeUpper} == 1
125	&& $end[1]->{multiplicity}{rangeUpper} == 1
126	) {
127	# 1:1 or 0:1
128	warn "Sorry, 1:1 associations not yet implimented for xmi.id".$assoc->{"xmi.id"}."\n";
129	}
130	elsif (
131	$end[0]->{multiplicity}{rangeUpper} == 1
132	\|\| $end[1]->{multiplicity}{rangeUpper} == 1
133	) {
134	# 1:m or 0:m
135	one2many($schema,$assoc);
136	}
137	else
138	{
139	# m:n
140	warn "Sorry, n:m associations not yet implimented for xmi.id".$assoc->{"xmi.id"}."\n";
141	}
142
143	}
144
145	}
146
147	sub attr2field {
148	my $attr = shift;
149	my $dataType = $attr->{dataType};
150
151	my %data = ( name => $attr->{name} );
152
153	$data{data_type}
154	= _resolve_tag($TAGS{data_type},[$attr,$dataType])
155	\|\| $dataType->{name};
156
157	$data{size} = _resolve_tag($TAGS{size},[$attr,$dataType]);
158
159	$data{default_value}
160	= $attr->{initialValue}
161	\|\| _resolve_tag($TAGS{default_value},[$attr,$dataType]);
162
163	my $is_nullable = _resolve_tag($TAGS{is_nullable},[$attr,$dataType]);
164	my $required = _resolve_tag($TAGS{required},[$attr,$dataType]);
165	$data{is_nullable}
166	= defined $is_nullable ? $is_nullable
167	: ( defined $required ? ($required ? 0 : 1) : undef);
168
169	$data{is_auto_increment}
170	= $attr->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue}
171	\|\| $dataType->{_map_taggedValues}{$TAGS{is_auto_increment}}{dataValue}
172	\|\| undef;
173
174	#
175	# Extras
176	#
177	my %tagnames;
178	foreach ( keys %{$attr->{_map_taggedValues}} ) {$tagnames{$_}++; }
179	delete @tagnames{@TAGS{qw/data_type size default_value is_nullable required is_auto_increment/}}; # Remove the tags we have already done
180	my %extra = map {
181	my $val = $attr->{_map_taggedValues}{$_}{dataValue};
182	s/^sqlf//;
183	($_,$val);
184	} keys %tagnames;
185	$data{extra} = \%extra;
186
187	return \%data;
188	}
189
190	# Maps a 1:M association into the schema
191	sub one2many {
192	my ($scma,$assoc) = @_;
193	my @ends = @{$assoc->{associationEnds}};
194	my ($end1) = grep $_->{multiplicity}{rangeUpper} == 1, @ends;
195	my $endm = $end1->{otherEnd};
196	my $table1 = $scma->get_table($end1->{participant}{name});
197	my $tablem = $scma->get_table($endm->{participant}{name});
198
199	#
200	# Export 1end pkey to many end
201	#
202	my $con = $table1->primary_key;
203	my @flds = $con->fields;
204	foreach (@flds) {
205	my $fld = $table1->get_field($_);
206	my %data;
207	$data{$_} = $fld->$_()
208	foreach (qw/name size data_type default_value is_nullable/);
209	$data{extra} = { $fld->extra }; # Copy extra hash
210	$data{is_unique} = 0; # FKey on many join so not unique
211	$data{is_nullable} = $end1->{multiplicity}{rangeLower} == 0 ? 1 : 0;
212	# 0:m - allow nulluable on fkey
213	# 1:m - dont allow nullable
214
215	$tablem->add_field(%data) or die $scma->error;
216	# Export the pkey if full composite (ie identity) relationship
217	$tablem->primary_key($_) if $end1->{aggregation} eq "composite";
218	}
219
220	#
221	# Add fkey constraint to many end
222	#
223	$tablem->add_constraint(
224	type => "FOREIGN_KEY",
225	fields => [@flds],
226	reference_table => $table1->{name},
227	reference_fields => [@flds],
228	) or die $scma->error;
229	}
230
231	1; #---------------------------------------------------------------------------
232
233	__END__
234
235	=pod
236
237	=head1 SYNOPSIS
238
239	use SQL::Translator;
240	use SQL::Translator::Parser::XML::XMI;
241
242	my $translator = SQL::Translator->new(
243	from => 'XML-XMI-SQLFairy',
244	to => 'MySQL',
245	filename => 'schema.xmi',
246	);
247
248	print $obj->translate;
249
250	=head1 DESCRIPTION
251
252	Converts Class diagrams to Schema trying to use standard UML features as much
253	as possible, with the minimum use of extension mechanisms (tagged values and
254	stereotypes) for the database details. The idea is to treat the object model
255	like a logical database model and map that to a physical model (the sql). Also
256	tries to make this mapping as configurable as possible and support all the
257	schema features that SQLFairy does.
258
259	=head2 Tables
260
261	Classes, all of them! (TODO More control over which tables to do.)
262
263	=head2 Fields
264
265	=head3 Datatypes
266
267	Database datatypes are modeled using tagged values; sqlfDataType,
268	sqlfSize, sqlfIsNullable and sqlfIsAutoIncrement. These can be added either
269	to the UML datatype or directly on the attribute where they override the value
270	from the datatype. If no sqlfDataType is given then the name of the UMLDataType
271	is used. If no default value is found then the UML initialValue is used (even
272	if a tag is set on the UMLDataType - do we want to do it this way?.
273
274	=head3 Primary Keys
275
276	Primary keys are attributes marked with <<PK>>. Add to multiple attribs to make
277	multi column keys. If none are marked will use the 1st attribute.
278
279	=head2 Relationships
280
281	Modeled using UML associations. Currently only handles 0:m and 1:m joins. That
282	is associations where one ends multiplicty is '1' or '0..1' and the other end's
283	multplicity is '0..' or '1..' or >1 (e.g '0..3' '1..23' '4..42') etc.
284
285	The pkey from the 1 end is added to the table for the class at the many end as
286	a foreign key. is_unique is forced to false for the new field.
287
288	If the 1 end is multiplicity '0..1' (ie a 0:m join) then the the fkey is made
289	nullable, if its multiplicity '1' (1:m) then its made not nullable.
290
291	If the association is a composition then the created fkey is made part of the
292	many ends pkey. ie It exports the pkey to create an identity join.
293
294	=head1 ARGS
295
296	=head1 BUGS
297
298	=head1 TODO
299
300	=head1 AUTHOR
301
302	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
303
304	=head1 SEE ALSO
305
306	perl(1), SQL::Translator::Parser::XML::XMI
307
308	=cut