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

# -------------------------------------------------------------------
# $Id: XMI.pm,v 1.3 2003-09-08 17:10:07 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

=head2 UML Data Modeling

To tell the parser which Classes are tables give them a <<Table>> stereotype.

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.

Primary keys are attributes marked with <<PK>> stereotype.

=head2 XMI Format

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

=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.3 $ =~ /(\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 XML::XPath;
use XML::XPath::XMLParser;

#
# get_classes( XPATHOBJ, ARGS );
#
# XPATHOBJ - An XML::XPath object setup and ready to use. You can also use any
#            Node to search from as this sub just calls findnodes() on the arg.
#
# ARGS     - Name/Value list of args.
#
# xpath  =>  The xpath to use for finding classes. Default is //UML:Classes
#            which will find all the classes in the XMI.
#
# attribute_test => An XPath predicate (ie the bit between [] ) to test the
#            attributes with to decide if we should parse them. ie
#            attribute_test => '@name="foo"' would only pass out attribs
#            with a name of foo.
#
sub get_classes {
	my ($xp,%args) = @_;
	my $classes = [];

	my $xpath = $args{xpath} ||= '//UML:Class'; # Default: all classes
	$xpath .= "[$args{class_test}]" if $args{class_test};

	my @nodes = $xp->findnodes($xpath);
	return unless @nodes;

	for my $classnode (@nodes) {
        my $class = {};

		# <UML:Class> attributes
		foreach (
			qw/name visibility isSpecification
			   isRoot isLeaf isAbstract isActive/
		) {
			$class->{$_} = $classnode->getAttribute($_);
		}

		# Stereotype
		$class->{stereotype} = "".$classnode->find(
            'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');

		#
		# Class Attributes
		#
		my $xpath = 'UML:Classifier.feature/UML:Attribute';
		$xpath .= "[$args{attribute_test}]" if $args{attribute_test};
		foreach my $attrnode ( $classnode->findnodes($xpath) ) {
			my $attr = {};
			# <UML:Attributes> attributes
			foreach (qw/name visibility isSpecification ownerScope/) {
				$attr->{$_} = $attrnode->getAttribute($_);
			}

			$attr->{stereotype} = "".$attrnode->findvalue(
                'xmiDeref(UML:ModelElement.stereotype/UML:Stereotype)/@name');

			$attr->{datatype} = "".$attrnode->find(
                  'xmiDeref(UML:StructuralFeature.type/UML:DataType)/@name');
            if ( my @body = $attrnode->findnodes(
                'UML:Attribute.initialValue/UML:Expression/@body') 
            ) {
                $attr->{initialValue} = $body[0]->getData;
            }

			push @{$class->{attributes}}, $attr;
		}

		push @$classes, $class;
	}

	return $classes;
};

sub parse {
	eval {

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

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

    my $xp = XML::XPath->new(xml => $data);
    $xp->set_namespace("UML", "org.omg.xmi.namespace.UML");
    #
    # 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.

	#
    # Build an XPath for the classes and attributes we want...
	#
    my @tests = ('@xmi.id'); # Only classes with an id so we don't get any
	                         #     refs to classes ie xmi.idref classes
	push @tests, '@name';    # Only Classes with a name
	push @tests, "xmiVisible('$pargs->{visibility}')" if $pargs->{visibility};
	my $path = '//UML:Class['.join(' and ',@tests).']';

	my $attrib_test = '@name';
	$attrib_test .= " and xmiVisible('$pargs->{visibility}')"
	    if $pargs->{visibility};

	# ...and parse them out
	debug "Searching for Classes using:$path";
	my $classes = get_classes( $xp,
		xpath => $path, attribute_test => $attrib_test);

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

	#
	# Turn the data from get_classes into a Schema
	#
	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
        #
        # name data_type size default_value is_nullable
        # is_auto_increment is_primary_key is_foreign_key comments
        #
        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

    return 1;

	};
	print "ERROR: $@\n" if $@;
	return 1;
}

1;

#=============================================================================
#
# XML::XPath extensions
#
#=============================================================================

package XML::XPath::Function;

=head1 XMI XPath Functions

The Parser adds the following extra XPath functions.

=head2 xmiDeref

Deals with xmi.id/xmi.idref pairs of attributes. You give it an
xPath e.g 'UML:ModelElement.stereotype/UML:stereotype' if the the
tag it points at has an xmi.idref it looks up the tag with that
xmi.id and returns it.

If it doesn't have an xmi.id, the path is returned as normal.

e.g. given

 <UML:ModelElement.stereotype>
     <UML:Stereotype xmi.idref = 'stTable'/>
 </UML:ModelElement.stereotype>
  ...
 <UML:Stereotype xmi.id='stTable' name='Table' visibility='public'
     isAbstract='false' isSpecification='false' isRoot='false' isLeaf='false'>
     <UML:Stereotype.baseClass>Class</UML:Stereotype.baseClass>
 </UML:Stereotype>

Using xmideref(//UML:ModelElement.stereotype/UML:stereotype) would return the
<UML:Stereotype xmi.id = '3b4b1e:f762a35f6b:-7fb6' ...> tag.

Using xmideref(//UML:ModelElement.stereotype/UML:stereotype)/@name would give
"Table".

=head xmiVisible

 is_visible( VISLEVEL )

Returns true or false for whether the visibility of something e.g. a Class or
Attribute, is visible at the level given. e.g.

 //UML:Class[xmiVisible('public')]       - Find all public classes
 //UML:Class[xmiVisible('protected')]    - Find all public and protected classes

Supports the 3 UML visibility levels of public, protected and private.

Note: Currently any element tested that doesn't have a visibility="" attribute
is assumed to be visible and so xmiVisible will return true. This is probably
the wrong thing to do and is very likley to change. It is probably best to
throw an error if we try to test something that doesn't do visibility.

=cut

sub xmiDeref {
    my $self = shift;
    my ($node, @params) = @_;
    if (@params > 1) {
        die "xmiDeref() function takes one or no parameters\n";
    }
    elsif (@params) {
        my $nodeset = shift(@params);
        return $nodeset unless $nodeset->size;
        $node = $nodeset->get_node(1);
    }
    die "xmiDeref() needs an Element node." 
    unless $node->isa("XML::XPath::Node::Element");

    my $id = $node->getAttribute("xmi.idref") or return $node;
    return $node->getRootNode->find('//*[@xmi.id="'.$id.'"]');
}

{
    my %vislevel = (
        public => 1,
        protected => 2,
        private => 3,
    );

    sub xmiVisible {
		my $self = shift;
		my ($node, @params) = @_;
		if (@params < 1 or @params > 2) {
			die "xmiVisible() function takes 1 or 2 parameters\n";
		}
		elsif (@params == 2) {
			my $nodeset = shift(@params);
			return unless $nodeset->size;
			$node = $nodeset->get_node(1);
		}
		die "xmiVisible() needs an Element node." 
		unless $node->isa("XML::XPath::Node::Element");

		my $vis = shift(@params) || return XML::XPath::Boolean->True;
		my $nodevis = $node->getAttribute("visibility")
			|| return XML::XPath::Boolean->True;
        return XML::XPath::Boolean->True
			if $vislevel{$vis} >= $vislevel{$nodevis};
        return XML::XPath::Boolean->False;
    }
}

# Test of custom xpath function.
sub hello {
    return XML::XPath::Literal->new("Hello World");
}

#=============================================================================
package main;


=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.

=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


