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

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