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 |