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

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