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

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