[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / XML / XMI.pm

package SQL::Translator::Parser::XML::XMI;

# -------------------------------------------------------------------
# $Id: XMI.pm,v 1.7 2003-09-17 16:27:21 grommit Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Mark Addison <mark.addison@itn.co.uk>,
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Parser::XML::XMI - Parser to create Schema from UML
Class diagrams stored in XMI format.

=head1 SYNOPSIS

  use SQL::Translator;
  use SQL::Translator::Parser::XML::XMI;

  my $translator     = SQL::Translator->new(
      from           => 'XML-XMI',
      to             => 'MySQL',
      filename       => 'schema.xmi',
      show_warnings  => 1,
      add_drop_table => 1,
  );

  print $obj->translate;

=head1 DESCRIPTION

Currently pulls out all the Classes as tables.

Any attributes of the class will be used as fields. The datatype of the
attribute must be a UML datatype and not an object, with the datatype's name
being used to set the data_type value in the schema.

=head2 XMI Format

The parser has been built using XMI 1.2 generated by PoseidonUML 2beta, which
says it uses UML 2. So the current conformance is down to Poseidon's idea
of XMI!

It should also parse XMI 1.0, such as you get from Rose, but this has had
little testing!

=head1 ARGS

=over 4

=item visibility

 visibilty=public|protected|private

What visibilty of stuff to translate. e.g when set to 'public' any private
and package Classes will be ignored and not turned into tables. Applies
to Classes and Attributes.

If not set or false (the default) no checks will be made and everything is
translated.

=back

=cut

# -------------------------------------------------------------------

use strict;

use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use Data::Dumper;
use Exporter;
use base qw(Exporter);
@EXPORT_OK = qw(parse);

use base qw/SQL::Translator::Parser/;  # Doesnt do anything at the mo!
use SQL::Translator::Utils 'debug';
use SQL::Translator::XMI::Parser;


# SQLFairy Parser
#-----------------------------------------------------------------------------

# is_visible - Used to check visibility in filter subs
{
    my %vislevel = (
        public => 1,
        protected => 2,
        private => 3,
    );

    sub is_visible {
		my ($nodevis, $vis) = @_;
        $nodevis = ref $_[0] ? $_[0]->{visibility} : $_[0];
        return 1 unless $vis;
        return 1 if $vislevel{$vis} >= $vislevel{$nodevis};
        return 0; 
    }
}

my ($schema, $pargs);

sub parse {
    my ( $translator, $data ) = @_;
    local $DEBUG  = $translator->debug;
    $schema    = $translator->schema;
    $pargs     = $translator->parser_args;

    debug "Visibility Level:$pargs->{visibility}" if $DEBUG;

    my $xmip = SQL::Translator::XMI::Parser->new(xml => $data);

    # TODO
    # - Options to set the initial context node so we don't just
    #   blindly do all the classes. e.g. Select a diag name to do.

    my $classes = $xmip->get_classes(
        filter => sub {
            return unless $_->{name};
            return unless is_visible($_, $pargs->{visibility});
            return 1;
        },
        filter_attributes => sub {
            return unless $_->{name};
            return unless is_visible($_, $pargs->{visibility});
            return 1;
        },
    );

    debug "Found ".scalar(@$classes)." Classes: ".join(", ",
        map {$_->{"name"}} @$classes) if $DEBUG;
    debug "Classes:",Dumper($classes);
    #print "Classes:",Dumper($classes),"\n";

	#
	# Turn the data from get_classes into a Schema
	#
	profile_default($classes);


    return 1;
}

sub profile_default {
	my ($classes) = @_;

	foreach my $class (@$classes) {
        # Add the table
        debug "Adding class: $class->{name}" if $DEBUG;
        my $table = $schema->add_table( name => $class->{name} )
            or die "Schema Error: ".$schema->error;

        #
        # Fields from Class attributes
        #
        foreach my $attr ( @{$class->{attributes}} ) {
			my %data = (
                name           => $attr->{name},
                data_type      => $attr->{datatype},
                is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
                #is_foreign_key => $stereotype eq "FK" ? 1 : 0,
            );
			$data{default_value} = $attr->{initialValue}
				if exists $attr->{initialValue};

            debug "Adding field:",Dumper(\%data);
            my $field = $table->add_field( %data ) or die $schema->error;

            $table->primary_key( $field->name ) if $data{'is_primary_key'};
            #
            # TODO:
            # - We should be able to make the table obj spot this when
            #   we use add_field.
            #
        }

    } # Classes loop
}

sub profile_rational {
	my ($classes) = @_;

	foreach my $class (@$classes) {
        next unless $class->{stereotype} eq "Table";

		# Add the table
        debug "Adding class: $class->{name}" if $DEBUG;
        my $table = $schema->add_table( name => $class->{name} )
            or die "Schema Error: ".$schema->error;

        #
        # Fields from Class attributes
        #
        foreach my $attr ( @{$class->{attributes}} ) {
			next unless $attr->{stereotype} eq "Column"
				or $attr->{stereotype} eq "PK"
				or $attr->{stereotype} eq "FK"
				or $attr->{stereotype} eq "PFK";

			my $ispk =
			    $attr->{stereotype} eq "PK" or $attr->{stereotype} eq "PFK"
				? 1 : 0;
			my %data = (
                name           => $attr->{name},
                data_type      => $attr->{datatype},
                is_primary_key => $ispk,
            );
			$data{default_value} = $attr->{initialValue}
				if exists $attr->{initialValue};

            my $field = $table->add_field( %data ) or die $schema->error;
            $table->primary_key( $field->name ) if $data{'is_primary_key'};
		}

		#
		# Constraints and indexes from Operations
		#
        foreach my $op ( @{$class->{operations}} ) {
			next unless my $stereo = $op->{stereotype};
			my @fields = map {$_->{name}} @{$op->{parameters}};
			my %data = (
                name      => $op->{name},
                type      => "",
				fields    => [@fields],
            );
			
			# Work out type and any other data
			if ( $stereo eq "Unique" ) {
				$data{type} = "UNIQUE";
			}
			elsif ( $stereo eq "PK" ) {
				$data{type} = "PRIMARY_KEY";
			}
			# TODO We need to work out the ref table
			#elsif ( $stereo eq "FK" ) {
			#	$data{type} = "FOREIGN_KEY";
			#}
            
			# Add the constraint or index
			if ( $data{type} ) {
				$table->add_constraint( %data ) or die $schema->error;
			}
			elsif ( $stereo eq "Index" ) {
            	$data{type} = "NORMAL";
				$table->add_index( %data ) or die $schema->error;
			}
			
			
		} # Ops loop

    } # Classes loop
}

1; #---------------------------------------------------------------------------

__END__

=pod

=head1 BUGS

Seems to be slow. I think this is because the XMI files can get pretty
big and complex, especially all the diagram info, and XPath needs to load the
whole tree.

=head1 TODO

B<field sizes> Don't think UML does this directly so may need to include
it in the datatype names.

B<table_visibility and field_visibility args> Seperate control over what is 
parsed, setting visibility arg will set both.

Everything else! Relations, fkeys, constraints, indexes, etc...

=head1 AUTHOR

Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.

=head1 SEE ALSO

perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
SQL::Translator::Schema.

=cut
Commit	Line	Data
1223c9b2	1	package SQL::Translator::Parser::XML::XMI;
	2
	3	# -------------------------------------------------------------------
538293f0	4	# $Id: XMI.pm,v 1.7 2003-09-17 16:27:21 grommit Exp $
1223c9b2	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 - Parser to create Schema from UML
	26	Class diagrams stored in XMI format.
	27
f8ec05fa	28	=head1 SYNOPSIS
	29
	30	use SQL::Translator;
	31	use SQL::Translator::Parser::XML::XMI;
	32
	33	my $translator = SQL::Translator->new(
	34	from => 'XML-XMI',
	35	to => 'MySQL',
	36	filename => 'schema.xmi',
	37	show_warnings => 1,
	38	add_drop_table => 1,
	39	);
	40
	41	print $obj->translate;
	42
	43	=head1 DESCRIPTION
	44
f42065cb	45	Currently pulls out all the Classes as tables.
f8ec05fa	46
	47	Any attributes of the class will be used as fields. The datatype of the
	48	attribute must be a UML datatype and not an object, with the datatype's name
	49	being used to set the data_type value in the schema.
	50
f8ec05fa	51	=head2 XMI Format
f8ec05fa	52
f42065cb	53	The parser has been built using XMI 1.2 generated by PoseidonUML 2beta, which
f8ec05fa	54	says it uses UML 2. So the current conformance is down to Poseidon's idea
	55	of XMI!
	56
f42065cb	57	It should also parse XMI 1.0, such as you get from Rose, but this has had
	58	little testing!
	59
f8ec05fa	60	=head1 ARGS
	61
	62	=over 4
	63
	64	=item visibility
	65
	66	visibilty=public\|protected\|private
	67
	68	What visibilty of stuff to translate. e.g when set to 'public' any private
	69	and package Classes will be ignored and not turned into tables. Applies
	70	to Classes and Attributes.
	71
	72	If not set or false (the default) no checks will be made and everything is
	73	translated.
	74
	75	=back
	76
1223c9b2	77	=cut
	78
	79	# -------------------------------------------------------------------
	80
	81	use strict;
	82
	83	use vars qw[ $DEBUG $VERSION @EXPORT_OK ];
538293f0	84	$VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
1223c9b2	85	$DEBUG = 0 unless defined $DEBUG;
	86
	87	use Data::Dumper;
	88	use Exporter;
	89	use base qw(Exporter);
	90	@EXPORT_OK = qw(parse);
	91
	92	use base qw/SQL::Translator::Parser/; # Doesnt do anything at the mo!
	93	use SQL::Translator::Utils 'debug';
f42065cb	94	use SQL::Translator::XMI::Parser;
91ed9c32	95
91ed9c32	96
f42065cb	97	# SQLFairy Parser
f42065cb	98	#-----------------------------------------------------------------------------
91ed9c32	99
f42065cb	100	# is_visible - Used to check visibility in filter subs
	101	{
	102	my %vislevel = (
	103	public => 1,
	104	protected => 2,
	105	private => 3,
	106	);
5cb154e5	107
f42065cb	108	sub is_visible {
	109	my ($nodevis, $vis) = @_;
	110	$nodevis = ref $_[0] ? $_[0]->{visibility} : $_[0];
	111	return 1 unless $vis;
	112	return 1 if $vislevel{$vis} >= $vislevel{$nodevis};
	113	return 0;
5cb154e5	114	}
5cb154e5	115	}
91ed9c32	116
538293f0	117	my ($schema, $pargs);
538293f0	118
1223c9b2	119	sub parse {
1223c9b2	120	my ( $translator, $data ) = @_;
f42065cb	121	local $DEBUG = $translator->debug;
538293f0	122	$schema = $translator->schema;
	123	$pargs = $translator->parser_args;
	124
ef2d7798	125	debug "Visibility Level:$pargs->{visibility}" if $DEBUG;
ef2d7798	126
f42065cb	127	my $xmip = SQL::Translator::XMI::Parser->new(xml => $data);
f42065cb	128
1223c9b2	129	# TODO
	130	# - Options to set the initial context node so we don't just
	131	# blindly do all the classes. e.g. Select a diag name to do.
538293f0	132
f42065cb	133	my $classes = $xmip->get_classes(
	134	filter => sub {
	135	return unless $_->{name};
	136	return unless is_visible($_, $pargs->{visibility});
	137	return 1;
	138	},
	139	filter_attributes => sub {
	140	return unless $_->{name};
	141	return unless is_visible($_, $pargs->{visibility});
	142	return 1;
	143	},
	144	);
538293f0	145
f8ec05fa	146	debug "Found ".scalar(@$classes)." Classes: ".join(", ",
f8ec05fa	147	map {$_->{"name"}} @$classes) if $DEBUG;
f42065cb	148	debug "Classes:",Dumper($classes);
f42065cb	149	#print "Classes:",Dumper($classes),"\n";
f8ec05fa	150
	151	#
	152	# Turn the data from get_classes into a Schema
	153	#
538293f0	154	profile_default($classes);
	155
	156
	157	return 1;
	158	}
	159
	160	sub profile_default {
	161	my ($classes) = @_;
	162
f8ec05fa	163	foreach my $class (@$classes) {
1223c9b2	164	# Add the table
f8ec05fa	165	debug "Adding class: $class->{name}" if $DEBUG;
f8ec05fa	166	my $table = $schema->add_table( name => $class->{name} )
1223c9b2	167	or die "Schema Error: ".$schema->error;
	168
	169	#
	170	# Fields from Class attributes
	171	#
f8ec05fa	172	foreach my $attr ( @{$class->{attributes}} ) {
	173	my %data = (
	174	name => $attr->{name},
	175	data_type => $attr->{datatype},
	176	is_primary_key => $attr->{stereotype} eq "PK" ? 1 : 0,
1223c9b2	177	#is_foreign_key => $stereotype eq "FK" ? 1 : 0,
1223c9b2	178	);
f8ec05fa	179	$data{default_value} = $attr->{initialValue}
f8ec05fa	180	if exists $attr->{initialValue};
1223c9b2	181
	182	debug "Adding field:",Dumper(\%data);
	183	my $field = $table->add_field( %data ) or die $schema->error;
	184
	185	$table->primary_key( $field->name ) if $data{'is_primary_key'};
	186	#
	187	# TODO:
ef2d7798	188	# - We should be able to make the table obj spot this when
1223c9b2	189	# we use add_field.
	190	#
	191	}
	192
	193	} # Classes loop
538293f0	194	}
1223c9b2	195
538293f0	196	sub profile_rational {
	197	my ($classes) = @_;
	198
	199	foreach my $class (@$classes) {
	200	next unless $class->{stereotype} eq "Table";
	201
	202	# Add the table
	203	debug "Adding class: $class->{name}" if $DEBUG;
	204	my $table = $schema->add_table( name => $class->{name} )
	205	or die "Schema Error: ".$schema->error;
	206
	207	#
	208	# Fields from Class attributes
	209	#
	210	foreach my $attr ( @{$class->{attributes}} ) {
	211	next unless $attr->{stereotype} eq "Column"
	212	or $attr->{stereotype} eq "PK"
	213	or $attr->{stereotype} eq "FK"
	214	or $attr->{stereotype} eq "PFK";
	215
	216	my $ispk =
	217	$attr->{stereotype} eq "PK" or $attr->{stereotype} eq "PFK"
	218	? 1 : 0;
	219	my %data = (
	220	name => $attr->{name},
	221	data_type => $attr->{datatype},
	222	is_primary_key => $ispk,
	223	);
	224	$data{default_value} = $attr->{initialValue}
	225	if exists $attr->{initialValue};
	226
	227	my $field = $table->add_field( %data ) or die $schema->error;
	228	$table->primary_key( $field->name ) if $data{'is_primary_key'};
	229	}
	230
	231	#
	232	# Constraints and indexes from Operations
	233	#
	234	foreach my $op ( @{$class->{operations}} ) {
	235	next unless my $stereo = $op->{stereotype};
	236	my @fields = map {$_->{name}} @{$op->{parameters}};
	237	my %data = (
	238	name => $op->{name},
	239	type => "",
	240	fields => [@fields],
	241	);
	242
	243	# Work out type and any other data
	244	if ( $stereo eq "Unique" ) {
	245	$data{type} = "UNIQUE";
	246	}
	247	elsif ( $stereo eq "PK" ) {
	248	$data{type} = "PRIMARY_KEY";
	249	}
	250	# TODO We need to work out the ref table
	251	#elsif ( $stereo eq "FK" ) {
	252	# $data{type} = "FOREIGN_KEY";
	253	#}
	254
	255	# Add the constraint or index
	256	if ( $data{type} ) {
	257	$table->add_constraint( %data ) or die $schema->error;
	258	}
	259	elsif ( $stereo eq "Index" ) {
260	$data{type} = "NORMAL";
261	$table->add_index( %data ) or die $schema->error;
262	}
263
264
265	} # Ops loop
266
267	} # Classes loop
1223c9b2	268	}
1223c9b2	269
538293f0	270	1; #---------------------------------------------------------------------------
1223c9b2	271
538293f0	272	__END__
f8ec05fa	273
f8ec05fa	274	=pod
1223c9b2	275
	276	=head1 BUGS
	277
ef2d7798	278	Seems to be slow. I think this is because the XMI files can get pretty
f42065cb	279	big and complex, especially all the diagram info, and XPath needs to load the
f42065cb	280	whole tree.
ef2d7798	281
1223c9b2	282	=head1 TODO
1223c9b2	283
ef2d7798	284	B<field sizes> Don't think UML does this directly so may need to include
1223c9b2	285	it in the datatype names.
1223c9b2	286
ef2d7798	287	B<table_visibility and field_visibility args> Seperate control over what is
	288	parsed, setting visibility arg will set both.
	289
1223c9b2	290	Everything else! Relations, fkeys, constraints, indexes, etc...
	291
	292	=head1 AUTHOR
	293
	294	Mark D. Addison E<lt>mark.addison@itn.co.ukE<gt>.
	295
	296	=head1 SEE ALSO
	297
	298	perl(1), SQL::Translator, XML::XPath, SQL::Translator::Producer::XML::SQLFairy,
	299	SQL::Translator::Schema.
	300
	301	=cut
f8ec05fa	302
f8ec05fa	303