File Coverage

lib/Parse/Dia/SQL/Output.pm
Criterion Covered Total %
statement 22 24 91.6
branch n/a
condition n/a
subroutine 8 8 100.0
pod n/a
total 30 32 93.7


line stmt bran cond sub pod time code
1             package Parse::Dia::SQL::Output;
2              
3             # $Id: Output.pm,v 1.33 2011/02/16 10:23:11 aff Exp $
4              
5             =pod
6              
7             =head1 NAME
8              
9             Parse::Dia::SQL::Output - Create SQL base class.
10              
11             =head1 SYNOPSIS
12              
13             use Parse::Dia::SQL;
14             my $dia = Parse::Dia::SQL->new(...);
15             my $output = $dia->get_output_instance();
16             print $output->get_sql();
17              
18             =head1 DESCRIPTION
19              
20             This is the base sql formatter class for creating sql. It contains
21             basic functionality, which can be overridden in subclasses, one for
22             each RDBMS.
23              
24             =head1 SEE ALSO
25              
26             Parse::Dia::SQL::Output::DB2
27             Parse::Dia::SQL::Output::Oracle
28              
29             =cut
30              
31 48     48   121836 use warnings;
  48         72  
  48         1292  
32 48     48   163 use strict;
  48         53  
  48         869  
33 48     48   17753 use open qw/:std :utf8/;
  48         40701  
  48         204  
34              
35 48     48   26995 use Text::Table;
  48         509085  
  48         1174  
36 48     48   267 use Data::Dumper;
  48         67  
  48         1928  
37 48     48   189 use Config;
  48         57  
  48         1649  
38              
39 48     48   149 use lib q{lib};
  48         63  
  48         302  
40 48     48   20935 use Parse::Dia::SQL::Utils;
  0            
  0            
41             use Parse::Dia::SQL::Logger;
42             use Parse::Dia::SQL::Const;
43              
44             =head1 METHODS
45              
46             =over
47              
48             =item new()
49              
50             The constructor. Arguments:
51              
52             db - the target database type
53              
54             =cut
55              
56             sub new {
57             my ($class, %param) = @_;
58              
59             my $self = {
60              
61             # command line options
62             files => $param{files} || [], # dia files
63             db => $param{db} || undef,
64             uml => $param{uml} || undef,
65             fk_auto_gen => $param{fk_auto_gen} || undef,
66             pk_auto_gen => $param{pk_auto_gen} || undef,
67             default_pk => $param{default_pk} || undef, # opt_p
68              
69             # formatting options
70             indent => $param{indent} || q{ } x 3,
71             newline => $param{newline} || "\n",
72             end_of_statement => $param{end_of_statement} || ";",
73             column_separator => $param{column_separator} || ",",
74             sql_comment => $param{sql_comment} || "-- ",
75              
76             # sql options
77             index_options => $param{index_options}
78             || [],
79             object_name_max_length => $param{object_name_max_length}
80             || undef,
81             table_postfix_options => $param{table_postfix_options}
82             || [],
83             table_postfix_options_separator => $param{table_postfix_options_separator}
84             || ' ',
85              
86             # parsed datastructures
87             associations => $param{associations} || [], # foreign keys, indices
88             classes => $param{classes} || [], # tables and views
89             components => $param{components} || [], # insert statements
90             small_packages => $param{small_packages} || [],
91             typemap => $param{typemap} || {}, # custom type mapping
92             loglevel => $param{loglevel} || undef,
93             backticks => $param{backticks} || undef, # MySQL-InnoDB only
94              
95             # references to components
96             log => undef,
97             const => undef,
98             utils => undef,
99             };
100             bless($self, $class);
101              
102             $self->_init_log();
103             $self->_init_const();
104             $self->_init_utils(loglevel => $param{loglevel});
105              
106             return $self;
107             }
108              
109             # Initialize logger
110             sub _init_log {
111             my $self = shift;
112             my $logger = Parse::Dia::SQL::Logger::->new(loglevel => $self->{loglevel});
113             $self->{log} = $logger->get_logger(__PACKAGE__);
114             return 1;
115             }
116              
117             # Initialize Constants component
118             sub _init_const {
119             my $self = shift;
120             $self->{const} = Parse::Dia::SQL::Const::->new();
121             return 1;
122             }
123              
124             # Initialize Parse::Dia::SQL::Utils class.
125             sub _init_utils {
126             my $self = shift;
127             $self->{utils} = Parse::Dia::SQL::Utils::->new(
128             db => $self->{db},
129             loglevel => $self->{loglevel},
130             );
131             return 1;
132             }
133              
134             # Return string with comment containing target database, $VERSION, time
135             # and list of files etc.
136             sub _get_comment {
137             my $self = shift;
138             my $files_word =
139             (scalar(@{ $self->{files} }) > 1)
140             ? q{Input files}
141             : q{Input file};
142              
143             my @arr = (
144             [ q{Parse::SQL::Dia}, qq{version $Parse::Dia::SQL::VERSION} ],
145             [ q{Documentation}, q{http://search.cpan.org/dist/Parse-Dia-SQL/} ],
146             [ q{Environment}, qq{Perl $], $^X} ],
147             [ q{Architecture}, qq{$Config{archname}} ],
148             [ q{Target Database}, $self->{db} ],
149             [ $files_word, join(q{, }, @{ $self->{files} }) ],
150             [ q{Generated at}, scalar localtime() ],
151             );
152              
153             # Add typemap for given database
154             my $typemap_str = "not found in input file";
155             if (exists($self->{typemap}->{ $self->{db} })) {
156             $typemap_str = "found in input file";
157             }
158             push @arr, [ "Typemap for " . $self->{db}, $typemap_str ];
159              
160             # Add the sql_comment to first sub-element of all elements
161             @arr = map { $_->[0] = $self->{sql_comment} . $_->[0]; $_ } @arr;
162              
163             my $tb = Text::Table->new();
164             $tb->load(@arr);
165              
166             return scalar $tb->table();
167             }
168              
169             =item get_sql()
170              
171             Return all sql. The sequence of statements is as follows:
172              
173             constraints drop
174             permissions drop
175             view drop
176             schema drop
177             smallpackage pre sql
178             schema create
179             view create
180             permissions create
181             inserts
182             smallpackage post sql
183             associations create (indices first, then foreign keys)
184              
185             =cut
186              
187             sub get_sql {
188             my $self = shift;
189              
190             ## No critic (NoWarnings)
191             no warnings q{uninitialized};
192             return
193             $self->_get_comment()
194             . $self->{newline}
195             . "-- get_constraints_drop "
196             . $self->{newline}
197             . $self->get_constraints_drop()
198             . $self->{newline}
199             . "-- get_permissions_drop "
200             . $self->{newline}
201             . $self->get_permissions_drop()
202             . $self->{newline}
203             . "-- get_view_drop"
204             . $self->{newline}
205             . $self->get_view_drop()
206             . $self->{newline}
207             . "-- get_schema_drop"
208             . $self->{newline}
209             . $self->get_schema_drop()
210             . $self->{newline}
211             . "-- get_smallpackage_pre_sql "
212             . $self->{newline}
213             . $self->get_smallpackage_pre_sql()
214             . $self->{newline}
215             . "-- get_schema_create"
216             . $self->{newline}
217             . $self->get_schema_create()
218             . $self->{newline}
219             . "-- get_view_create"
220             . $self->{newline}
221             . $self->get_view_create()
222             . $self->{newline}
223             . "-- get_permissions_create"
224             . $self->{newline}
225             . $self->get_permissions_create()
226             . $self->{newline}
227             . "-- get_inserts"
228             . $self->{newline}
229             . $self->get_inserts()
230             . $self->{newline}
231             . "-- get_smallpackage_post_sql"
232             . $self->{newline}
233             . $self->get_smallpackage_post_sql()
234             . $self->{newline}
235             . "-- get_associations_create"
236             . $self->{newline}
237             . $self->get_associations_create();
238             }
239              
240             # Return insert statements. These are based on content of the
241             # I, and split on the linefeed character ("\n").
242             #
243             # Add $self->{end_of_statement} to each statement.
244             sub get_inserts {
245             my $self = shift;
246             my $sqlstr = '';
247              
248             # Expect array ref of hash refs
249             return unless $self->_check_components();
250              
251             $self->{log}->debug(Dumper($self->{components}))
252             if $self->{log}->is_debug;
253              
254             foreach my $component (@{ $self->{components} }) {
255             foreach my $vals (split("\n", $component->{text})) {
256              
257             $sqlstr .=
258             qq{insert into }
259             . $component->{name}
260             . qq{ values($vals) }
261             . $self->{end_of_statement}
262             . $self->{newline};
263             }
264             }
265              
266             return $sqlstr;
267             }
268              
269             # Drop all constraints (e.g. foreign keys and indices)
270             #
271             # This sub is split into two parts to make it easy sub subclass either.
272             sub get_constraints_drop {
273             my $self = shift;
274              
275             # Allow undefined values
276             no warnings q[uninitialized];
277             return $self->_get_fk_drop() . $self->_get_index_drop();
278             }
279              
280             # Drop all foreign keys
281             sub _get_fk_drop {
282             my $self = shift;
283             my $sqlstr = '';
284              
285             return unless $self->_check_associations();
286              
287             # drop fk
288             foreach my $association (@{ $self->{associations} }) {
289             my ($table_name, $constraint_name, undef, undef, undef, undef) =
290             @{$association};
291              
292             # Shorten constraint name, if necessary (DB2 only)
293             $constraint_name = $self->_create_constraint_name($constraint_name);
294              
295             $sqlstr .=
296             qq{alter table $table_name drop constraint $constraint_name }
297             . $self->{end_of_statement}
298             . $self->{newline};
299             }
300             return $sqlstr;
301             }
302              
303             # Drop all indices
304             sub _get_index_drop {
305             my $self = shift;
306             my $sqlstr = q{};
307              
308             return unless $self->_check_classes();
309              
310             # drop index
311             foreach my $table (@{ $self->{classes} }) {
312              
313             foreach my $operation (@{ $table->{ops} }) {
314              
315             if (ref($operation) ne 'ARRAY') {
316             $self->{log}->error(
317             q{Error in ops input - expect an ARRAY ref, got } . ref($operation));
318             next OPERATION;
319             }
320              
321             my ($opname, $optype) = ($operation->[0], $operation->[1]);
322              
323             # 2nd element can be index, unique index, grant, etc
324             next if ($optype !~ qr/^(unique )?index$/i);
325              
326             $sqlstr .= $self->_get_drop_index_sql($table->{name}, $opname);
327             }
328             }
329             return $sqlstr;
330             }
331              
332             # Create drop index for index on table with given name. Note that the
333             # tablename is not used here, but many of the overriding subclasses use
334             # it, so we include both the tablename and the indexname as arguments to
335             # keep the interface consistent.
336             sub _get_drop_index_sql {
337             my ($self, $tablename, $indexname) = @_;
338              
339             return
340             qq{drop index $indexname}
341             . $self->{end_of_statement}
342             . $self->{newline};
343             }
344              
345             # Create drop view for all views
346             sub get_view_drop {
347             my $self = shift;
348             my $sqlstr = '';
349              
350             return unless $self->_check_classes();
351              
352             CLASS:
353             foreach my $object (@{ $self->{classes} }) {
354             next CLASS if ($object->{type} ne q{view});
355              
356             # Sanity checks on internal state
357             if (!defined($object)
358             || ref($object) ne q{HASH}
359             || !exists($object->{name}))
360             {
361             $self->{log}
362             ->error(q{Error in table input - cannot create drop table sql!});
363             next;
364             }
365              
366             $sqlstr .=
367             qq{drop view }
368             . $object->{name}
369             . $self->{end_of_statement}
370             . $self->{newline};
371             }
372              
373             return $sqlstr;
374              
375             }
376              
377             # Sanity check on internal state.
378             #
379             # Return true if and only if
380             #
381             # $self->{components} should be a defined array ref with 1 or more
382             # hash ref elements having two keys 'name' and 'text'
383             #
384             # otherwise false.
385             sub _check_components {
386             my $self = shift;
387              
388             # Sanity checks on internal state
389             if (!defined($self->{components})) {
390             $self->{log}->warn(q{no components in schema});
391             return;
392             } elsif (ref($self->{components}) ne 'ARRAY') {
393             $self->{log}->warn(q{components is not an ARRAY ref});
394             return;
395             } elsif (scalar(@{ $self->{components} } == 0)) {
396             $self->{log}->info(q{components is an empty ARRAY ref});
397             return;
398             }
399              
400             foreach my $comp (@{ $self->{components} }) {
401             if (ref($comp) ne q{HASH}) {
402             $self->{log}->warn(q{component element must be a HASH ref});
403             return;
404             }
405             if ( !exists($comp->{text})
406             || !exists($comp->{name}))
407             {
408             $self->{log}->warn(
409             q{component element must be a HASH ref with elements 'text' and 'name'}
410             );
411             return;
412             }
413             }
414              
415             return 1;
416             }
417              
418             # Sanity check on internal state.
419             #
420             # Return true if and only if
421             #
422             # $self->{classes} should be a defined array ref with 1 or more
423             # elements, all of which must be defined
424             #
425             # otherwise false.
426             sub _check_classes {
427             my $self = shift;
428              
429             # Sanity checks on internal state
430             if (!defined($self->{classes})) {
431             $self->{log}->warn(q{no classes in schema});
432             return;
433             } elsif (ref($self->{classes}) ne 'ARRAY') {
434             $self->{log}->warn(q{classes is not an ARRAY ref});
435             return;
436             } elsif (scalar(@{ $self->{classes} } == 0)) {
437             $self->{log}->info(q{classes is an empty ARRAY ref});
438             return;
439             }
440              
441             if (grep(!defined($_), (@{ $self->{classes} }))) {
442             $self->{log}
443             ->warn(q{the classes array reference contains an undefined element!});
444             return;
445             }
446              
447             return 1;
448             }
449              
450             # Sanity check on internal state.
451             #
452             # Return true if and only if
453             #
454             # $self->{associations} should be a defined array ref with 1 or more
455             # elements
456             #
457             # otherwise false.
458             sub _check_associations {
459             my $self = shift;
460              
461             # Sanity checks on internal state
462             if (!defined($self->{associations})) {
463             $self->{log}->warn(q{no associations in schema});
464             return;
465             } elsif (ref($self->{associations}) ne 'ARRAY') {
466             $self->{log}->warn(q{associations is not an ARRAY ref});
467             return;
468             } elsif (scalar(@{ $self->{associations} } == 0)) {
469             $self->{log}->info(q{associations is an empty ARRAY ref});
470             return;
471             }
472              
473             return 1;
474             }
475              
476             # Sanity check on given reference.
477             #
478             # Return true if and only if
479             #
480             # $arg should be a defined hash ref with 1 or more elements
481             # $arg->{name} exists and is a defined scalar
482             # $arg->{attList} exists and is a defined array ref.
483             #
484             # otherwise false.
485             sub _check_attlist {
486             my $self = shift;
487             my $arg = shift;
488              
489             # Sanity checks on internal state
490             if (!defined($arg) || ref($arg) ne q{HASH} || !exists($arg->{name})) {
491             $self->{log}->error(q{Error in ref input!});
492             return;
493             }
494             if (!exists($arg->{attList}) || ref($arg->{attList}) ne 'ARRAY') {
495             $self->{log}->error(q{Error in ref attList input!});
496             return;
497             }
498             return 1;
499             }
500              
501             sub _check_small_packages {
502             my $self = shift;
503              
504             # Sanity checks on internal state
505             if (!defined($self->{small_packages})
506             || ref($self->{small_packages}) ne q{ARRAY})
507             {
508             $self->{log}->error(q{small_packages error});
509             return;
510             }
511             my %seen = (); # Check for duplicate entries
512              
513             foreach my $sp (@{ $self->{small_packages} }) {
514             if (ref($sp) ne 'HASH') {
515             $self->{log}->error(q{Error in small_package input!});
516             return;
517             }
518             ++$seen{$_} for (keys %{$sp});
519             }
520             foreach my $key (keys %seen) {
521             $self->{log}->info(qq{Duplicate entry in small_package for key '$key' (}
522             . $seen{$key}
523             . q{ times)})
524             if $seen{$key} > 1;
525             }
526              
527             return 1;
528             }
529              
530             # create drop table for all tables
531             #
532             # TODO: Consider rename to get_table[s]_drop
533             sub get_schema_drop {
534             my $self = shift;
535             my $sqlstr = '';
536              
537             return unless $self->_check_classes();
538              
539             CLASS:
540             foreach my $object (@{ $self->{classes} }) {
541             next CLASS if ($object->{type} ne q{table});
542              
543             # Sanity checks on internal state
544             if (!defined($object)
545             || ref($object) ne q{HASH}
546             || !exists($object->{name}))
547             {
548             $self->{log}
549             ->error(q{Error in table input - cannot create drop table sql!});
550             next;
551             }
552              
553             $sqlstr .=
554             qq{drop table }
555             . $object->{name}
556             . $self->{end_of_statement}
557             . $self->{newline};
558             }
559              
560             return $sqlstr;
561              
562             }
563              
564             # Create revoke sql
565             sub get_permissions_drop {
566             my $self = shift;
567             my $sqlstr = '';
568              
569             # Check classes
570             return unless $self->_check_classes();
571              
572             # loop through classes looking for grants
573             foreach my $table (@{ $self->{classes} }) {
574              
575             foreach my $operation (@{ $table->{ops} }) {
576              
577             if (ref($operation) ne 'ARRAY') {
578             $self->{log}->error(
579             q{Error in ops input - expect an ARRAY ref, got } . ref($operation));
580             next OPERATION;
581             }
582              
583             my ($opname, $optype, $colref) =
584             ($operation->[0], $operation->[1], $operation->[2]);
585              
586             # 2nd element can be index, unique index, grant, etc
587             next if ($optype ne q{grant});
588              
589             # Add backticks if option is set and dbtype is correct
590             my $tablename = $self->_quote_identifier($table->{name});
591              
592             $sqlstr .=
593             qq{revoke $opname on }
594             . $tablename
595             . q{ from }
596             . join(q{,}, @{$colref})
597             . $self->{end_of_statement}
598             . $self->{newline};
599             }
600             }
601              
602             return $sqlstr;
603              
604             }
605              
606             # Create grant sql
607             sub get_permissions_create {
608             my $self = shift;
609             my $sqlstr = '';
610              
611             # Check classes
612             return unless $self->_check_classes();
613              
614             # loop through classes looking for grants
615             foreach my $table (@{ $self->{classes} }) {
616              
617             foreach my $operation (@{ $table->{ops} }) {
618              
619             if (ref($operation) ne 'ARRAY') {
620             $self->{log}->error(
621             q{Error in ops input - expect an ARRAY ref, got } . ref($operation));
622             next OPERATION;
623             }
624              
625             my ($opname, $optype, $colref) =
626             ($operation->[0], $operation->[1], $operation->[2]);
627              
628             # 2nd element can be index, unique index, grant, etc
629             next if ($optype ne q{grant});
630              
631             # Add backticks if option is set and dbtype is correct
632             my $tablename = $self->_quote_identifier($table->{name});
633              
634             $sqlstr .=
635             qq{$optype $opname on }
636             . $tablename . q{ to }
637             . join(q{,}, @{$colref})
638             . $self->{end_of_statement}
639             . $self->{newline};
640             }
641             }
642              
643             return $sqlstr;
644             }
645              
646             # Create associations statements:
647             #
648             # This includes the following elements, in the following sequence
649             #
650             # - index (unique and non-unique)
651             # - foreign key
652             sub get_associations_create {
653             my $self = shift;
654             my $sqlstr = '';
655              
656             # Check both ass. (fk) and classes (index) before operating on the
657             # array refs.
658              
659             # indices
660             if ($self->_check_classes()) {
661             foreach my $object (@{ $self->{classes} }) {
662             $sqlstr .= $self->_get_create_index_sql($object);
663             }
664             }
665              
666             # foreign keys
667             if ($self->_check_associations()) {
668             foreach my $object (@{ $self->{associations} }) {
669             $sqlstr .= $self->_get_create_association_sql($object);
670             }
671             }
672              
673             return $sqlstr;
674             }
675              
676             # Create table statements
677             sub get_schema_create {
678             my $self = shift;
679             my $sqlstr = '';
680              
681             return unless $self->_check_classes();
682              
683             CLASS:
684             foreach my $object (@{ $self->{classes} }) {
685             next CLASS if ($object->{type} ne q{table});
686             $sqlstr .= $self->_get_create_table_sql($object);
687             }
688              
689             return $sqlstr;
690             }
691              
692             # Create view statements
693             sub get_view_create {
694             my $self = shift;
695             my $sqlstr = '';
696              
697             return unless $self->_check_classes();
698              
699             VIEW:
700             foreach my $object (@{ $self->{classes} }) {
701             next VIEW if ($object->{type} ne q{view});
702             $sqlstr .= $self->_get_create_view_sql($object);
703             }
704              
705             return $sqlstr;
706             }
707              
708             # Create primary key clause, e.g.
709             #
710             # constraint pk_ primary key (,..,)
711             #
712             # Returns undefined if list of primary key is empty (i.e. if there are
713             # no primary keys on given table).
714             sub _create_pk_string {
715             my ($self, $tablename, @pks) = @_;
716              
717             if (!$tablename) {
718             $self->{log}
719             ->error(q{Missing argument tablename - cannot create pk string!});
720             return;
721             }
722              
723             # Return undefined if list of primary key is empty
724             if (scalar(@pks) == 0) {
725             $self->{log}->debug(qq{table '$tablename' has no primary keys});
726             return;
727             }
728              
729             return qq{constraint pk_$tablename primary key (} . join(q{,}, @pks) . q{)};
730             }
731              
732             # Create sql for given table. Use _format_columns() to
733             # format columns nicely (without the comment column)
734             sub _get_create_table_sql {
735             my ($self, $table) = @_;
736             my @columns = ();
737             my @primary_keys = ();
738             my @comments = ();
739              
740             # Sanity checks on table ref
741             return unless $self->_check_attlist($table);
742              
743             # Save the original table name (in case backticks are added)
744             my $original_table_name = $table->{name};
745              
746             # Add backticks if option is set and dbtype is correct
747             $table->{name} = $self->_quote_identifier($table->{name});
748              
749             # Check not null and primary key property for each column. Column
750             # visibility is given in $columns[3]. A value of 2 in this field
751             # signifies a primary key (which also must be defined as 'not null'.
752             foreach my $column (@{ $table->{attList} }) {
753              
754             if (ref($column) ne 'ARRAY') {
755             $self->{log}
756             ->error(q{Error in view attList input - expect an ARRAY ref!});
757             next COLUMN;
758             }
759              
760             # Don't warn on uninitialized values here since there are lots
761             # of them.
762              
763             ## no critic (ProhibitNoWarnings)
764             no warnings q{uninitialized};
765              
766             $self->{log}->debug("column before: " . join(q{,}, @$column));
767              
768             # Field sequence:
769             my ($col_name, $col_type, $col_val, $col_vis, $col_com, $col_nullable) = @$column;
770              
771             # Add 'not null' if field is primary key or marked "not nullable"
772             # (Dia database shape only)
773             if ($col_vis == 2) {
774             $col_val = 'not null';
775             } elsif ($col_nullable eq q{false}) {
776             $col_val = 'not null';
777             }
778              
779             # Add column name to list of primary keys if $col_vis == 2
780             push @primary_keys, $col_name if ($col_vis == 2);
781              
782             # Add 'default' keyword to defined values different from (not)
783             # null when the column is not a primary key:
784             # TODO: Special handling for SAS (in subclass)
785             if ($col_val ne q{} && $col_val !~ /^(not )?null$/i && $col_vis != 2) {
786             $col_val = qq{ default $col_val};
787             }
788              
789             # Prefix non-empty comments with the comment character
790             $col_com = $self->{sql_comment} . qq{ $col_com} if $col_com;
791              
792             if (!$self->{typemap}) {
793             $self->{log}->debug("no typemap");
794             }
795              
796             if (exists($self->{typemap}->{ $self->{db} })) {
797              
798             # typemap replace
799             $col_type = $self->map_user_type($col_type);
800             } else {
801             $self->{log}->debug("no typemap for " . $self->{db});
802             }
803              
804             # Add backticks to column name if option is enabled
805             $col_name = $self->_quote_identifier($col_name);
806              
807             $self->{log}->debug(
808             "column after : " . join(q{,}, $col_name, $col_type, $col_val, $col_com));
809              
810             # Create a line with out the comment
811             push @columns, [ $col_name, $col_type, $col_val ];
812              
813             # Comments are added separately *after* comma on each line
814             push @comments, $col_com; # possibly undef
815             }
816             $self->{log}->warn("No columns in table") if !scalar @columns;
817              
818             # Format columns nicely (without the comment column)
819             @columns = $self->_format_columns(@columns);
820             $self->{log}->debug("columns:" . Dumper(\@columns));
821             $self->{log}->debug("comments:" . Dumper(\@comments));
822              
823             # Add comma + newline + indent between the lines.
824             # Note that _create_pk_string can return undef.
825             @columns = (
826             split(
827             /$self->{newline}/,
828             join(
829             $self->{column_separator} . $self->{newline} . $self->{indent},
830             @columns, $self->_create_pk_string($original_table_name, @primary_keys)
831             )
832             )
833             );
834              
835             # Add the comment column, ensure the comma comes before the comment (if any)
836             {
837             ## no critic (ProhibitNoWarnings)
838             no warnings q{uninitialized};
839             @columns = map { $_ . shift(@comments) } @columns;
840             }
841             $self->{log}->debug("columns:" . Dumper(\@columns));
842              
843             # Add custom table postfix options if 'comment' section is defined
844             $self->{log}->debug("table comment:" . Dumper($table->{comment}));
845             if ($table->{comment}) {
846              
847             # Use comment only if it starts with given database type:
848             if ($table->{comment} =~ m/^$self->{db}:\s*(.*)$/) {
849              
850             # Remove db-type
851             my $table_comment = $1;
852              
853             # TODO: Add error checks on 'comment' input
854             $self->{table_postfix_options} = [$table_comment];
855             }
856              
857             }
858              
859             return
860             qq{create table }
861             . $table->{name} . " ("
862             . $self->{newline}
863             . $self->{indent}
864             . join($self->{newline}, @columns)
865             . $self->get_smallpackage_column_sql($table->{name})
866             . $self->{newline} . ")"
867             . $self->{indent}
868             . join(
869             $self->{table_postfix_options_separator},
870             @{ $self->{table_postfix_options} }
871             )
872             . $self->{end_of_statement}
873             . $self->{newline};
874             }
875              
876             # Format columns in tabular form using Text::Table.
877             #
878             # Input: arrayref of arrayrefs
879             # Output: arrayref of arrayrefs
880             sub _format_columns {
881             my ($self, @columns) = @_;
882             my @columns_out = ();
883              
884             $self->{log}->debug("input: " . Dumper(\@columns))
885             if $self->{log}->is_debug();
886              
887             my $tb = Text::Table->new();
888             $tb->load(@columns);
889              
890             # Take out one by one the formatted columns, remove newline character
891             push @columns_out, map { s/\n//g; $_ } $tb->body($_)
892             for (0 .. $tb->body_height());
893              
894             $self->{log}->debug("output: " . Dumper(@columns_out))
895             if $self->{log}->is_debug();
896             return @columns_out;
897             }
898              
899             # Create sql for given view.
900             #
901             # Similar to _get_create_table_sql, but must handle
902             # 'from',
903             # 'where',
904             # 'order by',
905             # 'group by',
906             #
907             # TODO: ADD support for 'having' clause.
908             sub _get_create_view_sql {
909             my ($self, $view) = @_;
910             my @columns = ();
911             my @from = ();
912             my @where = ();
913             my @orderby = ();
914             my @groupby = ();
915              
916             # Sanity checks on view ref
917             return unless $self->_check_attlist($view);
918              
919             COLUMN:
920             foreach my $column (@{ $view->{attList} }) {
921             $self->{log}->debug(q{column: } . Dumper($column));
922              
923             if (ref($column) ne 'ARRAY') {
924             $self->{log}
925             ->error(q{Error in view attList input - expect an ARRAY ref, got }
926             . ref($column));
927             next COLUMN;
928             }
929              
930             my $col_name = $column->[0]; # Pick first column
931             $self->{log}->debug(qq{col_name: $col_name});
932              
933             push @columns, join(q{ }, $col_name); # TODO: remove trailing whitespace
934             }
935              
936             OPERATION:
937             foreach my $operation (@{ $view->{ops} }) {
938             $self->{log}->debug($view->{name} . q{: operation: } . Dumper($operation));
939              
940             if (ref($operation) ne 'ARRAY') {
941             $self->{log}
942             ->error(q{Error in view attList input - expect an ARRAY ref, got }
943             . ref($operation));
944             next OPERATION;
945             }
946              
947             my ($opname, $optype) = ($operation->[0], $operation->[1]);
948              
949             # skip grants
950             next OPERATION if $optype eq q{grant};
951             if ($optype eq q{from}) {
952             push @from, $opname;
953             } elsif ($optype eq q{where}) {
954             push @where, $opname;
955             } elsif ($optype eq q{order by}) {
956             push @orderby, $opname;
957             } elsif ($optype eq q{group by}) {
958             push @groupby, $opname;
959             } else {
960              
961             # unsupported view operation type
962             $self->{log}->warn(qq{ unsupported view operation type '$optype'});
963             }
964             }
965              
966             my $retval =
967             qq{create view }
968             . $view->{name}
969             . q{ as select }
970             . $self->{newline}
971             . $self->{indent}
972             . join($self->{column_separator}, @columns)
973             . $self->{newline}
974             . $self->{indent}
975             . q{ from }
976             . join($self->{column_separator}, @from)
977             . $self->{newline}
978             . $self->{indent};
979              
980             # optional values
981             $retval .=
982             q{ where }
983             . join($self->{newline} . $self->{indent}, @where)
984             . $self->{newline}
985             . $self->{indent}
986             if (scalar(@where));
987             $retval .= q{ group by } . join($self->{column_separator}, @groupby)
988             if (scalar(@groupby));
989             $retval .= q{ order by } . join($self->{column_separator}, @orderby)
990             if (scalar(@orderby));
991              
992             # add semi colon or equivalent
993             $retval .= $self->{end_of_statement} . $self->{newline};
994             if ($self->{log}->is_debug()) {
995             $self->{log}->debug(q{view: $retval});
996             }
997             return $retval;
998             }
999              
1000             # Create sql for given association.
1001             sub _get_create_association_sql {
1002             my ($self, $association) = @_;
1003              
1004             # Sanity checks on input
1005             if (ref($association) ne 'ARRAY') {
1006             $self->{log}
1007             ->error(q{Error in association input - cannot create association sql!});
1008             return;
1009             }
1010              
1011             my (
1012             $table_name, $constraint_name, $key_column,
1013             $ref_table, $ref_column, $constraint_action
1014             ) = @{$association};
1015              
1016             # Shorten constraint name, if necessary (DB2 only)
1017             $constraint_name = $self->_create_constraint_name($constraint_name);
1018              
1019             # Add backticks to table names if option is enabled
1020             $table_name = $self->_quote_identifier($table_name);
1021             $ref_table = $self->_quote_identifier($ref_table);
1022              
1023             return
1024             qq{alter table $table_name add constraint $constraint_name }
1025             . $self->{newline}
1026             . $self->{indent}
1027             . qq{ foreign key ($key_column)}
1028             . $self->{newline}
1029             . $self->{indent}
1030             . qq{ references $ref_table ($ref_column) $constraint_action}
1031             . $self->{end_of_statement}
1032             . $self->{newline};
1033             }
1034              
1035             # Added only so that it can be overridden (e.g. in DB2.pm)
1036             sub _create_constraint_name {
1037             my ($self, $tablename) = @_;
1038             return if !$tablename;
1039             return $tablename;
1040             }
1041              
1042             # Create sql for all indices for given table.
1043             sub _get_create_index_sql {
1044             my ($self, $table) = @_;
1045             my $sqlstr = q{};
1046              
1047             # Sanity checks on input
1048             if (ref($table) ne 'HASH') {
1049             $self->{log}->error(q{Error in table input - cannot create index sql!});
1050             return;
1051             }
1052              
1053             OPERATION:
1054             foreach my $operation (@{ $table->{ops} }) {
1055              
1056             if (ref($operation) ne 'ARRAY') {
1057             $self->{log}->error(
1058             q{Error in ops input - expect an ARRAY ref, got } . ref($operation));
1059             next OPERATION;
1060             }
1061              
1062             # Extract elements (the stereotype is not in use)
1063             my ($opname, $optype, $colref, $opstereotype, $opcomment) = (
1064             $operation->[0], $operation->[1], $operation->[2],
1065             $operation->[3], $operation->[4]
1066             );
1067              
1068             # 2nd element can be index, unique index, grant, etc.
1069             # Accept "index" only in this context.
1070             if ($optype !~ qr/^(unique )?index$/i) {
1071             $self->{log}->debug(qq{Skipping optype '$optype' - not (unique) index});
1072             next OPERATION;
1073             }
1074              
1075             # Use operation comment as index option if defined, otherwise
1076             # use default (if any)
1077             my $idx_opt =
1078             (defined $opcomment && $opcomment ne q{})
1079             ? $opcomment
1080             : join(q{,}, @{ $self->{index_options} });
1081              
1082             $sqlstr .=
1083             qq{create $optype $opname on }
1084             . $table->{name} . q{ (}
1085             . join(q{,}, @{$colref}) . q{) }
1086             . $idx_opt
1087             . $self->{end_of_statement}
1088             . $self->{newline};
1089             }
1090             return $sqlstr;
1091             }
1092              
1093             # Common function for all smallpackage statements. Returns statements
1094             # for the parsed small packages that matches both db name and the
1095             # given keyword (e.g. 'post').
1096             sub _get_smallpackage_sql {
1097             my ($self, $keyword, $table_name) = @_;
1098              
1099             my @statements = ();
1100             return unless $self->_check_small_packages();
1101              
1102             # Each small package is a hash ref
1103             foreach my $sp (@{ $self->{small_packages} }) {
1104              
1105             # Foreach key in hash, pick those values whose
1106             # keys that contains db name and 'keyword':
1107             if ($table_name) {
1108             push @statements, map { $sp->{$_} }
1109             grep(/$self->{db}.*:\s*$keyword\s*\($table_name\)/, keys %{$sp});
1110             } else {
1111             push @statements,
1112             map { $sp->{$_} } grep(/$self->{db}.*:\s*$keyword/, keys %{$sp});
1113             }
1114             }
1115             return join($self->{newline}, @statements);
1116              
1117             }
1118              
1119             # Add SQL statements BEFORE generated code
1120             sub get_smallpackage_pre_sql {
1121             my $self = shift;
1122             return $self->_get_smallpackage_sql(q{pre});
1123             }
1124              
1125             # Add SQL statements AFTER generated code
1126             sub get_smallpackage_post_sql {
1127             my $self = shift;
1128             return $self->_get_smallpackage_sql(q{post});
1129             }
1130              
1131             # SQL clauses to add at the end of the named table definitions
1132             sub get_smallpackage_table_sql {
1133             my $self = shift;
1134             return $self->{log}->logdie("NOTIMPL");
1135             }
1136              
1137             # SQL clauses to add at the end of the named table primary key
1138             # constraints
1139             sub get_smallpackage_pk_sql {
1140             my $self = shift;
1141             return $self->{log}->logdie("NOTIMPL");
1142             }
1143              
1144             # SQL clauses to add at the end of the named table column definitions
1145             sub get_smallpackage_column_sql {
1146             my $self = shift;
1147             my ($table_name) = @_;
1148              
1149             my $clause = $self->_get_smallpackage_sql(q{columns}, $table_name);
1150              
1151             if ($clause ne '') {
1152             $clause =~ s/\n(.*?)/\n$self->{indent}$1/g;
1153             $clause = ',' . $self->{newline} . $self->{indent} . $clause;
1154             return $clause;
1155             }
1156             return '';
1157             }
1158              
1159             # SQL clauses to add at the end of the named table index definitions
1160             sub get_smallpackage_index_sql {
1161             my $self = shift;
1162             return $self->{log}->logdie("NOTIMPL");
1163             }
1164              
1165             # store macro for generating statements BEFORE generated code
1166             sub get_smallpackage_macropre_sql {
1167             my $self = shift;
1168             return $self->{log}->logdie("NOTIMPL");
1169             }
1170              
1171             # store macro for generating statements AFTER generated code
1172             sub get_smallpackage_macropost_sql {
1173             my $self = shift;
1174             return $self->{log}->logdie("NOTIMPL");
1175             }
1176              
1177             # typemap replace
1178             sub map_user_type {
1179             my ($self, $col_type) = @_;
1180              
1181             return $col_type if !$self->{typemap};
1182             return $col_type if !exists($self->{typemap}->{ $self->{db} });
1183              
1184             #$self->{log}->debug("typemap: " . Dumper($self->{typemap}));
1185              
1186             my ($orgname, $orgsize) = $self->{utils}->split_type($col_type);
1187              
1188             #return $col_type if !exists( $self->{typemap}->{ $self->{db} }->{$orgname} );
1189              
1190             if (exists($self->{typemap}->{ $self->{db} }->{$orgname})) {
1191              
1192             my $arref = $self->{typemap}->{ $self->{db} }->{$orgname};
1193              
1194             no warnings q[uninitialized];
1195             my ($newname, $newsize) = @$arref;
1196              
1197             #$self->{log}->debug("typemap arref match: " . Dumper($arref));
1198              
1199             # return newname + newsize if orgsize is undef
1200             return $newname . $newsize if !$orgsize;
1201              
1202             # return newname + newsize if orgsize equals newsize
1203             return $newname . $newsize if $orgsize eq $newsize;
1204              
1205             # return newname + orgsize if newsize is undef
1206             return $newname . $orgsize if !$newsize;
1207              
1208             # else error
1209             $self->{log}
1210             ->error(qq[Error in typemap usage: Cannot map from $col_type to $newname]
1211             . $newsize);
1212             }
1213              
1214             # Return the original type is we can't find a typemap replacement
1215             return $col_type;
1216             }
1217              
1218             # Add quotes (backticks) to identifier if option is set and db-type
1219             # supports it (i.e. mysql-innodb). See also Output/MySQL/InnoDB.pm
1220             sub _quote_identifier {
1221             my ($self, $identifier) = @_;
1222             return $identifier;
1223             }
1224              
1225             1;
1226              
1227             __END__