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	85092	use warnings;
	74		85
	74		2347
175	74	74	237	use strict;
	74		74
	74		1226
176
177	74	74	1334	use Data::Dumper;
	74		10228
	74		3577
178	74	74	36994	use IO::Uncompress::Gunzip qw(:all);
	74		2330498
	74		7185
179	74	74	50922	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.28';
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 ( $self->{uml} && $nodeAttrName eq 'assoc_type' && $assocDirection == 2 ) {
1266				$leftEnd{aggregate} = $self->{utils}->get_num_from_node($currentNode);
1267				} elsif ( $self->{uml} && $nodeAttrName eq 'assoc_type' ) {
1268				$rightEnd{aggregate} = $self->{utils}->get_num_from_node($currentNode);
1269				} elsif ( $nodeAttrName eq 'class_scope_a' ) {
1270				$leftEnd{class_scope} = $self->{utils}->get_string_from_node($currentNode);
1271				} elsif ( $nodeAttrName eq 'class_scope_b' ) {
1272				$rightEnd{class_scope} = $self->{utils}->get_string_from_node($currentNode);
1273				} elsif ( $nodeAttrName =~ qr/^multip[l]?icity_a$/ ) { ### Spelling !!!
1274				$leftEnd{multiplicity} = $self->{utils}->get_string_from_node($currentNode);
1275				} elsif ( $nodeAttrName =~ qr/^multip[l]?icity_b$/ ) { ### Spelling !!!
1276				$rightEnd{multiplicity} = $self->{utils}->get_string_from_node($currentNode);
1277				}
1278
1279				} else {
1280				$self->{log}->fatal("Unsupported $UML_ASSOCIATION version $version");
1281				}
1282
1283				$i++;
1284				}
1285
1286				# parse out the 'connections', that is, the classes on either end
1287				$connectionNode =
1288				$association->getElementsByTagName('dia:connections')->item(0);
1289
1290				$leftConnectionHandle =
1291				$connectionNode->getElementsByTagName('dia:connection')->item(0);
1292				$rightConnectionHandle =
1293				$connectionNode->getElementsByTagName('dia:connection')->item(1);
1294
1295				# Get the classes' object IDs
1296
1297				$leftConnectionHandle = $leftConnectionHandle->getAttribute('to')
1298				if ($leftConnectionHandle);
1299				$rightConnectionHandle = $rightConnectionHandle->getAttribute('to')
1300				if ($rightConnectionHandle);
1301
1302				# Check that the association is connected at both ends
1303				if ( !( $leftConnectionHandle && $rightConnectionHandle ) ) {
1304				my $goodEnd;
1305				$goodEnd = $leftConnectionHandle if ($leftConnectionHandle);
1306				$goodEnd = $rightConnectionHandle if ($rightConnectionHandle);
1307				$goodEnd = $self->uml_class_lookup( [ $id->[0], $goodEnd ] )->{name}
1308				if ($goodEnd);
1309				$self->{log}->warn("Association "
1310				. ( $assocName ? $assocName : "" )
1311				. (
1312				$goodEnd
1313				? " only connected at one end - " . $goodEnd
1314				: " not connected at either end"
1315				));
1316				$self->{log}->warn("foreign key constraint not created");
1317				return;
1318				}
1319
1320				my $leftMult = $self->{utils}->classify_multiplicity( $leftEnd{'multiplicity'} );
1321				my $rightMult = $self->{utils}->classify_multiplicity( $rightEnd{'multiplicity'} );
1322
1323				if ($self->{log}->is_debug()) {
1324				no warnings 'uninitialized';
1325				$self->{log}->debug("leftEnd : ".Dumper(\%leftEnd));
1326				$self->{log}->debug("rightEnd: ".Dumper(\%rightEnd));
1327
1328				$self->{log}->debug(
1329				" * (UNUSED) direction=$assocDirection (aggregate determines many end)");
1330				$self->{log}->debug( " * leftEnd="
1331				. $leftEnd{'role'} . " agg="
1332				. $leftEnd{'aggregate'}
1333				. " classId="
1334				. $leftConnectionHandle );
1335				$self->{log}->debug( " * rightEnd="
1336				. $rightEnd{'role'} . " agg="
1337				. $rightEnd{'aggregate'}
1338				. " classId="
1339				. $rightConnectionHandle );
1340
1341
1342				$self->{log}->debug("leftMult : $leftMult");
1343				$self->{log}->debug("rightMult : $rightMult");
1344				}
1345
1346				# Get primary key end in one-to-n (incl 1-to-1) associations
1347				# The encoding for this is different between default ERD mode and UML mode
1348				my $pkSide = 'none';
1349				my $arity;
1350				if ( ( $self->{uml} ? $rightEnd{'aggregate'} : $leftEnd{'aggregate'} )
1351				\|\| $self->{uml} && $rightMult =~ '^z?one$' && $leftMult =~ /^z?many$/ )
1352				{
1353
1354				# Right side is 'one' end; one-to-many
1355				$pkSide = 'right';
1356				$arity = 'zmany';
1357				}
1358				elsif ( ( $self->{uml} ? $leftEnd{'aggregate'} : $rightEnd{'aggregate'} )
1359				\|\| $self->{uml} && $leftMult =~ '^z?one$' && $rightMult =~ /^z?many$/ )
1360				{
1361
1362				# Left side is 'one' end; one-to-many
1363				$pkSide = 'left';
1364				$arity = 'zmany';
1365				}
1366				elsif ( $assocDirection eq 1
1367				&& ( !$self->{uml} \|\| ( $rightMult eq 'one' && $leftMult =~ /^z?one$/ ) ) )
1368				{
1369
1370				# Right side is 'one' end; one-to-zero-or-one
1371				$pkSide = 'right';
1372				$arity = 'zone';
1373				}
1374				elsif ( $assocDirection eq 2
1375				&& ( !$self->{uml} \|\| ( $leftMult eq 'one' && $rightMult =~ /^z?one$/ ) ) )
1376				{
1377
1378				# Left side is 'one' end; one-to-zero-or-one
1379				$pkSide = 'left';
1380				$arity = 'zone';
1381				}
1382
1383				my $leftClass = $self->uml_class_lookup( [ $id->[0], $leftConnectionHandle ] );
1384				my $rightClass = $self->uml_class_lookup( [ $id->[0], $rightConnectionHandle ] );
1385
1386				my $ok = 0;
1387
1388				if ( $pkSide ne 'none' ) {
1389
1390				# If the classification above succeeded, generate the
1391				# keys (if needed) and the FK constraints for a one-to-
1392				# association
1393				$ok = $self->generate_one_to_any_association(
1394				$assocName, $pkSide, $arity, $leftClass,
1395				\%leftEnd, $rightClass, \%rightEnd
1396				);
1397				}
1398				elsif ( ( $self->{uml} \|\| $assocDirection eq 0 )
1399				&& $leftMult =~ /^z?many$/
1400				&& $rightMult =~ /^z?many$/ )
1401				{
1402
1403				# If the classification above failed, and the association is
1404				# many-to-many; generate the centre (join) table, its constraints
1405				# and the classes' primary keys (if needed)
1406				$ok = $self->generate_many_to_many_association(
1407				$assocName, $leftClass, $rightEnd{'role'},
1408				$rightClass, $leftEnd{'role'}
1409				);
1410				}
1411				else {
1412				$self->{log}->warn(
1413				"Couldn't classify $leftClass->{name}:$rightClass->{name} to generate SQL: $leftMult:$rightMult");
1414				$ok = 0;
1415				}
1416
1417				$self->{log}->debug(
1418				"Classified $leftClass->{name}:$rightClass->{name} to generate SQL: $leftMult:$rightMult") if $self->{log}->is_debug();
1419
1420				# $errors++ if ( !$ok );
1421
1422				return $ok;
1423				}
1424
1425				# Look up a class given the XML id of the class, taking into account
1426				# placeholder classes.
1427				sub uml_class_lookup {
1428				my $self = shift;
1429				my $id = shift;
1430
1431				if ( my $placeHolder = $self->{umlClassPlaceholder}{ $id->[0] }{ $id->[1] } )
1432				{
1433				$self->{log}->debug(
1434				"Map reference to {$id->[0]}{$id->[1]} to ",
1435				$placeHolder->{refers},
1436				" (", $placeHolder->{name}, ")"
1437				);
1438				$id = $placeHolder->{refers};
1439				}
1440				return $self->{umlClassLookup}{ $id->[0] }{ $id->[1] };
1441				}
1442
1443
1444				# Generate SQL for a many to many association including generating the
1445				# centre (join) table.
1446				sub generate_many_to_many_association {
1447				my $self = shift;
1448				my $assocName = shift;
1449				my $leftClassLookup = shift;
1450				my $leftRole = shift;
1451				my $rightClassLookup = shift;
1452				my $rightRole = shift;
1453
1454				$self->{log}->debug("generate_many_to_many_association: assocName: $assocName");
1455				$self->{log}->debug("generate_many_to_many_association: leftClassLookup->{name}: ".$leftClassLookup->{name} );
1456				$self->{log}->debug("generate_many_to_many_association: leftRole: $leftRole");
1457				$self->{log}->debug("generate_many_to_many_association: rightClassLookup->{name}: ".$rightClassLookup->{name} );
1458				$self->{log}->debug("generate_many_to_many_association: rightRole: $rightRole");
1459
1460				my @centreCols;
1461				my ( $leftFKName, $rightFKName );
1462				my ( $leftEndCols, $rightEndCols );
1463				my ( $leftFKCols, $rightFKCols );
1464
1465				if ( $leftClassLookup->{type} ne 'table'
1466				\|\| $rightClassLookup->{type} ne 'table' )
1467				{
1468				$self->{log}->warn( "View in $assocName"
1469				. " ($leftClassLookup->{name},$rightClassLookup->{name} ne 'table')"
1470				. ": Many-to-many associations are only supported between tables");
1471				# $errors++;
1472				return;
1473				}
1474
1475				# Generate the centre (join) table name if the user hasn't specified one
1476
1477				$assocName =
1478				$self->{utils}->make_name( 0, $leftClassLookup->{name}, $rightClassLookup->{name}, $self->{db} )
1479				if ( !$assocName );
1480
1481				# Build the centre table for the left (A) end of the association
1482
1483				if (
1484				!$self->add_centre_cols(
1485				$assocName, \@centreCols, $leftRole, $rightRole,
1486				\$leftFKName, \$leftFKCols, \$leftEndCols, $leftClassLookup
1487				)
1488				)
1489				{
1490				$self->{log}->debug("add_centre_cols return false - returning");
1491				return;
1492				}
1493
1494				# Build the centre table for the right (B) end of the association
1495
1496				if (
1497				!$self->add_centre_cols(
1498				$assocName, \@centreCols, $rightRole, $leftRole,
1499				\$rightFKName, \$rightFKCols, \$rightEndCols, $rightClassLookup
1500				)
1501				)
1502				{
1503				$self->{log}->debug("add_centre_cols return false - returning");
1504				return;
1505				}
1506
1507				# Make the association table
1508				$self->{log}->debug("Call gen_table_view_sql assocName=$assocName");
1509
1510				$self->gen_table_view_sql(
1511				$assocName,
1512				"table",
1513				"Association between $leftClassLookup->{name}"
1514				. " and $rightClassLookup->{name}",
1515				[@centreCols],
1516				[]
1517				);
1518
1519				# generate the constraint code:
1520				# foreign key -> referenced attribute
1521				$self->{log}->debug("Call save_foreign_key (left to right)");
1522
1523				$self->save_foreign_key(
1524				$assocName, ## From table
1525				$leftFKName, ## name of foreign key constraint
1526				$leftFKCols, ## foreign key column in assoc tbl
1527				$leftClassLookup->{name}, ## Table referenced
1528				$leftEndCols, ## Column in table referenced
1529				'on delete cascade' ## Trash when no longer referenced
1530				);
1531
1532				# generate the constraint code:
1533				# referenced attribute <- foreign key
1534				$self->{log}->debug("Call save_foreign_key (right to left)");
1535
1536				$self->save_foreign_key($assocName, $rightFKName, $rightFKCols,
1537				$rightClassLookup->{name},
1538				$rightEndCols, 'on delete cascade');
1539
1540				return 1;
1541				}
1542
1543				# Create datastructure that represents given Table or View SQL and
1544				# store in classes reference.
1545				sub gen_table_view_sql {
1546				my $self = shift;
1547				my $objectName = shift;
1548				my $objectType = shift;
1549				my $objectComment = shift;
1550				my $objectAttributes = shift;
1551				my $objectOperations = shift;
1552
1553				my $classLookup = {
1554				name => $objectName, # Object name
1555				type => $objectType, # Object type table/view
1556				attList => $objectAttributes, # list of attributes
1557				atts => $objectAttributes, # lookup table of attributes
1558				pk => [], # list of primary key attributes
1559				uindxc => {}, # lookup of unique index column names
1560				uindxn => {}, # lookup of unique index names
1561				ops => $objectOperations, # list of operations
1562				};
1563
1564				# Push this generated table to classes array
1565				push @{ $self->{classes} }, $classLookup;
1566
1567				$self->{log}->debug("classes: ".Dumper($self->{classes}));
1568
1569				return 1;
1570				}
1571
1572				# Add column descriptors for a centre (join) table to an array of
1573				# descriptors passed.
1574				sub add_centre_cols {
1575				my $self = shift;
1576				my $assocName = shift; # For warning messages & constructing constraint name
1577				my $cols = shift; # Where to add column descriptors
1578				my $pkRole = shift; # Names for the PK end
1579				my $fkRole = shift; # Names for the FK end
1580				my $fkCName = shift; # Assemble FK constraint name here
1581				my $fkColNames = shift; # Assemble FK column names here
1582				my $pkColNames = shift; # Assemble PK column names here
1583				my $classDesc = shift; # Class lookup descriptor
1584
1585				my $className = $classDesc->{name}; # Name of target class
1586				my $pk = $classDesc->{pk}; # List of primary key attributes
1587				my $uin = $classDesc->{uindxn}; # List of unique index by name
1588				my $uic = $classDesc->{uindxc}; # List of unique index by column names
1589
1590				my ( undef, $pkRoleNames ) = split( /\s:\s/, $pkRole );
1591				my ( $fkRoleNames, undef ) = split( /\s:\s/, $fkRole );
1592
1593				my $pkAtts = $pk;
1594
1595				# Use user-supplied names for the primary key if given
1596
1597				if ($pkRoleNames) {
1598				$pkRoleNames =~ s/\s//g;
1599				my $pkNames = $self->{utils}->names_from_attlist($pk);
1600				if ( $self->{utils}->name_case($pkNames) eq
1601				$self->{utils}->name_case($pkRoleNames) )
1602				{
1603
1604				# It's an explicit reference to the primary key
1605				$pkAtts = $pk;
1606				}
1607				else {
1608
1609				# Try a unique index
1610				if ( !( $pkAtts = $uin->{$pkRoleNames} )
1611				&& !( $pkAtts = $uic->{$pkRoleNames} ) )
1612				{
1613				$self->{log}->warn(
1614				"In association $assocName $pkRoleNames doesn't refer to a primary key or unique index");
1615				return 0;
1616				}
1617				}
1618				}
1619
1620				# If there was no user-supplied PK name, but PK generation is allowed, do it
1621
1622				if ( $self->{default_pk} && !@$pkAtts && $classDesc->{type} eq 'table' ) {
1623				$self->{utils}->add_default_pk( $classDesc, '' );
1624				$pkAtts = $classDesc->{pk};
1625				}
1626
1627				# No primary key (or unique index) suitable
1628				if ( @$pkAtts == 0 ) {
1629				$self->{log}->warn(
1630				"Association $assocName referenced class $classDesc->{name} must have a primary key");
1631				return 0;
1632				}
1633
1634				my @pkCols;
1635				my @fkCols;
1636				my $pk0;
1637				my @fkCNames;
1638
1639				# If the user supplied foreign key names, use them
1640				if ($fkRoleNames) {
1641				@fkCNames = split /\s,\s/, $fkRoleNames;
1642				if ( @fkCNames != @$pkAtts ) {
1643				$self->{log}->warn(
1644				"Association $assocName $fkRoleNames has the wrong number of attributes");
1645				return 0;
1646				}
1647				}
1648
1649				# Generate the columns in the centre (join) table
1650
1651				foreach my $i ( 0 .. $#{$pkAtts} ) {
1652				my $pkFld = $pkAtts->[$i];
1653				$pk0 = $pkFld->[0] if ( !$pk0 );
1654				my $colName =
1655				$fkRoleNames
1656				? $fkCNames[$i]
1657				: $self->{utils}->make_name( 1, $className, $pkFld->[0] );
1658				push @fkCols, $colName;
1659
1660				# The generated columns in the centre (join) table take the
1661				# type of the corresponding PK, and are part of centre table's
1662				# primary key (2==protected for the visibility).
1663				push @$cols, [ $colName, $pkFld->[1], '', 2, '' ];
1664
1665				# Build the list of PK names
1666				push @pkCols, $pkFld->[0];
1667				}
1668				$$pkColNames = join ',', @pkCols if ( !$$pkColNames );
1669				$$fkColNames = join ',', @fkCols;
1670				$$fkCName =
1671				$self->{utils}->make_name( 1, $assocName, '_fk_', $className, $pk0 );
1672				return 1;
1673				}
1674
1675
1676				# Generate data for SQL generation for an association where one side has
1677				# multiplicity one; no additional table is necessary.
1678				sub generate_one_to_any_association {
1679				my $self = shift;
1680				my $userAssocName = shift;
1681				my $pkSide = shift;
1682				my $arity = shift;
1683				my $pkClassLookup = shift;
1684				my $pkEnd = shift;
1685				my $fkClassLookup = shift;
1686				my $fkEnd = shift;
1687
1688				# The caller used 'left' and 'right'; change this to
1689				# primary key/foreign key side of the association
1690
1691				if ( $pkSide eq 'right' ) {
1692				my $tClassLookup = $pkClassLookup;
1693				my $tEnd = $pkEnd;
1694				$pkClassLookup = $fkClassLookup;
1695				$pkEnd = $fkEnd;
1696				$fkClassLookup = $tClassLookup;
1697				$fkEnd = $tEnd;
1698				}
1699
1700				# MAke the association name if necessary
1701
1702				my $assocName = $userAssocName;
1703				if ( !$assocName ) {
1704				$assocName = $self->{utils}->make_name( 0, $pkClassLookup->{name}, $fkClassLookup->{name} );
1705				}
1706
1707				# Classify the multiplicity (if given) of the ends of the association
1708
1709				my $pkMult =
1710				$self->{utils}->classify_multiplicity( $pkEnd->{'multiplicity'} );
1711				my $fkMult =
1712				$self->{utils}->classify_multiplicity( $fkEnd->{'multiplicity'} );
1713
1714				# By default, foreign keys are constrained to be 'not null'
1715				my $defFKnull = 'not null';
1716
1717				# Work out the constraint action for the foreign key
1718				my $constraintAction = '';
1719				if ( $self->{uml} ) {
1720
1721				# UML interpretation
1722
1723				# Only one of the left and right end aggregation can be
1724				# non-zero; 1 = aggregation, 2 = composition.
1725				my $aggregation = $pkEnd->{'aggregate'} + $fkEnd->{'aggregate'};
1726				if ( $aggregation == 0 ) { # No semantics specified
1727				$constraintAction = '';
1728				}
1729				elsif ( $aggregation == 1 ) { # Aggregation
1730				$constraintAction = 'on delete set NULL';
1731				$defFKnull = 'null';
1732				}
1733				elsif ( $aggregation == 2 ) { # Composition
1734				$constraintAction = 'on delete cascade';
1735				}
1736				}
1737				else {
1738
1739				# ERD interpretation
1740
1741				# If Utils::classify_multiplicity didn't understand the multiplicity
1742				# field, then assume it's a constraint action, and set the
1743				# multiplicity classification to 'none'
1744
1745				if ( $fkMult eq 'undef' ) {
1746				$constraintAction = $fkEnd->{'multiplicity'};
1747				$fkMult = 'none';
1748				}
1749
1750				# If the constraint action is 'on delete set null', then
1751				# allow the FK to have null value
1752
1753				if ( $constraintAction =~ /on\s+delete\s+set\s+null/i ) {
1754				$defFKnull = 'null';
1755				}
1756
1757				# tedia2sql v1.2.9b usage of 'on delete clause'
1758				# The 'on cascade delete' clauses were on opposite ends of
1759				# the association for one-to-many and one-to-one for ERD mode!
1760				# if ($arity eq 'zmany' && $fkMult eq 'undef') {
1761				# $constraintAction = $fkEnd->{'multiplicity'};
1762				# $fkMult = 'none';
1763				# } elsif ($arity eq 'zone' && $pkMult eq 'undef') {
1764				# $constraintAction = $pkEnd->{'multiplicity'};
1765				# $pkMult = 'none';
1766				# }
1767				}
1768
1769				# If the arity implied by the association is one-to-many, set the
1770				# arity classifications appropriately if they weren't given
1771
1772				if ( $arity eq 'zmany' ) {
1773				$pkMult = 'one' if ( $pkMult eq 'none' );
1774				$fkMult = 'zmany' if ( $fkMult eq 'none' );
1775				if (
1776				$pkMult ne 'one'
1777				\|\| $self->{uml}
1778				? $fkMult !~ /^z?(many\|one)$/
1779				: $fkMult !~ /^z?many$/
1780				)
1781				{
1782				$self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
1783				. " specified in $assocName");
1784				return 0;
1785				}
1786				}
1787				elsif ( $arity eq 'zone' ) {
1788				$pkMult = 'one' if ( $pkMult eq 'none' );
1789				$fkMult = 'zone' if ( $fkMult eq 'none' );
1790				if ( $pkMult ne 'one'
1791				\|\| $fkMult !~ /^z?one$/ )
1792				{
1793				$self->{log}->warn( "Inappropriate multiplicity ($pkMult->$fkMult)"
1794				. " specified in $assocName");
1795				return 0;
1796				}
1797				}
1798
1799				$defFKnull = 'null' if ( $pkMult =~ /^z(many\|one)$/ );
1800
1801				# Generate names if they haven't been specified
1802				my $pkEndKey = $pkEnd->{'role'};
1803				my $fkEndKey = $fkEnd->{'role'};
1804				my $pkPK = $pkClassLookup->{pk}; # List of primary key attributes
1805				my $pkUIn = $pkClassLookup->{uindxn}; # List of unique index descriptors
1806				my $pkUIc = $pkClassLookup->{uindxc}; # List of unique index descriptors
1807				my $pkAtts = undef;
1808				my $fkAtts = undef;
1809
1810				if ($pkEndKey) {
1811
1812				# Use user-supplied names for the primary key if given
1813
1814				if ( $pkClassLookup->{type} eq 'table' ) {
1815				$pkEndKey =~ s/\s//g;
1816				my $pkNames = $self->{utils}->names_from_attlist($pkPK);
1817				if ( $self->{utils}->name_case($pkNames) eq
1818				$self->{utils}->name_case($pkEndKey) )
1819				{
1820
1821				# It's an explicit reference to the primary key
1822				$pkAtts = $pkPK;
1823				}
1824				else {
1825
1826				# Try a unique index
1827				if ( !( $pkAtts = $pkUIn->{ $self->{utils}->name_case($pkEndKey) } )
1828				&& !( $pkAtts = $pkUIc->{ $self->{utils}->name_case($pkEndKey) } ) )
1829				{
1830				$self->{log}->warn( "In association $assocName"
1831				. " $pkEndKey doesn't refer to a"
1832				. " primary key or unique index");
1833				return 0;
1834				}
1835				$self->{log}->info("null PK - unique index in $pkClassLookup->{name}")
1836				if ( !$pkAtts );
1837				}
1838				}
1839				else {
1840				$pkAtts = $self->{utils}->attlist_from_names( $pkClassLookup, $pkEndKey );
1841				}
1842				}
1843				else {
1844
1845				# Otherwise just use the marked primary key...
1846
1847				$pkAtts = $pkPK;
1848				$pkEndKey = $self->{utils}->names_from_attlist($pkAtts);
1849				}
1850
1851				# If there was no user-supplied PK name, but PK generation is allowed, do it
1852
1853				if ( $self->{fk_auto_gen} && !@$pkAtts ) {
1854				$self->{utils}->add_default_pk( $pkClassLookup, $pkEndKey );
1855				$pkAtts = $pkClassLookup->{pk};
1856				$pkEndKey = $self->{utils}->names_from_att_list($pkAtts);
1857				}
1858
1859				# Use user-supplied foreign key names if given
1860				if ($fkEndKey) {
1861				$fkEndKey =~ s/\s//g;
1862				}
1863				else {
1864
1865				$self->{log}->warn( "No FK attibute in specified in $assocName");
1866				# TODO: Implement the below method:
1867				#$fkEndKey = fkNamesFromAttList( $pkClassLookup->{name}, $pkAtts );
1868				}
1869				$fkAtts = $self->{utils}->attlist_from_names( $fkClassLookup, $fkEndKey );
1870				#$self->{log}->warn(q{fkAtts: }. Dumper($fkAtts));
1871
1872				# If we're not auto-generating foreign keys, the number of PK and FK attributes
1873				# must be equal
1874				if ( ( !$self->{pk_auto_gen} \|\| $fkClassLookup->{type} ne 'table' )
1875				&& @$pkAtts != @$fkAtts )
1876				{
1877				$self->{log}->warn( "In association $assocName $fkEndKey"
1878				. " has attributes not declared in $fkClassLookup->{name}");
1879				return;
1880				}
1881
1882				# Add default FK attributes if required...
1883				$fkAtts =
1884				$self->{utils}->add_default_fk( $fkClassLookup, $fkEndKey, $fkAtts, $pkAtts, $defFKnull )
1885				if ( $self->{pk_auto_gen}
1886				&& $fkClassLookup->{type} eq 'table'
1887				&& @$pkAtts != @$fkAtts );
1888
1889				# Number and types of PK and FK attributes must match...
1890				if ( @$pkAtts != @$fkAtts ) {
1891				$self->{log}->warn(
1892				"Number of PK and FK attributes don't match " . " in $assocName" );
1893				return;
1894				}
1895
1896				# Check ignore type mismatch flag
1897				if (!$self->{ignore_type_mismatch}) {
1898				if (
1899				!$self->{utils}->check_att_list_types(
1900				$assocName, $pkClassLookup, $fkClassLookup,
1901				$pkAtts, $fkAtts, $self->{db}
1902				)
1903				)
1904				{
1905				my $pkNames = $self->{utils}->names_from_attlist($pkAtts);
1906				my $fkNames = $self->{utils}->names_from_attlist($fkAtts);
1907				$self->{log}
1908				->warn( "Types of ($pkNames) don't match ($fkNames)" . " in $assocName");
1909				return;
1910				}
1911				} else {
1912				# Issue warning that ignore flag is set
1913				$self->{log}->warn( "Ignoring type mismatch if any");
1914				}
1915
1916				# Use the user-supplied FK constraint name; otherwise generate one
1917				my $fkName =
1918				$userAssocName && !$self->{uml}
1919				? $userAssocName
1920				: $self->{utils}->make_name( 1, $fkClassLookup->{name}, '_fk_', $fkAtts->[0][0] );
1921
1922				# Save the data needed to build the constraint
1923				$self->save_foreign_key(
1924				$fkClassLookup->{name},
1925				$fkName, $fkEndKey, $pkClassLookup->{name},
1926				$pkEndKey, $constraintAction
1927				);
1928				return 1;
1929				}
1930
1931
1932				# Save the details of foreign keys for output later (i.e. push onto
1933				# fk_defs array ref).
1934				sub save_foreign_key {
1935				my $self = shift;
1936				my $sourceTable = shift;
1937				my $assocName = shift;
1938				my $leftEnd = shift;
1939				my $targetTable = shift;
1940				my $rightEnd = shift;
1941				my $constraintAction = shift;
1942
1943				push @{ $self->{fk_defs} },
1944				[
1945				$sourceTable, $assocName, $leftEnd,
1946				$targetTable, $rightEnd, $constraintAction
1947				];
1948
1949				$self->{log}->debug("save_foreign_key: fk_defs is now: " . Dumper($self->{fk_defs})) if $self->{log}->is_debug();
1950
1951				return 1;
1952				}
1953
1954				1;
1955
1956				__END__