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
1             package Parse::Dia::SQL;
2              
3             # $Id: SQL.pm,v 1.55 2011/02/16 10:23:11 aff Exp $
4              
5             =pod
6              
7             =head1 NAME
8              
9             Parse::Dia::SQL - Convert Dia class diagrams into SQL.
10              
11             =head1 SYNOPSIS
12              
13             use Parse::Dia::SQL;
14             my $dia = Parse::Dia::SQL->new(
15             file => 't/data/TestERD.dia',
16             db => 'db2'
17             );
18             print $dia->get_sql();
19              
20             # or command-line version
21             perl parsediasql --file t/data/TestERD.dia --db db2
22              
23             =head1 DESCRIPTION
24              
25             Dia is a diagram creation program for Linux, Unix and Windows released
26             under the I.
27              
28             Parse::Dia::SQL converts Dia class diagrams into SQL.
29              
30             Parse::Dia::SQL is the parser that interprets the .dia file(s) into an
31             internal datastructure.
32              
33             Parse::Dia::SQL::Output (or one of its sub classes) can take the
34             datastructure and generate the SQL statements it represents.
35              
36             =head1 MODELLING HOWTO
37              
38             See L
39              
40             =head2 Modelling differences from tedia2sql
41              
42             =over
43              
44             =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.
45              
46             =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.
47              
48             =item * Preliminary support for Dia's I shapes is added.
49              
50             =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   86054 use warnings;
  74         90  
  74         2260  
175 74     74   237 use strict;
  74         74  
  74         1232  
176              
177 74     74   1238 use Data::Dumper;
  74         10540  
  74         3581  
178 74     74   38690 use IO::Uncompress::Gunzip qw(:all);
  74         2401861  
  74         7391  
179 74     74   52833 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.29';
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__