File Coverage

blib/lib/Parse/Dia/SQL.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

line

stmt

bran

cond

sub

pod

time

code

package Parse::Dia::SQL;

# $Id: SQL.pm,v 1.55 2011/02/16 10:23:11 aff Exp $

=pod

=head1 NAME

Parse::Dia::SQL - Convert Dia class diagrams into SQL.

=head1 SYNOPSIS

use Parse::Dia::SQL;

my $dia = Parse::Dia::SQL->new(

file => 't/data/TestERD.dia',

db => 'db2'

);

print $dia->get_sql();

# or command-line version

perl parsediasql --file t/data/TestERD.dia --db db2

=head1 DESCRIPTION

Dia is a diagram creation program for Linux, Unix and Windows released

under the I.

Parse::Dia::SQL converts Dia class diagrams into SQL.

Parse::Dia::SQL is the parser that interprets the .dia file(s) into an

internal datastructure.

Parse::Dia::SQL::Output (or one of its sub classes) can take the

datastructure and generate the SQL statements it represents.

=head1 MODELLING HOWTO

See L

=head2 Modelling differences from tedia2sql

=over

=item * Index options are supported. Text is taken from the I field of the I, i.e. the index. A database specific default value is used if the I field is left blank. Consult the Output sub class' constructor.

=item * Type mapping is supported. A type mapping is a user-defined column name replacement. Unlike I the type mapping is non-recursive. Consult C for an example.

=item * Preliminary support for Dia's I shapes is added.

=item * Table comments are used as I. This

51				means per-table options (e.g. partitioning options) are supported on a
52				per-database level.
53
54				=item * I notation is supported for MySQL-InnoDB.
55
56				=back
57
58				=head1 DIA VERSIONS
59
60				Parse::Dia::SQL has been tested with Dia versions 0.93 - 0.97.
61
62				Parse::Dia::SQL uses the XML C tag information in the I<.dia> input file to determine how each XML construct is formatted. Future versions of Dia may change the internal format, and XML C tag is used to detect such changes.
63
64				=head1 DATABASE SUPPORT
65
66				The following databases are supported:
67
68				=over
69
70				=item DB2
71
72				=item Informix
73
74				=item Ingres
75
76				=item Oracle
77
78				=item Postgres
79
80				=item Sas
81
82				=item SQLite3
83
84				=item SQLite3fk (with foreign key support)
85
86				=item Sybase
87
88				=item MySQL InnoDB
89
90				=item MySQL MyISAM
91
92				=back
93
94				Adding support for additional databases means to create a subclass of
95				Parse::Dia::SQL::Output.
96
97				Patches are welcome.
98
99				=head1 AUTHOR
100
101				Parse::Dia::SQL is based on I by Tim Ellis and others. See the
102				I file for details.
103
104				Modified by Andreas Faafeng, C<< >> for release on
105				CPAN.
106
107				=head1 BUGS
108
109				Please report any bugs or feature requests to C
110				rt.cpan.org>, or through the web interface at
111				L. I will be
112				notified, and then you'll automatically be notified of progress on
113				your bug as I make changes.
114
115				=head1 SUPPORT
116
117				You can find documentation for this module with the perldoc command.
118
119				perldoc Parse::Dia::SQL
120
121				You can also look for information at:
122
123				=over 4
124
125				=item * Project home
126
127				Documentation and public source code repository:
128
129				L
130
131				=item * RT: CPAN's request tracker
132
133				L
134
135				=item * AnnoCPAN: Annotated CPAN documentation
136
137				L
138
139				=item * CPAN Ratings
140
141				L
142
143				=item * Search CPAN
144
145				L
146
147				=back
148
149				=head1 SEE ALSO
150
151				=over
152
153				=item * L
154
155				=item * L
156
157				=back
158
159
160				=head1 ACKNOWLEDGEMENTS
161
162				See the AUTHORS file.
163
164				=head1 LICENSE
165
166				This program is released under the GNU General Public License.
167
168				=head1 TERMINOLOGY
169
170				By I we mean relational database management system (RDBMS).
171
172				=cut
173
174	74	74	118328	use warnings;
	74		173
	74		2878
175	74	74	390	use strict;
	74		149
	74		1612
176
177	74	74	1254	use Data::Dumper;
	74		11715
	74		4837
178	74	74	37354	use IO::Uncompress::Gunzip qw(:all);
	74		2685242
	74		8641
179	74	74	50746	use XML::DOM;
	0
	0
180				use Data::Dumper;
181				use File::Spec::Functions qw(catfile catdir);
182
183				use lib q{lib};
184				use Parse::Dia::SQL::Utils;
185				use Parse::Dia::SQL::Logger;
186				use Parse::Dia::SQL::Const;
187				use Parse::Dia::SQL::Output;
188
189				use Parse::Dia::SQL::Output::DB2;
190				use Parse::Dia::SQL::Output::HTML;
191				use Parse::Dia::SQL::Output::Informix;
192				use Parse::Dia::SQL::Output::Ingres;
193				use Parse::Dia::SQL::Output::MySQL::InnoDB;
194				use Parse::Dia::SQL::Output::MySQL::MyISAM;
195				use Parse::Dia::SQL::Output::MySQL;
196				use Parse::Dia::SQL::Output::Oracle;
197				use Parse::Dia::SQL::Output::Postgres;
198				use Parse::Dia::SQL::Output::SQLite3;
199				use Parse::Dia::SQL::Output::SQLite3fk;
200				use Parse::Dia::SQL::Output::Sas;
201				use Parse::Dia::SQL::Output::Sybase;
202
203				our $VERSION = '0.30';
204
205				my $UML_ASSOCIATION = 'UML - Association';
206				my $UML_SMALLPACKAGE = 'UML - SmallPackage';
207				my $UML_CLASS = 'UML - Class';
208				my $UML_COMPONENT = 'UML - Component';
209				my $DATABASE_TABLE = 'Database - Table';
210
211				=head1 METHODS
212
213				=over
214
215				=item new()
216
217				The constructor. Mandatory arguments:
218
219				file - The .dia file to parse
220				db - The target database type
221
222				Dies if target database is unknown or unsupported.
223
224				=cut
225
226				sub new {
227				my ($class, %param) = @_;
228
229				# Argument 'file' overrides argument 'files'
230				$param{files} = [ $param{file} ] if defined($param{file});
231
232				my $self = {
233				files => $param{files} \|\| undef,
234				db => $param{db} \|\| undef,
235				uml => $param{uml} \|\| undef,
236				fk_auto_gen => $param{fk_auto_gen} \|\| undef,
237				pk_auto_gen => $param{pk_auto_gen} \|\| undef,
238				default_pk => $param{default_pk} \|\| undef, # opt_p
239				doc => undef,
240				nodelist => undef,
241				log => undef,
242				utils => undef,
243				const => undef,
244				fk_defs => [],
245				classes => [],
246				components => [], # insert statements
247				small_packages => [],
248				typemap => {},
249				output => undef,
250				index_options => $param{index_options} \|\| [],
251				diaversion => $param{diaversion} \|\| undef,
252				ignore_type_mismatch => $param{ignore_type_mismatch} \|\| undef,
253				converted => 0,
254				loglevel => $param{loglevel} \|\| undef,
255				backticks => $param{backticks} \|\| undef, # MySQL-InnoDB only
256				htmlformat => $param{htmlformat} \|\| '', # HTML output only
257				};
258
259				bless($self, $class);
260
261				$self->_init_log();
262				$self->_init_utils();
263				$self->_init_const();
264
265				# Die unless database is supported
266				if (!grep(/^$self->{db}$/, $self->{const}->get_rdbms())) {
267				$self->{log}->logdie(qq{Unsupported database }
268				. $self->{db}
269				. q{. Valid options are }
270				. join(q{, }, $self->{const}->get_rdbms()));
271				}
272
273				return $self;
274				}
275
276
277				# Initialize logger
278				sub _init_log {
279				my $self = shift;
280				my $logger = Parse::Dia::SQL::Logger::->new(loglevel => $self->{loglevel});
281				$self->{log} = $logger->get_logger(__PACKAGE__);
282				return 1;
283				}
284
285				# Initialize Constants component
286				sub _init_const {
287				my $self = shift;
288				$self->{const} = Parse::Dia::SQL::Const::->new();
289				return 1;
290				}
291
292				# Initialize Parse::Dia::SQL::Utils class.
293				sub _init_utils {
294				my $self = shift;
295				$self->{utils} = Parse::Dia::SQL::Utils::->new(
296				db => $self->{db},
297				default_pk => $self->{default_pk},
298				loglevel => $self->{loglevel},
299				);
300				return 1;
301				}
302
303
304				# Return Output subclass for the database set in C.
305				#
306				# Some params will be taken from this object unless explicitly set by caller:
307				#
308				# classes
309				# associations
310				# small_packages
311				# components
312				# files
313				# index_options
314				# typemap
315				#
316				# Returns undef if convert flag is false (to prevent output before
317				# conversion).
318				#
319				# Dies if db is unknown.
320				sub get_output_instance {
321				my ($self, %param) = @_;
322
323				# Make sure parsing is finished before we can output
324				if (!$self->{converted}) {
325				$self->{log}->error("Cannot output before convert!");
326				return;
327				}
328
329				# Add some args to param unless they are set by caller
330				%param =
331				map { $param{$_} = $self->{$_} unless exists($param{$_}); $_ => $param{$_} }
332				qw(classes associations small_packages components files index_options typemap loglevel backticks htmlformat);
333
334				if ($self->{db} eq q{db2}) {
335				return Parse::Dia::SQL::Output::DB2->new(%param);
336				} elsif ($self->{db} eq q{mysql-myisam}) {
337				return Parse::Dia::SQL::Output::MySQL::MyISAM->new(%param);
338				} elsif ($self->{db} eq q{mysql-innodb}) {
339				return Parse::Dia::SQL::Output::MySQL::InnoDB->new(%param);
340				} elsif ($self->{db} eq q{sybase}) {
341				return Parse::Dia::SQL::Output::Sybase->new(%param);
342				} elsif ($self->{db} eq q{ingres}) {
343				return Parse::Dia::SQL::Output::Ingres->new(%param);
344				} elsif ($self->{db} eq q{informix}) {
345				return Parse::Dia::SQL::Output::Informix->new(%param);
346				} elsif ($self->{db} eq q{oracle}) {
347				return Parse::Dia::SQL::Output::Oracle->new(%param);
348				} elsif ($self->{db} eq q{postgres}) {
349				return Parse::Dia::SQL::Output::Postgres->new(%param);
350				} elsif ($self->{db} eq q{sas}) {
351				return Parse::Dia::SQL::Output::Sas->new(%param);
352				} elsif ($self->{db} eq q{sqlite3}) {
353				return Parse::Dia::SQL::Output::SQLite3->new(%param);
354				} elsif ($self->{db} eq q{sqlite3fk}) {
355				return Parse::Dia::SQL::Output::SQLite3fk->new(%param);
356				} elsif ($self->{db} eq q{html}) {
357				return Parse::Dia::SQL::Output::HTML->new(%param);
358				}
359
360				return $self->{log}->logdie(qq{Failed to get instance for } . $self->{db});
361				}
362
363
364				# Parse the .dia file and create inner representation.
365				#
366				# Returns true on success.
367				#
368				# Returns undefined if called more than once on the same object.
369				sub convert {
370				my $self = shift;
371
372				if ($self->{converted}) {
373				$self->{log}->info("Repeated conversion attempt discarded");
374				return;
375				}
376
377				$self->_parse_doms();
378				$self->_get_nodelists();
379				$self->_parse_classes(); # parse
380				$self->_parse_smallpackages(); # parse
381				$self->_parse_associations(); # parse
382
383				$self->{classes} = $self->get_classes_ref();
384				$self->{small_packages} = $self->get_smallpackages_ref();
385				$self->{associations} = $self->get_associations_ref();
386				$self->{components} = $self->get_components_ref();
387
388				$self->{converted} = 1; # flag that we have parsed the file(s)
389				return 1;
390				}
391
392				=item get_sql()
393
394				Return sql for given db. Calls underlying methods that performs
395				parsing and sql generation.
396
397				=cut
398
399				sub get_sql {
400				my $self = shift;
401				my $sqlstr = q{};
402				$self->convert() or $self->{log}->logdie("failed to convert");
403				my $output = $self->get_output_instance();
404				return $output->get_sql();
405				}
406
407				# Uncompress the .dia file(s) and parse xml content. Push the parsed xml
408				# dom onto the docs list.
409				#
410				# Return the number of parsed files.
411				sub _parse_doms {
412				my $self = shift;
413
414				if (!$self->{files} \|\| ref($self->{files}) ne q{ARRAY}){
415				$self->{log}->logdie(q{Need at least one file!});
416				}
417
418				foreach my $file ( @{ $self->{files} } ) {
419
420				if ( !-f $file ) {
421				$self->{log}->logdie(qq{missing file '$file'!});
422				} elsif ( !-r $file ) {
423				$self->{log}->logdie(qq{unreadable file '$file'!});
424				}
425
426				# uncompress
427				my $buffer = undef;
428				gunzip $file => \$buffer
429				or $self->{log}->logdie("gunzip failed: $GunzipError");
430
431				# parse xml
432				my $parser = new XML::DOM::Parser;
433				eval {
434				push @{ $self->{docs} }, $parser->parse($buffer);
435				};
436				if ($@) {
437				$self->{log}->logdie(qq{parsing of file '$file' failed});
438				}
439
440				}
441				return scalar( @{ $self->{docs} } );
442				}
443
444				# Returns the parsed xml dom documents (for testing only).
445				sub _get_docs {
446				my $self = shift;
447				return $self->{docs};
448				}
449
450				# Create nodelist from dom. Return array of array XML::DOM::NodeList
451				# objects.
452				#
453				# Each inner array correspond to a separate input file.
454				sub _get_nodelists {
455				my $self = shift;
456				if ( !$self->{docs} ) {
457				$self->{log}->error(q{missing docs list!});
458				return;
459				}
460
461				foreach my $doc ( @{ $self->{docs} } ) {
462				my $nodelist = $doc->getElementsByTagName('dia:object');
463				push @{ $self->{nodelists} }, $nodelist;
464				}
465
466				return $self->{nodelists};
467				}
468
469				# Accessor
470				sub get_smallpackages_ref {
471				my $self = shift;
472				return $self->{small_packages};
473				}
474
475				# Go through nodelists and return number of 'SmallPackages' found
476				# Extract typemap information if any to $self->{typemap}.
477				sub _parse_smallpackages {
478				my $self = shift;
479				my @retarr = (); # array of hashrefs to return
480
481				$self->{log}->debug("_parse_smallpackages is called");
482
483				if (!$self->{nodelists}) {
484				$self->{log}->warn("nodelists are empty");
485				return;
486				}
487
488				foreach my $nodelist (@{ $self->{nodelists} }) {
489
490				$self->{log}->debug("nodelist length" . $nodelist->getLength);
491
492				NODE:
493				for (my $i = 0 ; $i < $nodelist->getLength ; $i++) {
494				my $nodeType = $nodelist->item($i)->getNodeType;
495
496				# sanity check -- a dia:object should be an element_node
497				if ($nodeType == ELEMENT_NODE) {
498				my $nodeAttrType = $nodelist->item($i)->getAttribute('type');
499				my $nodeAttrId = $nodelist->item($i)->getAttribute('id');
500				my $nodeAttrVersion = $nodelist->item($i)->getAttribute('version');
501				$self->{log}->debug("Node $i -- type=$nodeAttrType");
502
503				if ($nodeAttrType eq $UML_SMALLPACKAGE) {
504
505				# Check that version is supported
506				if (!$self->{utils}
507				->_check_object_version($UML_SMALLPACKAGE, $nodeAttrVersion))
508				{
509				$self->{log}->error(
510				"Found unsupported version '$nodeAttrVersion' of $UML_SMALLPACKAGE"
511				);
512				next NODE;
513				}
514
515				# generic database statements
516				$self->{log}->debug("call _parse_smallpackage");
517				my $href =
518				$self->_parse_smallpackage($nodelist->item($i), $nodeAttrId);
519
520				$self->{log}->debug("_parse_smallpackage returned " . Dumper($href));
521				push @{ $self->{small_packages} }, $href;
522
523				# Custom handling of typemap, if any
524				$self->{log}->debug("typemap before: " . Dumper($self->{typemap}));
525				my $typemap = $self->_parse_typemap($href);
526				foreach my $key (keys %{$typemap}) {
527				$self->{typemap}->{$key} = $typemap->{$key};
528				}
529				$self->{log}->debug("typemap after: " . Dumper($self->{typemap}));
530				}
531				}
532				}
533				}
534
535				# Return number of small_packages - undef if none
536				if (defined($self->{small_packages})
537				&& ref($self->{small_packages}) eq 'ARRAY')
538				{
539				return scalar(@{ $self->{small_packages} });
540				} else {
541				return;
542				}
543				}
544
545				# Returns hashref where key is name of Databaseclass and value is its
546				# content.
547				sub _parse_databaseclass {
548				my $self = shift;
549				my $databaseclassNode = shift;
550
551				my $nodelist = $databaseclassNode->getElementsByTagName('dia:attribute');
552				$self->{log}->debug( "nodelist: " . Dumper($nodelist) );
553				$self->{log}->debug( "attributes: " . $nodelist->getLength );
554
555				}
556
557				# Parse _smallpackage hashref and set global hash typemap.
558				# Returns the parsed typemap hashref.
559				# Does not check for duplicate definitions.
560				sub _parse_typemap {
561				my $self = shift;
562				my $href = shift;
563				my $typemap_href = {};
564
565				# Custom handling of typemap, if any
566				TYPEMAP:
567				foreach my $key ( keys %{$href} ) {
568
569				# skip elements not containing typemap keyword
570				next TYPEMAP if ( $key !~ /^(.*):typemap/ );
571
572				my $typemap_db = $1;
573
574				# verify that key is a valid database type
575				if ( !grep( /^$typemap_db$/, $self->{const}->get_rdbms() ) ) {
576				$self->{log}->error( qq{Unsupported typemap '$typemap_db'}
577				. q{. Valid options are }
578				. join( q{, }, $self->{const}->get_rdbms() ) );
579				next TYPEMAP;
580				}
581
582				my $typemap_str = $href->{$key};
583				$self->{log}->debug(qq{Found typemap for database $typemap_db});
584
585				TYPEMAPDEF:
586				foreach my $def ( split( /;/, $typemap_str ) ) {
587				my @defDefined = split /:/, $def;
588				$self->{log}->debug( q{defDefined :} . Dumper( \@defDefined ) );
589				if ( scalar(@defDefined) != 2
590				\|\| !$defDefined[0]
591				\|\| !$defDefined[1] )
592				{
593				$self->{log}->warn("Malformed typemap: $def");
594				next TYPEMAPDEF;
595				}
596
597				# remove leading and trailing whitespace
598				$defDefined[0] =~ s/^\s(\S+)\s$/$1/;
599				$defDefined[1] =~ s/^\s(\S+)\s$/$1/;
600
601				my @typearr = $self->{utils}->split_type( $defDefined[1] );
602
603				# Set typemap key-value for given db type
604				$typemap_href->{$typemap_db}->{ $defDefined[0] } = \@typearr;
605				}
606				}
607				$self->{log}->debug( q{typemap :} . Dumper($typemap_href) );
608
609				return $typemap_href;
610				}
611
612				# Returns hashref where key is name of SmallPackage and value is its
613				# content.
614				sub _parse_smallpackage {
615				my $self = shift;
616				my $smallpackageNode = shift;
617
618				my $nodelist = $smallpackageNode->getElementsByTagName('dia:attribute');
619				$self->{log}->debug( "attributes: " . $nodelist->getLength );
620
621				# parse out the 'stereotype' -- which in this case will be its name
622				my $packName = undef;
623				for ( my $i = 0 ; $i < $nodelist->getLength ; $i++ ) {
624				my $currentNode = $nodelist->item($i);
625				my $nodeAttrName = $currentNode->getAttribute('name');
626				$self->{log}->debug("nodeAttrName :$nodeAttrName");
627
628				if ( $nodeAttrName eq 'stereotype' ) {
629				$packName = $self->{utils}->get_string_from_node($currentNode);
630				$self->{log}->debug("packName:$packName");
631				}
632				elsif ( $nodeAttrName eq 'text' ) {
633				my $packText = $self->{utils}->get_string_from_node($currentNode);
634				$self->{log}->debug("packText:$packText");
635
636				# Create hashref and return it
637				my $href = { $packName => $packText };
638				return $href;
639				}
640				}
641				return; # Error: Did not find 'stereotype' element
642				}
643
644				# Return hashref with parsed classes.
645				sub get_classes_ref {
646				my $self = shift;
647				$self->{log}->warn(qq{The classes ref is undefined!}) if !$self->{classes};
648				#$self->{log}->debug(q{classes:} . Dumper($self->{classes}));
649				return $self->{classes};
650				}
651
652
653
654				# Returns hashref where key is name of class and value is its content.
655				sub _parse_classes {
656				my $self = shift;
657
658				if ( !$self->{nodelists} ) {
659				$self->{log}->warn("nodelists are empty");
660				return;
661				}
662				my $fid = 0; # file sequence number
663
664				foreach my $nodelist ( @{ $self->{nodelists} } ) {
665				$fid++;
666				$self->{log}
667				->debug("nodelist length " . $nodelist->getLength );
668
669				NODE:
670				for ( my $i = 0 ; $nodelist && $i < $nodelist->getLength ; $i++ ) {
671				my $nodeType = $nodelist->item($i)->getNodeType;
672
673				# sanity check -- a dia:object should be an element_node
674				if ( $nodeType == ELEMENT_NODE ) {
675				my $nodeAttrType = $nodelist->item($i)->getAttribute('type');
676				my $nodeAttrId = $nodelist->item($i)->getAttribute('id');
677				my $nodeAttrVersion = $nodelist->item($i)->getAttribute('version');
678
679				$self->{log}->debug("Node $i -- type=$nodeAttrType");
680
681				if ( $nodeAttrType eq $UML_CLASS ) {
682
683				# Check that version is supported
684				if (!$self->{utils}->_check_object_version($UML_CLASS, $nodeAttrVersion)) {
685				$self->{log}->error("Found unsupported version '$nodeAttrVersion' of UML Class");
686				next NODE;
687				}
688
689				# table or view create
690				$self->{log}->debug("$nodeAttrId");
691				my $class = $self->_parse_class( $nodelist->item($i), [$fid, $nodeAttrId, $nodeAttrVersion] );
692
693				push @{$self->{classes}}, $class;
694
695				#$self->{log}->debug("get_class:". Dumper($class));
696				}
697				elsif ( $nodeAttrType eq $UML_COMPONENT ) {
698				$self->{log}->debug("get_component");
699
700				# Check that version is supported
701				if (!$self->{utils}->_check_object_version($UML_COMPONENT, $nodeAttrVersion)) {
702				$self->{log}->error("Found unsupported version '$nodeAttrVersion' of $UML_COMPONENT");
703				next NODE;
704				}
705
706				# insert statements - hash ref where table is key
707				my $component = $self->_parse_component ($nodelist->item($i), [$i, $nodeAttrId]);
708				push @{$self->{components}}, $component if defined($component);
709				} elsif ( $nodeAttrType eq $DATABASE_TABLE ) {
710				$self->{log}->debug("Found '$DATABASE_TABLE'");
711
712				my $class = $self->_parse_database_table( $nodelist->item($i), [$fid, $nodeAttrId, $nodeAttrVersion] );
713
714				push @{$self->{classes}}, $class;
715				}
716				}
717				}
718				}
719				$self->{log}->debug("return");
720				return $self->{classes};
721				}
722
723				# Accessor
724				sub get_components_ref {
725				my $self = shift;
726				return $self->{components};
727				}
728
729
730				# Parse a component and take our what is needed to create inserts.
731				#
732				# Returns a hash reference.
733				sub _parse_component {
734				my $self = shift;
735				my $component = shift;
736				my $id = shift; # it's a array ref..
737
738				my ( $i, $currentNode, $comp_name, $comp_text, $nodeType, $nodeAttrName,
739				$nodeAttrId, $nodeList );
740
741				$nodeList = $component->getElementsByTagName ('dia:attribute');
742
743				# parse out the 'stereotype' -- which in this case will
744				# be its name
745				undef ($comp_name);
746				$i=0;
747
748				# pass 1 to get $comp_name
749				while ($i < $nodeList->getLength && (!$comp_name \|\| !$comp_text)) {
750				$currentNode = $nodeList->item($i);
751				$nodeAttrName = $currentNode->getAttribute ('name');
752
753				if ($nodeAttrName eq 'stereotype') {
754				$comp_name = $self->{utils}->get_string_from_node ($currentNode);
755				$self->{log}->debug(qq{comp_name=$comp_name});
756
757				# Dia <0.9 puts strange characters before & after
758				# the component stereotype
759				if ($self->{diaversion} && $self->{diaversion} < 0.9) {
760				$comp_name =~ s/^&#[0-9]+;//s;
761				$comp_name =~ s/&#[0-9]+;$//s;
762				}
763
764				} elsif ($nodeAttrName eq 'text') {
765				$comp_text = $self->{utils}->get_string_from_node ($currentNode);
766				#if ($verbose) { print "Got text from node... (probably multiline)\n"; }
767
768				# first, get rid of the # starting and ending the text
769				$comp_text =~ s/^#//s;
770				$comp_text =~ s/#$//s;
771				}
772
773				$i++;
774				}
775
776				# Fail unless both name and text are defined
777				if (!$comp_name \|\| !$comp_text) {
778				$self->{log}->error(qq{Component does not have both name and text, not generating SQL});
779				return;
780				}
781
782				# Return a hash ref that represents the component
783				return {name => $comp_name, text => $comp_text};
784				}
785
786
787				# Parse a DATABASE TABLE.
788				#
789				# Returns a hash reference.
790				sub _parse_database_table {
791				my $self = shift;
792				my $class = shift;
793				my $id = shift; # it's a array ref..
794
795				my $warns = 0;
796
797				# get the Class name
798				my $className =
799				$self->{utils}
800				->get_value_from_object( $class, "dia:attribute", "name", "name", "string",
801				0 );
802
803				# determine if this Class is a Table or View
804				my $classAbstract =
805				$self->{utils}
806				->get_value_from_object( $class, "dia:attribute", "name", "abstract",
807				"boolean", 0 );
808				my $classComment =
809				$self->{utils}
810				->get_value_from_object( $class, "dia:attribute", "name", "comment", "string",
811				1 );
812				my $classStereotype =
813				$self->{utils}
814				->get_value_from_object( $class, "dia:attribute", "name", "stereotype",
815				"string", 0 );
816
817				# Dia lacks view support !
818				my $classType = 'table';
819
820				if ( $self->{log}->is_debug() ) {
821				## no critic (ProhibitNoWarnings)
822				no warnings q{uninitialized};
823				$self->{log}
824				->debug("Parsing UML Class name : $className");
825				$self->{log}
826				->debug("Parsing UML Class abstract : $classAbstract");
827				$self->{log}
828				->debug("Parsing UML Class comment : $classComment");
829				$self->{log}
830				->debug("Parsing UML Class stereotype: $classStereotype");
831				$self->{log}
832				->debug("Parsing UML Class type : $classType");
833				}
834
835				my $classLookup = {
836				name => $className, # Class name
837				type => $classType, # Class type table/view
838				comment => $classComment, # Class comment
839				attList => [], # list of attributes
840				atts => {}, # lookup table of attributes
841				pk => [], # list of primary key attributes
842				uindxc => {}, # lookup of unique index column names
843				uindxn => {}, # lookup of unique index names
844				ops => [], # list of operations
845				};
846
847				# get the Class attributes
848				my $attribNode =
849				$self->{utils}
850				->get_node_from_object( $class, "dia:attribute", "name", "attributes", 0 );
851
852				# need name, type, value, and visibility for each
853				foreach
854				my $singleAttrib ( $attribNode->getElementsByTagName("dia:composite") )
855				{
856				my $attribName =
857				$self->{utils}
858				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "name",
859				"string", 0 );
860				my $attribType =
861				$self->{utils}
862				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "type",
863				"string", 0 );
864
865				# NOTE: There is currently not possible to assign a default value
866				# to a column using the database shape in Dia.
867				my $attribVal = '';
868				# $self->{utils}
869				# ->get_value_from_object( $singleAttrib, "dia:attribute", "name", "value",
870				# "string", 0 );
871				my $attrib_is_primary_key =
872				$self->{utils}
873				->get_value_from_object( $singleAttrib, "dia:attribute", "name",
874				"primary_key", "boolean", 0 );
875				# Conform to UML Class encoding (true == 2, false == 0)
876				$attrib_is_primary_key = ($attrib_is_primary_key eq 'true') ? 2 : 0;
877
878				my $attribComment =
879				$self->{utils}
880				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "comment",
881				"string", 1 );
882
883				my $attribNullable =
884				$self->{utils}
885				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "nullable",
886				"boolean", 1 );
887
888				# Strip newlines from comments except for HTML output
889				$attribComment =~ s/\n/ /g if ($self->{db} ne q{html});
890				chomp($attribComment); # Always strip any trailing newlines
891
892				$self->{log}->debug(
893				"attribute: $attribName - $attribType - $attribVal - $attrib_is_primary_key"
894				);
895				my $att = [
896				$attribName, $attribType, $attribVal,
897				$attrib_is_primary_key, $attribComment, $attribNullable
898				];
899				push @{ $classLookup->{attList} }, $att;
900
901				# Set up symbol table info in the class lookup
902				$classLookup->{atts}{ $self->{utils}->name_case($attribName) } = $att;
903				push @{ $classLookup->{pk} }, $att
904				if ( $attrib_is_primary_key );
905				}
906
907				$self->{log}->debug( "returning " . Dumper($classLookup) );
908				return $classLookup;
909				}
910
911				# Parse a CLASS and salt away the information needed to generate its SQL
912				# DDL.
913				#
914				# Returns a hash reference.
915				sub _parse_class {
916				my $self = shift;
917				my $class = shift;
918				my $id = shift; # it's a array ref..
919
920				my $warns = 0;
921
922				# get the Class name
923				my $className =
924				$self->{utils}
925				->get_value_from_object( $class, "dia:attribute", "name", "name", "string",
926				0 );
927
928				# determine if this Class is a Table or View
929				my $classAbstract =
930				$self->{utils}
931				->get_value_from_object( $class, "dia:attribute", "name", "abstract",
932				"boolean", 0 );
933				my $classComment =
934				$self->{utils}
935				->get_value_from_object( $class, "dia:attribute", "name", "comment", "string",
936				1 );
937				my $classStereotype =
938				$self->{utils}
939				->get_value_from_object( $class, "dia:attribute", "name", "stereotype",
940				"string", 0 );
941				my $classType;
942				if ( $classAbstract eq 'true' ) {
943				$classType = 'view';
944				}
945				else {
946				$classType = 'table';
947				}
948
949				if ( $self->{log}->is_debug() ) {
950				## no critic (ProhibitNoWarnings)
951				no warnings q{uninitialized};
952				$self->{log}
953				->debug("Parsing UML Class name : $className");
954				$self->{log}
955				->debug("Parsing UML Class abstract : $classAbstract");
956				$self->{log}
957				->debug("Parsing UML Class comment : $classComment");
958				$self->{log}
959				->debug("Parsing UML Class stereotype: $classStereotype");
960				$self->{log}
961				->debug("Parsing UML Class type : $classType");
962				}
963
964				if ( $self->{utils}->name_case($classStereotype) eq
965				$self->{utils}->name_case("placeholder") )
966				{
967
968				# it's merely a placeholder - it's not allowed attributes or operations
969				my $attribNode =
970				$self->{utils}
971				->get_node_from_object( $class, "dia:attribute", "name", "attributes", 0 );
972				my $operNode =
973				$self->{utils}
974				->get_node_from_object( $class, "dia:attribute", "name", "operations", 0 );
975				$self->{log}
976				->logdie("Class $className has placeholder with attributes or operations")
977				if ( $attribNode->getElementsByTagName("dia:composite")->getLength() > 0
978				\|\| $operNode->getElementsByTagName("dia:composite")->getLength() > 0 );
979
980				# Record the placeholder's name against its ID; refers will be the
981				# id of the class to actually use; to be filled in later
982				$self->{umlClassPlaceholder}{ $id->[0] }{ $id->[1] } = {
983				name => $className,
984				refers => -1
985				};
986				$self->{log}->logdie("TODO: placeholder");
987				return $warns == 0;
988				}
989
990				# Associations will need this associative array to understand
991				# what their endpoints are connected to and to find its
992				# key(s)
993				my $classLookup = {
994				name => $className, # Class name
995				type => $classType, # Class type table/view
996				comment => $classComment, # Class comment
997				attList => [], # list of attributes
998				atts => {}, # lookup table of attributes
999				pk => [], # list of primary key attributes
1000				uindxc => {}, # lookup of unique index column names
1001				uindxn => {}, # lookup of unique index names
1002				ops => [], # list of operations
1003				};
1004
1005				$self->{umlClassLookup}->{$id->[0]}{$id->[1]} = $classLookup;
1006
1007				# get the Class attributes
1008				my $attribNode =
1009				$self->{utils}
1010				->get_node_from_object( $class, "dia:attribute", "name", "attributes", 0 );
1011
1012				# need name, type, value, and visibility for each
1013				foreach
1014				my $singleAttrib ( $attribNode->getElementsByTagName("dia:composite") )
1015				{
1016				my $attribName =
1017				$self->{utils}
1018				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "name",
1019				"string", 0 );
1020				my $attribType =
1021				$self->{utils}
1022				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "type",
1023				"string", 0 );
1024				my $attribVal =
1025				$self->{utils}
1026				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "value",
1027				"string", 0 );
1028				my $attribVisibility =
1029				$self->{utils}
1030				->get_value_from_object( $singleAttrib, "dia:attribute", "name",
1031				"visibility", "number", 0 );
1032				my $attribComment =
1033				$self->{utils}
1034				->get_value_from_object( $singleAttrib, "dia:attribute", "name", "comment",
1035				"string", 1 );
1036
1037				# Strip newlines from comments except for HTML output
1038				$attribComment =~ s/\n/ /g if ($self->{db} ne q{html});
1039				chomp($attribComment); # Always strip any trailing newlines
1040
1041				$self->{log}->debug(
1042				"attribute: $attribName - $attribType - $attribVal - $attribVisibility"
1043				);
1044				my $att = [
1045				$attribName, $attribType, $attribVal,
1046				$attribVisibility, $attribComment
1047				];
1048				push @{ $classLookup->{attList} }, $att;
1049
1050				# Set up symbol table info in the class lookup
1051				$classLookup->{atts}{ $self->{utils}->name_case($attribName) } = $att;
1052				push @{ $classLookup->{pk} }, $att
1053				if ( $attribVisibility && $attribVisibility eq 2 );
1054				}
1055
1056				# get the Class operations
1057				my $operationDescs = [];
1058				my $operNode =
1059				$self->{utils}
1060				->get_node_from_object( $class, "dia:attribute", "name", "operations", 0 );
1061
1062				# need name, type, (parameters...)
1063				foreach
1064				my $singleOperation ( $operNode->getElementsByTagName("dia:composite") )
1065				{
1066				my $paramString = "";
1067
1068				# only parse umloperation dia:composites
1069				if ( $singleOperation->getAttributes->item(0)->toString eq
1070				'type="umloperation"' )
1071				{
1072				my $operName =
1073				$self->{utils}
1074				->get_value_from_object( $singleOperation, "dia:attribute", "name", "name",
1075				"string", 0 );
1076				my $operType =
1077				$self->{utils}
1078				->get_value_from_object( $singleOperation, "dia:attribute", "name", "type",
1079				"string", 0 );
1080				my $operTemplate =
1081				$self->{utils}
1082				->get_value_from_object( $singleOperation, "dia:attribute", "name",
1083				"stereotype", "string", 0 )
1084				\|\| '';
1085				my $operComment =
1086				$self->{utils}
1087				->get_value_from_object( $singleOperation, "dia:attribute", "name",
1088				"comment", "string", 1 );
1089				my $operParams =
1090				$self->{utils}
1091				->get_node_from_object( $singleOperation, "dia:attribute", "name",
1092				"parameters", 0 );
1093				my @paramList = $singleOperation->getElementsByTagName("dia:composite");
1094				my $paramCols = [];
1095				my $paramDescs = [];
1096
1097				foreach my $singleParam (@paramList) {
1098				my $paramName =
1099				$self->{utils}
1100				->get_value_from_object( $singleParam, "dia:attribute", "name", "name",
1101				"string", 0 );
1102				if ( $operType =~ /index/
1103				&& !$classLookup->{atts}{ $self->{utils}->name_case($paramName) } )
1104				{
1105				$self->{log}
1106				->warn("Index $operName references undefined attribute $paramName");
1107
1108				#$warns++; $errors++;
1109				next;
1110				}
1111				push @$paramDescs, $paramName;
1112				push @$paramCols,
1113				[
1114				$paramName,
1115				$classLookup->{atts}{ $self->{utils}->name_case($paramName) }[1]
1116				];
1117				}
1118
1119				$self->{log}->debug(
1120				"Got operation: $operName / $operType / ($paramString) / ($operTemplate)"
1121				);
1122				push @$operationDescs,
1123				[ $operName, $operType, $paramDescs, $operTemplate, $operComment ];
1124
1125				# Set up the index symbol table info in the class lookup
1126				$operType =~ s/\s//g; # clean up any spaces in the type
1127				if ( $self->{utils}->name_case($operType) eq
1128				$self->{utils}->name_case('uniqueindex') )
1129				{
1130				$classLookup->{uindxn}{ $self->{utils}->name_case($operName) } =
1131				$paramCols;
1132				$classLookup->{uindxc}{ $self->{utils}->name_case($paramString) } =
1133				$paramCols;
1134				}
1135				}
1136				$classLookup->{ops} = $operationDescs;
1137				}
1138
1139				$self->{log}->debug( "returning " . Dumper($classLookup) );
1140				return $classLookup;
1141				}
1142
1143				# Return hashref with parsed associations.
1144				sub get_associations_ref {
1145				my $self = shift;
1146				return $self->{fk_defs};
1147				}
1148
1149
1150				# Scan the nodeList for UML Associations and return them.
1151				sub _parse_associations {
1152				my $self = shift;
1153				my $fid = 0; # file sequence number
1154
1155				my $assocErrs = 0;
1156				foreach my $nodelist ( @{ $self->{nodelists} } ) {
1157				$fid++;
1158
1159				for ( my $i = 0 ; $i < $nodelist->getLength ; $i++ ) {
1160				my $nodeType = $nodelist->item($i)->getNodeType;
1161
1162				# sanity check -- a dia:object should be an element_node
1163				if ( $nodeType == ELEMENT_NODE ) {
1164				my $nodeAttrType = $nodelist->item($i)->getAttribute('type');
1165				my $nodeAttrId = $nodelist->item($i)->getAttribute('id');
1166				my $nodeAttrVersion = $nodelist->item($i)->getAttribute('version');
1167
1168				if ( $nodeAttrType eq $UML_ASSOCIATION ) {
1169				$self->{log}->debug("Association Node $i -- type=$nodeAttrType id=$nodeAttrId version=$nodeAttrVersion");
1170
1171				# Note that version number is passed since there was a
1172				# change in Dia 0.97
1173
1174				# TODO: Check return value:
1175				$self->_parse_association( $nodelist->item($i), [ $fid, $nodeAttrId, $nodeAttrVersion ] )
1176				}
1177				}
1178
1179				}
1180				}
1181
1182				return $self->{fk_defs};
1183				}
1184
1185				# Generate the foreign key relationship between two tables: classify
1186				# the relationship, and generate the necessary constraints and centre
1187				# (join) tables.
1188				#
1189				# Note that version number is passed as an argument (in '$id') since
1190				# there was a change in Dia 0.97. This is implemented in dia source
1191				# file:
1192				#
1193				# objects/UML/association.c
1194				#
1195				# /* Version 0 had no autorouting and so shouldn't have it set by default. */
1196				# /* Version 1 was saving both ends separately without using StdProps */
1197				# /* Version 2 uses StdProps */
1198				#
1199				# Note on misspelling of "multipicity"
1200				#
1201				# http://mail.gnome.org/archives/dia-list/2009-March/msg00067.html
1202				# [Hans Breuer] "Sorry, typos in property names must stay forever to
1203				# not break backward compatibility with older diagrams."
1204
1205				sub _parse_association {
1206				my $self = shift;
1207				my $association = shift;
1208				my $id = shift; # it's an array ref..
1209
1210				my ( $i, $currentNode, $assocName, $assocDirection, $nodeType, $nodeAttrName,
1211				$nodeAttrId, $nodeList );
1212				my ( %leftEnd, %rightEnd, $connectionNode, $leftConnectionHandle,
1213				$rightConnectionHandle );
1214
1215				my $version = $id->[2];
1216				$self->{log}->debug("Parsing UML Association file=$id->[0] id=$id->[1] version=$version");
1217
1218				# Check that version is supported
1219				if (!$self->{utils}->_check_object_version($UML_ASSOCIATION, $version)) {
1220				$self->{log}->error("Found unsupported version '$version' of $UML_ASSOCIATION");
1221				return;
1222				}
1223
1224				$nodeList = $association->getElementsByTagName('dia:attribute');
1225
1226				# parse out the name, direction, and ends
1227				undef($assocName);
1228				$i = 0;
1229				while ( $i < $nodeList->getLength ) {
1230				$currentNode = $nodeList->item($i);
1231				$nodeAttrName = $currentNode->getAttribute('name');
1232
1233				$self->{log}->debug( "version:$version nodeAttrName:$nodeAttrName" );
1234
1235				# version 1 : Dia 0.96 or prior
1236				if ($version == 1) {
1237
1238				if ( $nodeAttrName eq 'name' ) {
1239				$assocName = $self->{utils}->get_string_from_node($currentNode);
1240				$self->{log}->debug("Got association name=$assocName");
1241				} elsif ( $nodeAttrName eq 'direction' ) {
1242				$assocDirection = $self->{utils}->get_num_from_node($currentNode);
1243				} elsif ( $nodeAttrName eq 'ends' ) {
1244				my @tags = ( 'arole', '9aggregate', 'bclass_scope', 'amultiplicity' );
1245				%leftEnd = $self->{utils}->get_node_attribute_values(
1246				$association->getElementsByTagName('dia:composite')->item(0), @tags );
1247				%rightEnd = $self->{utils}->get_node_attribute_values(
1248				$association->getElementsByTagName('dia:composite')->item(1), @tags );
1249
1250				}
1251				}
1252
1253				# version 2 : Dia 0.97 or later - Note (mis)spelling of 'multipicity':
1254				elsif ( $version == 2 ) {
1255				$self->{log}->debug("version 2 : Dia 0.97 nodeAttrName:$nodeAttrName ") if $self->{log}->is_debug();
1256				if ( $nodeAttrName eq 'name' ) {
1257				$assocName = $self->{utils}->get_string_from_node($currentNode);
1258				$self->{log}->debug("Got association name=$assocName");
1259				} elsif ( $nodeAttrName eq 'direction' ) {
1260				$assocDirection = $self->{utils}->get_num_from_node($currentNode);
1261				} elsif ( $nodeAttrName eq 'role_a' ) {
1262				$leftEnd{role} = $self->{utils}->get_string_from_node($currentNode);
1263				} elsif ( $nodeAttrName eq 'role_b' ) {
1264				$rightEnd{role} = $self->{utils}->get_string_from_node($currentNode);
1265				} elsif ( $nodeAttrName eq 'assoc_type' ) {
1266				$leftEnd{aggregate} = $self->{utils}->get_num_from_node($currentNode);
1267				} elsif ( $nodeAttrName eq 'class_scope_a' ) {
1268				$leftEnd{class_scope} = $self->{utils}->get_string_from_node($currentNode);
1269				} elsif ( $nodeAttrName eq 'class_scope_b' ) {
1270				$rightEnd{class_scope} = $self->{utils}->get_string_from_node($currentNode);
1271				} elsif ( $nodeAttrName =~ qr/^multip[l]?icity_a$/ ) { ### Spelling !!!
1272				$leftEnd{multiplicity} = $self->{utils}->get_string_from_node($currentNode);
1273				} elsif ( $nodeAttrName =~ qr/^multip[l]?icity_b$/ ) { ### Spelling !!!
1274				$rightEnd{multiplicity} = $self->{utils}->get_string_from_node($currentNode);
1275				}
1276
1277				} else {
1278				$self->{log}->fatal("Unsupported $UML_ASSOCIATION version $version");
1279				}
1280
1281				$i++;
1282				}
1283
1284				# apply aggregate attribute to proper Left/Right End. currently it
1285				# is stored in LeftEnd.
1286				if ( $version == 2 ) {
1287				if ( $self->{uml} ) {
1288				$rightEnd{aggregate} = delete $leftEnd{aggregate}
1289				unless $assocDirection == 2;
1290				}
1291
1292				else {
1293				$rightEnd{aggregate} = delete $leftEnd{aggregate}
1294				if $assocDirection == 2;
1295				}
1296				}
1297
1298				# parse out the 'connections', that is, the classes on either end
1299				$connectionNode =
1300				$association->getElementsByTagName('dia:connections')->item(0);
1301
1302				$leftConnectionHandle =
1303				$connectionNode->getElementsByTagName('dia:connection')->item(0);
1304				$rightConnectionHandle =
1305				$connectionNode->getElementsByTagName('dia:connection')->item(1);
1306
1307				# Get the classes' object IDs
1308
1309				$leftConnectionHandle = $leftConnectionHandle->getAttribute('to')
1310				if ($leftConnectionHandle);
1311				$rightConnectionHandle = $rightConnectionHandle->getAttribute('to')
1312				if ($rightConnectionHandle);
1313
1314				# Check that the association is connected at both ends
1315				if ( !( $leftConnectionHandle && $rightConnectionHandle ) ) {
1316				my $goodEnd;
1317				$goodEnd = $leftConnectionHandle if ($leftConnectionHandle);
1318				$goodEnd = $rightConnectionHandle if ($rightConnectionHandle);
1319				$goodEnd = $self->uml_class_lookup( [ $id->[0], $goodEnd ] )->{name}
1320				if ($goodEnd);
1321				$self->{log}->warn("Association "
1322				. ( $assocName ? $assocName : "" )
1323				. (
1324				$goodEnd
1325				? " only connected at one end - " . $goodEnd
1326				: " not connected at either end"
1327				));
1328				$self->{log}->warn("foreign key constraint not created");
1329				return;
1330				}
1331
1332				my $leftMult = $self->{utils}->classify_multiplicity( $leftEnd{'multiplicity'} );
1333				my $rightMult = $self->{utils}->classify_multiplicity( $rightEnd{'multiplicity'} );
1334
1335				if ($self->{log}->is_debug()) {
1336				no warnings 'uninitialized';
1337				$self->{log}->debug("leftEnd : ".Dumper(\%leftEnd));
1338				$self->{log}->debug("rightEnd: ".Dumper(\%rightEnd));
1339
1340				$self->{log}->debug(
1341				" * (UNUSED) direction=$assocDirection (aggregate determines many end)");
1342				$self->{log}->debug( " * leftEnd="
1343				. $leftEnd{'role'} . " agg="
1344				. $leftEnd{'aggregate'}
1345				. " classId="
1346				. $leftConnectionHandle );
1347				$self->{log}->debug( " * rightEnd="
1348				. $rightEnd{'role'} . " agg="
1349				. $rightEnd{'aggregate'}
1350				. " classId="
1351				. $rightConnectionHandle );
1352
1353
1354				$self->{log}->debug("leftMult : $leftMult");
1355				$self->{log}->debug("rightMult : $rightMult");
1356				}
1357
1358				# Get primary key end in one-to-n (incl 1-to-1) associations
1359				# The encoding for this is different between default ERD mode and UML mode
1360				my $pkSide = 'none';
1361				my $arity;
1362				if ( ( $self->{uml} ? $rightEnd{'aggregate'} : $leftEnd{'aggregate'} )
1363				\|\| $self->{uml} && $rightMult =~ '^z?one$' && $leftMult =~ /^z?many$/ )
1364				{
1365
1366				# Right side is 'one' end; one-to-many
1367				$pkSide = 'right';
1368				$arity = 'zmany';
1369				}
1370				elsif ( ( $self->{uml} ? $leftEnd{'aggregate'} : $rightEnd{'aggregate'} )
1371				\|\| $self->{uml} && $leftMult =~ '^z?one$' && $rightMult =~ /^z?many$/ )
1372				{
1373
1374				# Left side is 'one' end; one-to-many
1375				$pkSide = 'left';
1376				$arity = 'zmany';
1377				}
1378				elsif ( $assocDirection eq 1
1379				&& ( !$self->{uml} \|\| ( $rightMult eq 'one' && $leftMult =~ /^z?one$/ ) ) )
1380				{
1381
1382				# Right side is 'one' end; one-to-zero-or-one
1383				$pkSide = 'right';
1384				$arity = 'zone';
1385				}
1386				elsif ( $assocDirection eq 2
1387				&& ( !$self->{uml} \|\| ( $leftMult eq 'one' && $rightMult =~ /^z?one$/ ) ) )
1388				{
1389
1390				# Left side is 'one' end; one-to-zero-or-one
1391				$pkSide = 'left';
1392				$arity = 'zone';
1393				}
1394
1395				my $leftClass = $self->uml_class_lookup( [ $id->[0], $leftConnectionHandle ] );
1396				my $rightClass = $self->uml_class_lookup( [ $id->[0], $rightConnectionHandle ] );
1397
1398				my $ok = 0;
1399
1400				if ( $pkSide ne 'none' ) {
1401
1402				# If the classification above succeeded, generate the
1403				# keys (if needed) and the FK constraints for a one-to-
1404				# association
1405				$ok = $self->generate_one_to_any_association(
1406				$assocName, $pkSide, $arity, $leftClass,
1407				\%leftEnd, $rightClass, \%rightEnd
1408				);
1409				}
1410				elsif ( ( $self->{uml} \|\| $assocDirection eq 0 )
1411				&& $leftMult =~ /^z?many$/
1412				&& $rightMult =~ /^z?many$/ )
1413				{
1414
1415				# If the classification above failed, and the association is
1416				# many-to-many; generate the centre (join) table, its constraints
1417				# and the classes' primary keys (if needed)
1418				$ok = $self->generate_many_to_many_association(
1419				$assocName, $leftClass, $rightEnd{'role'},
1420				$rightClass, $leftEnd{'role'}
1421				);
1422				}
1423				else {
1424				$self->{log}->warn(
1425				"Couldn't classify $leftClass->{name}:$rightClass->{name} to generate SQL: $leftMult:$rightMult");
1426				$ok = 0;
1427				}
1428
1429				$self->{log}->debug(
1430				"Classified $leftClass->{name}:$rightClass->{name} to generate SQL: $leftMult:$rightMult") if $self->{log}->is_debug();
1431
1432				# $errors++ if ( !$ok );
1433
1434				return $ok;
1435				}
1436
1437				# Look up a class given the XML id of the class, taking into account
1438				# placeholder classes.
1439				sub uml_class_lookup {
1440				my $self = shift;
1441				my $id = shift;
1442
1443				if ( my $placeHolder = $self->{umlClassPlaceholder}{ $id->[0] }{ $id->[1] } )
1444				{
1445				$self->{log}->debug(
1446				"Map reference to {$id->[0]}{$id->[1]} to ",
1447				$placeHolder->{refers},
1448				" (", $placeHolder->{name}, ")"
1449				);
1450				$id = $placeHolder->{refers};
1451				}
1452				return $self->{umlClassLookup}{ $id->[0] }{ $id->[1] };
1453				}
1454
1455
1456				# Generate SQL for a many to many association including generating the
1457				# centre (join) table.
1458				sub generate_many_to_many_association {
1459				my $self = shift;
1460				my $assocName = shift;
1461				my $leftClassLookup = shift;
1462				my $leftRole = shift;
1463				my $rightClassLookup = shift;
1464				my $rightRole = shift;
1465
1466				$self->{log}->debug("generate_many_to_many_association: assocName: $assocName");
1467				$self->{log}->debug("generate_many_to_many_association: leftClassLookup->{name}: ".$leftClassLookup->{name} );
1468				$self->{log}->debug("generate_many_to_many_association: leftRole: $leftRole");
1469				$self->{log}->debug("generate_many_to_many_association: rightClassLookup->{name}: ".$rightClassLookup->{name} );
1470				$self->{log}->debug("generate_many_to_many_association: rightRole: $rightRole");
1471
1472				my @centreCols;
1473				my ( $leftFKName, $rightFKName );
1474				my ( $leftEndCols, $rightEndCols );
1475				my ( $leftFKCols, $rightFKCols );
1476
1477				if ( $leftClassLookup->{type} ne 'table'
1478				\|\| $rightClassLookup->{type} ne 'table' )
1479				{
1480				$self->{log}->warn( "View in $assocName"
1481				. " ($leftClassLookup->{name},$rightClassLookup->{name} ne 'table')"
1482				. ": Many-to-many associations are only supported between tables");
1483				# $errors++;
1484				return;
1485				}
1486
1487				# Generate the centre (join) table name if the user hasn't specified one
1488
1489				$assocName =
1490				$self->{utils}->make_name( 0, $leftClassLookup->{name}, $rightClassLookup->{name}, $self->{db} )
1491				if ( !$assocName );
1492
1493				# Build the centre table for the left (A) end of the association
1494
1495				if (
1496				!$self->add_centre_cols(
1497				$assocName, \@centreCols, $leftRole, $rightRole,
1498				\$leftFKName, \$leftFKCols, \$leftEndCols, $leftClassLookup
1499				)
1500				)
1501				{
1502				$self->{log}->debug("add_centre_cols return false - returning");
1503				return;
1504				}
1505
1506				# Build the centre table for the right (B) end of the association
1507
1508				if (
1509				!$self->add_centre_cols(
1510				$assocName, \@centreCols, $rightRole, $leftRole,
1511				\$rightFKName, \$rightFKCols, \$rightEndCols, $rightClassLookup
1512				)
1513				)
1514				{
1515				$self->{log}->debug("add_centre_cols return false - returning");
1516				return;
1517				}
1518
1519				# Make the association table
1520				$self->{log}->debug("Call gen_table_view_sql assocName=$assocName");
1521
1522				$self->gen_table_view_sql(
1523				$assocName,
1524				"table",
1525				"Association between $leftClassLookup->{name}"
1526				. " and $rightClassLookup->{name}",
1527				[@centreCols],
1528				[]
1529				);
1530
1531				# generate the constraint code:
1532				# foreign key -> referenced attribute
1533				$self->{log}->debug("Call save_foreign_key (left to right)");
1534
1535				$self->save_foreign_key(
1536				$assocName, ## From table
1537				$leftFKName, ## name of foreign key constraint
1538				$leftFKCols, ## foreign key column in assoc tbl
1539				$leftClassLookup->{name}, ## Table referenced
1540				$leftEndCols, ## Column in table referenced
1541				'on delete cascade' ## Trash when no longer referenced
1542				);
1543
1544				# generate the constraint code:
1545				# referenced attribute <- foreign key
1546				$self->{log}->debug("Call save_foreign_key (right to left)");
1547
1548				$self->save_foreign_key($assocName, $rightFKName, $rightFKCols,
1549				$rightClassLookup->{name},
1550				$rightEndCols, 'on delete cascade');
1551
1552				return 1;
1553				}
1554
1555				# Create datastructure that represents given Table or View SQL and
1556				# store in classes reference.
1557				sub gen_table_view_sql {
1558				my $self = shift;
1559				my $objectName = shift;
1560				my $objectType = shift;
1561				my $objectComment = shift;
1562				my $objectAttributes = shift;
1563				my $objectOperations = shift;
1564
1565				my $classLookup = {
1566				name => $objectName, # Object name
1567				type => $objectType, # Object type table/view
1568				attList => $objectAttributes, # list of attributes
1569				atts => $objectAttributes, # lookup table of attributes
1570				pk => [], # list of primary key attributes
1571				uindxc => {}, # lookup of unique index column names
1572				uindxn => {}, # lookup of unique index names
1573				ops => $objectOperations, # list of operations
1574				};
1575
1576				# Push this generated table to classes array
1577				push @{ $self->{classes} }, $classLookup;
1578
1579				$self->{log}->debug("classes: ".Dumper($self->{classes}));
1580
1581				return 1;
1582				}
1583
1584				# Add column descriptors for a centre (join) table to an array of
1585				# descriptors passed.
1586				sub add_centre_cols {
1587				my $self = shift;
1588				my $assocName = shift; # For warning messages & constructing constraint name
1589				my $cols = shift; # Where to add column descriptors
1590				my $pkRole = shift; # Names for the PK end
1591				my $fkRole = shift; # Names for the FK end
1592				my $fkCName = shift; # Assemble FK constraint name here
1593				my $fkColNames = shift; # Assemble FK column names here
1594				my $pkColNames = shift; # Assemble PK column names here
1595				my $classDesc = shift; # Class lookup descriptor
1596
1597				my $className = $classDesc->{name}; # Name of target class
1598				my $pk = $classDesc->{pk}; # List of primary key attributes
1599				my $uin = $classDesc->{uindxn}; # List of unique index by name
1600				my $uic = $classDesc->{uindxc}; # List of unique index by column names
1601
1602				my ( undef, $pkRoleNames ) = split( /\s:\s/, $pkRole );
1603				my ( $fkRoleNames, undef ) = split( /\s:\s/, $fkRole );
1604
1605				my $pkAtts = $pk;
1606
1607				# Use user-supplied names for the primary key if given
1608
1609				if ($pkRoleNames) {
1610				$pkRoleNames =~ s/\s//g;
1611				my $pkNames = $self->{utils}->names_from_attlist($pk);
1612				if ( $self->{utils}->name_case($pkNames) eq
1613				$self->{utils}->name_case($pkRoleNames) )
1614				{
1615
1616				# It's an explicit reference to the primary key
1617				$pkAtts = $pk;
1618				}
1619				else {
1620
1621				# Try a unique index
1622				if ( !( $pkAtts = $uin->{$pkRoleNames} )
1623				&& !( $pkAtts = $uic->{$pkRoleNames} ) )
1624				{
1625				$self->{log}->warn(
1626				"In association $assocName $pkRoleNames doesn't refer to a primary key or unique index");
1627				return 0;
1628				}
1629				}
1630				}
1631
1632				# If there was no user-supplied PK name, but PK generation is allowed, do it
1633
1634				if ( $self->{default_pk} && !@$pkAtts && $classDesc->{type} eq 'table' ) {
1635				$self->{utils}->add_default_pk( $classDesc, '' );
1636				$pkAtts = $classDesc->{pk};
1637				}
1638
1639				# No primary key (or unique index) suitable
1640				if ( @$pkAtts == 0 ) {
1641				$self->{log}->warn(
1642				"Association $assocName referenced class $classDesc->{name} must have a primary key");
1643				return 0;
1644				}
1645
1646				my @pkCols;
1647				my @fkCols;
1648				my $pk0;
1649				my @fkCNames;
1650
1651				# If the user supplied foreign key names, use them
1652				if ($fkRoleNames) {
1653				@fkCNames = split /\s,\s/, $fkRoleNames;
1654				if ( @fkCNames != @$pkAtts ) {
1655				$self->{log}->warn(
1656				"Association $assocName $fkRoleNames has the wrong number of attributes");
1657				return 0;
1658				}
1659				}
1660
1661				# Generate the columns in the centre (join) table
1662
1663				foreach my $i ( 0 .. $#{$pkAtts} ) {
1664				my $pkFld = $pkAtts->[$i];
1665				$pk0 = $pkFld->[0] if ( !$pk0 );
1666				my $colName =
1667				$fkRoleNames
1668				? $fkCNames[$i]
1669				: $self->{utils}->make_name( 1, $className, $pkFld->[0] );
1670				push @fkCols, $colName;
1671
1672				# The generated columns in the centre (join) table take the
1673				# type of the corresponding PK, and are part of centre table's
1674				# primary key (2==protected for the visibility).
1675				push @$cols, [ $colName, $pkFld->[1], '', 2, '' ];
1676
1677				# Build the list of PK names
1678				push @pkCols, $pkFld->[0];
1679				}
1680				$$pkColNames = join ',', @pkCols if ( !$$pkColNames );
1681				$$fkColNames = join ',', @fkCols;
1682				$$fkCName =
1683				$self->{utils}->make_name( 1, $assocName, '_fk_', $className, $pk0 );
1684				return 1;
1685				}
1686
1687
1688				# Generate data for SQL generation for an association where one side has
1689				# multiplicity one; no additional table is necessary.
1690				sub generate_one_to_any_association {
1691				my $self = shift;
1692				my $userAssocName = shift;
1693				my $pkSide = shift;
1694				my $arity = shift;
1695				my $pkClassLookup = shift;
1696				my $pkEnd = shift;
1697				my $fkClassLookup = shift;
1698				my $fkEnd = shift;
1699
1700				# The caller used 'left' and 'right'; change this to
1701				# primary key/foreign key side of the association
1702
1703				if ( $pkSide eq 'right' ) {
1704				my $tClassLookup = $pkClassLookup;
1705				my $tEnd = $pkEnd;
1706				$pkClassLookup = $fkClassLookup;
1707				$pkEnd = $fkEnd;
1708				$fkClassLookup = $tClassLookup;
1709				$fkEnd = $tEnd;
1710				}
1711
1712				# MAke the association name if necessary
1713
1714				my $assocName = $userAssocName;
1715				if ( !$assocName ) {
1716				$assocName = $self->{utils}->make_name( 0, $pkClassLookup->{name}, $fkClassLookup->{name} );
1717				}
1718
1719				# Classify the multiplicity (if given) of the ends of the association
1720
1721				my $pkMult =
1722				$self->{utils}->classify_multiplicity( $pkEnd->{'multiplicity'} );
1723				my $fkMult =
1724				$self->{utils}->classify_multiplicity( $fkEnd->{'multiplicity'} );
1725
1726				# By default, foreign keys are constrained to be 'not null'
1727				my $defFKnull = 'not null';
1728
1729				# Work out the constraint action for the foreign key
1730				my $constraintAction = '';
1731				if ( $self->{uml} ) {
1732
1733				# UML interpretation
1734
1735				# Only one of the left and right end aggregation can be
1736				# non-zero; 1 = aggregation, 2 = composition.
1737				my $aggregation = $pkEnd->{'aggregate'} + $fkEnd->{'aggregate'};
1738				if ( $aggregation == 0 ) { # No semantics specified
1739				$constraintAction = '';
1740				}
1741				elsif ( $aggregation == 1 ) { # Aggregation
1742				$constraintAction = 'on delete set NULL';
1743				$defFKnull = 'null';
1744				}
1745				elsif ( $aggregation == 2 ) { # Composition
1746				$constraintAction = 'on delete cascade';
1747				}
1748				}
1749				else {
1750
1751				# ERD interpretation
1752
1753				# If Utils::classify_multiplicity didn't understand the multiplicity
1754				# field, then assume it's a constraint action, and set the
1755				# multiplicity classification to 'none'
1756
1757				if ( $fkMult eq 'undef' ) {
1758				$constraintAction = $fkEnd->{'multiplicity'};
1759				$fkMult = 'none';
1760				}
1761
1762				# If the constraint action is 'on delete set null', then
1763				# allow the FK to have null value
1764
1765				if ( $constraintAction =~ /on\s+delete\s+set\s+null/i ) {
1766				$defFKnull = 'null';
1767				}
1768
1769				# tedia2sql v1.2.9b usage of 'on delete clause'
1770				# The 'on cascade delete' clauses were on opposite ends of
1771				# the association for one-to-many and one-to-one for ERD mode!
1772				# if ($arity eq 'zmany' && $fkMult eq 'undef') {
1773				# $constraintAction = $fkEnd->{'multiplicity'};
1774				# $fkMult = 'none';
1775				# } elsif ($arity eq 'zone' && $pkMult eq 'undef') {
1776				# $constraintAction = $pkEnd->{'multiplicity'};
1777				# $pkMult = 'none';
1778				# }
1779				}
1780
1781				# If the arity implied by the association is one-to-many, set the
1782				# arity classifications appropriately if they weren't given
1783
1784				if ( $arity eq 'zmany' ) {
1785				$pkMult = 'one' if ( $pkMult eq 'none' );
1786				$fkMult = 'zmany' if ( $fkMult eq 'none' );
1787				if (
1788				$pkMult ne 'one'
1789				\|\| $self->{uml}
1790				? $fkMult !~ /^z?(many\|one)$/
1791				: $fkMult !~ /^z?many$/
1792				)
1793				{
1794				$self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
1795				. " specified in $assocName");
1796				return 0;
1797				}
1798				}
1799				elsif ( $arity eq 'zone' ) {
1800				$pkMult = 'one' if ( $pkMult eq 'none' );
1801				$fkMult = 'zone' if ( $fkMult eq 'none' );
1802				if ( $pkMult ne 'one'
1803				\|\| $fkMult !~ /^z?one$/ )
1804				{
1805				$self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
1806				. " specified in $assocName");
1807				return 0;
1808				}
1809				}
1810
1811				$defFKnull = 'null' if ( $pkMult =~ /^z(many\|one)$/ );
1812
1813				# Generate names if they haven't been specified
1814				my $pkEndKey = $pkEnd->{'role'};
1815				my $fkEndKey = $fkEnd->{'role'};
1816				my $pkPK = $pkClassLookup->{pk}; # List of primary key attributes
1817				my $pkUIn = $pkClassLookup->{uindxn}; # List of unique index descriptors
1818				my $pkUIc = $pkClassLookup->{uindxc}; # List of unique index descriptors
1819				my $pkAtts = undef;
1820				my $fkAtts = undef;
1821
1822				if ($pkEndKey) {
1823
1824				# Use user-supplied names for the primary key if given
1825
1826				if ( $pkClassLookup->{type} eq 'table' ) {
1827				$pkEndKey =~ s/\s//g;
1828				my $pkNames = $self->{utils}->names_from_attlist($pkPK);
1829				if ( $self->{utils}->name_case($pkNames) eq
1830				$self->{utils}->name_case($pkEndKey) )
1831				{
1832
1833				# It's an explicit reference to the primary key
1834				$pkAtts = $pkPK;
1835				}
1836				else {
1837
1838				# Try a unique index
1839				if ( !( $pkAtts = $pkUIn->{ $self->{utils}->name_case($pkEndKey) } )
1840				&& !( $pkAtts = $pkUIc->{ $self->{utils}->name_case($pkEndKey) } ) )
1841				{
1842				$self->{log}->warn( "In association $assocName"
1843				. " $pkEndKey doesn't refer to a"
1844				. " primary key or unique index");
1845				return 0;
1846				}
1847				$self->{log}->info("null PK - unique index in $pkClassLookup->{name}")
1848				if ( !$pkAtts );
1849				}
1850				}
1851				else {
1852				$pkAtts = $self->{utils}->attlist_from_names( $pkClassLookup, $pkEndKey );
1853				}
1854				}
1855				else {
1856
1857				# Otherwise just use the marked primary key...
1858
1859				$pkAtts = $pkPK;
1860				$pkEndKey = $self->{utils}->names_from_attlist($pkAtts);
1861				}
1862
1863				# If there was no user-supplied PK name, but PK generation is allowed, do it
1864
1865				if ( $self->{fk_auto_gen} && !@$pkAtts ) {
1866				$self->{utils}->add_default_pk( $pkClassLookup, $pkEndKey );
1867				$pkAtts = $pkClassLookup->{pk};
1868				$pkEndKey = $self->{utils}->names_from_att_list($pkAtts);
1869				}
1870
1871				# Use user-supplied foreign key names if given
1872				if ($fkEndKey) {
1873				$fkEndKey =~ s/\s//g;
1874				}
1875				else {
1876
1877				$self->{log}->warn( "No FK attibute in specified in $assocName");
1878				# TODO: Implement the below method:
1879				#$fkEndKey = fkNamesFromAttList( $pkClassLookup->{name}, $pkAtts );
1880				}
1881				$fkAtts = $self->{utils}->attlist_from_names( $fkClassLookup, $fkEndKey );
1882				#$self->{log}->warn(q{fkAtts: }. Dumper($fkAtts));
1883
1884				# If we're not auto-generating foreign keys, the number of PK and FK attributes
1885				# must be equal
1886				if ( ( !$self->{pk_auto_gen} \|\| $fkClassLookup->{type} ne 'table' )
1887				&& @$pkAtts != @$fkAtts )
1888				{
1889				$self->{log}->warn( "In association $assocName $fkEndKey"
1890				. " has attributes not declared in $fkClassLookup->{name}");
1891				return;
1892				}
1893
1894				# Add default FK attributes if required...
1895				$fkAtts =
1896				$self->{utils}->add_default_fk( $fkClassLookup, $fkEndKey, $fkAtts, $pkAtts, $defFKnull )
1897				if ( $self->{pk_auto_gen}
1898				&& $fkClassLookup->{type} eq 'table'
1899				&& @$pkAtts != @$fkAtts );
1900
1901				# Number and types of PK and FK attributes must match...
1902				if ( @$pkAtts != @$fkAtts ) {
1903				$self->{log}->warn(
1904				"Number of PK and FK attributes don't match " . " in $assocName" );
1905				return;
1906				}
1907
1908				# Check ignore type mismatch flag
1909				if (!$self->{ignore_type_mismatch}) {
1910				if (
1911				!$self->{utils}->check_att_list_types(
1912				$assocName, $pkClassLookup, $fkClassLookup,
1913				$pkAtts, $fkAtts, $self->{db}
1914				)
1915				)
1916				{
1917				my $pkNames = $self->{utils}->names_from_attlist($pkAtts);
1918				my $fkNames = $self->{utils}->names_from_attlist($fkAtts);
1919				$self->{log}
1920				->warn( "Types of ($pkNames) don't match ($fkNames)" . " in $assocName");
1921				return;
1922				}
1923				} else {
1924				# Issue warning that ignore flag is set
1925				$self->{log}->warn( "Ignoring type mismatch if any");
1926				}
1927
1928				# Use the user-supplied FK constraint name; otherwise generate one
1929				my $fkName =
1930				$userAssocName && !$self->{uml}
1931				? $userAssocName
1932				: $self->{utils}->make_name( 1, $fkClassLookup->{name}, '_fk_', $fkAtts->[0][0] );
1933
1934				# Save the data needed to build the constraint
1935				$self->save_foreign_key(
1936				$fkClassLookup->{name},
1937				$fkName, $fkEndKey, $pkClassLookup->{name},
1938				$pkEndKey, $constraintAction
1939				);
1940				return 1;
1941				}
1942
1943
1944				# Save the details of foreign keys for output later (i.e. push onto
1945				# fk_defs array ref).
1946				sub save_foreign_key {
1947				my $self = shift;
1948				my $sourceTable = shift;
1949				my $assocName = shift;
1950				my $leftEnd = shift;
1951				my $targetTable = shift;
1952				my $rightEnd = shift;
1953				my $constraintAction = shift;
1954
1955				push @{ $self->{fk_defs} },
1956				[
1957				$sourceTable, $assocName, $leftEnd,
1958				$targetTable, $rightEnd, $constraintAction
1959				];
1960
1961				$self->{log}->debug("save_foreign_key: fk_defs is now: " . Dumper($self->{fk_defs})) if $self->{log}->is_debug();
1962
1963				return 1;
1964				}
1965
1966				1;
1967
1968				__END__