lib/SQL/Translator/Parser/XML/XMI/SQLFairy.pm

   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