<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package SQL::Translator::Parser::DBI::DB2;

=head1 NAME

SQL::Translator::Parser::DBI::DB2 - parser for DBD::DB2

=head1 SYNOPSIS

See SQL::Translator::Parser::DBI.

=head1 DESCRIPTION

Uses DBI methods to determine schema structure.  DBI, of course,
delegates to DBD::DB2.

=cut

use strict;
use warnings;
use DBI;
use Data::Dumper;
use SQL::Translator::Parser::DB2;
use SQL::Translator::Schema::Constants;

our ($DEBUG, $VERSION, @EXPORT_OK );
# $VERSION = '1.59';
$DEBUG   = 0 unless defined $DEBUG;

sub parse {
    my ( $tr, $dbh ) = @_;

    my $schema = $tr-&gt;schema;

    my ($sth, @tables, $columns);
    my $stuff;

    if ($dbh-&gt;{FetchHashKeyName} ne 'NAME_uc') {
        $dbh-&gt;{FetchHashKeyName} = 'NAME_uc';
    }

    if ($dbh-&gt;{ChopBlanks} != 1) {
        $dbh-&gt;{ChopBlanks} = 1;
    }

    my $tabsth = $dbh-&gt;prepare(&lt;&lt;SQL);
SELECT t.TABSCHEMA,
       t.TABNAME,
       t.TYPE,
      ts.TBSPACE
FROM SYSCAT.TABLES t
JOIN SYSCAT.TABLESPACES ts ON t.TBSPACEID = ts.TBSPACEID
WHERE t.TABSCHEMA NOT LIKE 'SYS%'
ORDER BY t.TABNAME ASC
SQL
#    $sth = $dbh-&gt;table_info();
#    @tables   = @{$sth-&gt;fetchall_arrayref({})};

    my $colsth = $dbh-&gt;prepare(&lt;&lt;SQL);
SELECT c.TABSCHEMA,
       c.TABNAME,
       c.COLNAME,
       c.TYPENAME,
       c.LENGTH,
       c.DEFAULT,
       c.NULLS,
       c.COLNO
FROM SYSCAT.COLUMNS c
WHERE c.TABSCHEMA NOT LIKE 'SYS%' AND
     c.TABNAME = ?
ORDER BY COLNO
SQL

    my $consth = $dbh-&gt;prepare(&lt;&lt;SQL);
SELECT tc.TABSCHEMA,
       tc.TABNAME,
       kc.CONSTNAME,
       kc.COLNAME,
       tc.TYPE,
       tc.CHECKEXISTINGDATA
FROM SYSCAT.TABCONST tc
JOIN SYSCAT.KEYCOLUSE kc ON tc.CONSTNAME = kc.CONSTNAME AND
                            tc.TABSCHEMA = kc.TABSCHEMA AND
                            tc.TABNAME   = kc.TABNAME
WHERE tc.TABSCHEMA NOT LIKE 'SYS%' AND
      tc.TABNAME = ?
SQL

    my $indsth = $dbh-&gt;prepare(&lt;&lt;SQL);
SELECT i.INDSCHEMA,
       i.INDNAME,
       i.TABSCHEMA,
       i.TABNAME,
       i.UNIQUERULE,
       i.INDEXTYPE,
       ic.COLNAME
FROM SYSCAT.INDEXES i
JOIN SYSCAT.INDEXCOLUSE ic ON i.INDSCHEMA = ic.INDSCHEMA AND
                              i.INDNAME = ic.INDNAME
WHERE i.TABSCHEMA NOT LIKE 'SYS%' AND
      i.INDEXTYPE &lt;&gt; 'P' AND
      i.TABNAME = ?
SQL

    my $trigsth = $dbh-&gt;prepare(&lt;&lt;SQL);
SELECT t.TRIGSCHEMA,
       t.TRIGNAME,
       t.TABSCHEMA,
       t.TRIGTIME,
       t.TRIGEVENT,
       t.GRANULARITY,
       t.TEXT
FROM SYSCAT.TRIGGERS t
WHERE t.TABSCHEMA NOT LIKE 'SYS%' AND
      t.TABNAME = ?
SQL

    $tabsth-&gt;execute();
    @tables = @{$tabsth-&gt;fetchall_arrayref({})};

    foreach my $table_info (@tables) {
        next
            unless (defined($table_info-&gt;{TYPE}));

# Why are we not getting system tables, maybe a parameter should decide?

        if ($table_info-&gt;{TYPE} eq 'T'&amp;&amp;
            $table_info-&gt;{TABSCHEMA} !~ /^SYS/) {
            print Dumper($table_info) if($DEBUG);
            print  $table_info-&gt;{TABNAME} if($DEBUG);
            my $table = $schema-&gt;add_table(
                                           name =&gt; $table_info-&gt;{TABNAME},
                                           type =&gt; 'TABLE',
                                          ) || die $schema-&gt;error;
            $table-&gt;options("TABLESPACE", $table_info-&gt;{TBSPACE});

            $colsth-&gt;execute($table_info-&gt;{TABNAME});
            my $cols = $colsth-&gt;fetchall_hashref("COLNAME");

            foreach my $c (values %{$cols}) {
                print Dumper($c) if $DEBUG;
                print $c-&gt;{COLNAME} if($DEBUG);
                my $f = $table-&gt;add_field(
                                        name        =&gt; $c-&gt;{COLNAME},
                                        default_value =&gt; $c-&gt;{DEFAULT},
                                        data_type   =&gt; $c-&gt;{TYPENAME},
                                        order       =&gt; $c-&gt;{COLNO},
                                        size        =&gt; $c-&gt;{LENGTH},
                                         ) || die $table-&gt;error;


                $f-&gt;is_nullable($c-&gt;{NULLS} eq 'Y');
            }

            $consth-&gt;execute($table_info-&gt;{TABNAME});
            my $cons = $consth-&gt;fetchall_hashref("COLNAME");
            next if(!%$cons);

            my @fields = map { $_-&gt;{COLNAME} } (values %{$cons});
            my $c = $cons-&gt;{$fields[0]};

            print  $c-&gt;{CONSTNAME} if($DEBUG);
            my $con = $table-&gt;add_constraint(
                                           name   =&gt; $c-&gt;{CONSTNAME},
                                           fields =&gt; \@fields,
                                           type   =&gt; $c-&gt;{TYPE} eq 'P' ?
                                           PRIMARY_KEY : $c-&gt;{TYPE} eq 'F' ?
                                           FOREIGN_KEY : UNIQUE
                                         ) || die $table-&gt;error;


            $con-&gt;deferrable($c-&gt;{CHECKEXISTINGDATA} eq 'D');

            $indsth-&gt;execute($table_info-&gt;{TABNAME});
            my $inds = $indsth-&gt;fetchall_hashref("INDNAME");
            print Dumper($inds) if($DEBUG);
            next if(!%$inds);

            foreach my $ind (keys %$inds)
            {
                print $ind if($DEBUG);
                $indsth-&gt;execute($table_info-&gt;{TABNAME});
                my $indcols = $indsth-&gt;fetchall_hashref("COLNAME");
                next if($inds-&gt;{$ind}{UNIQUERULE} eq 'P');

                print Dumper($indcols) if($DEBUG);

                my @fields = map { $_-&gt;{INDNAME} eq $ind ? $_-&gt;{COLNAME} : () }
                   (values %{$indcols});

                my $index = $indcols-&gt;{$fields[0]};

                my $inew = $table-&gt;add_index(
                                             name   =&gt; $index-&gt;{INDNAME},
                                             fields =&gt; \@fields,
                                             type   =&gt; $index-&gt;{UNIQUERULE} eq 'U' ?
                                             UNIQUE : NORMAL
                                             ) || die $table-&gt;error;


            }

            $trigsth-&gt;execute($table_info-&gt;{TABNAME});
            my $trigs = $trigsth-&gt;fetchall_hashref("TRIGNAME");
            print Dumper($trigs);
            next if(!%$trigs);

            foreach my $t (values %$trigs)
            {
                print  $t-&gt;{TRIGNAME} if($DEBUG);
                my $trig = $schema-&gt;add_trigger(
                     name                  =&gt; $t-&gt;{TRIGNAME},
 #                      fields =&gt; \@fields,
                     perform_action_when   =&gt; $t-&gt;{TRIGTIME} eq 'A' ? 'after' :
                                              $t-&gt;{TRIGTIME} eq 'B' ? 'before':
                                              'instead',
                     database_event        =&gt; $t-&gt;{TRIGEVENT} eq 'I' ? 'insert'
                                            : $t-&gt;{TRIGEVENT} eq 'D' ? 'delete'
                                            : 'update',
                     action                =&gt; $t-&gt;{TEXT},
                     on_table              =&gt; $t-&gt;{TABNAME}
                                              ) || die $schema-&gt;error;

#             $trig-&gt;extra( reference =&gt; $def-&gt;{'reference'},
#                           condition =&gt; $def-&gt;{'condition'},
#                           granularity =&gt; $def-&gt;{'granularity'} );
            }

        }
    }

    return 1;
}

1;

# -------------------------------------------------------------------
# Time is a waste of money.
# Oscar Wilde
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

Jess Robinson &lt;lt&gt;castaway@desert-island.m.isar.de&lt;gt&gt;.

=head1 SEE ALSO

SQL::Translator, DBD::DB2.

=cut
</pre></body></html>