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

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