[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Informix.pm

package DBIx::Class::Schema::Loader::DBI::Informix;

use strict;
use warnings;
use mro 'c3';
use base qw/DBIx::Class::Schema::Loader::DBI/;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util 'looks_like_number';
use namespace::clean;

our $VERSION = '0.07002';

=head1 NAME

DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
Informix Implementation.

=head1 DESCRIPTION

See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.

=cut

sub _setup {
    my $self = shift;

    $self->next::method(@_);

    if (not defined $self->preserve_case) {
        $self->preserve_case(0);
    }
    elsif ($self->preserve_case) {
        $self->schema->storage->sql_maker->quote_char('"');
        $self->schema->storage->sql_maker->name_sep('.');
    }
}

sub _tables_list {
    my ($self, $opts) = @_;

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
select tabname from systables t
where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
EOF
    $sth->execute;

    my @tables = map @$_, @{ $sth->fetchall_arrayref };

    return $self->_filter_tables(\@tables, $opts);
}

sub _constraints_for {
    my ($self, $table, $type) = @_;

    my $dbh = $self->schema->storage->dbh;
    local $dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $dbh->prepare(<<'EOF');
select c.constrname, i.*
from sysconstraints c
join systables t on t.tabid = c.tabid
join sysindexes i on c.idxname = i.idxname
where t.tabname = ? and c.constrtype = ?
EOF
    $sth->execute($table, $type);
    my $indexes = $sth->fetchall_hashref('constrname');
    $sth->finish;

    my $cols = $self->_colnames_by_colno($table);

    my $constraints;
    while (my ($constr_name, $idx_def) = each %$indexes) {
        $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
    }

    return $constraints;
}

sub _idx_colnames {
    my ($self, $idx_info, $table_cols_by_colno) = @_;

    return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
}

sub _colnames_by_colno {
    my ($self, $table) = @_;

    my $dbh = $self->schema->storage->dbh;
    local $dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $dbh->prepare(<<'EOF');
select c.colname, c.colno
from syscolumns c
join systables t on c.tabid = t.tabid
where t.tabname = ?
EOF
    $sth->execute($table);
    my $cols = $sth->fetchall_hashref('colno');
    $cols = { map +($_, $cols->{$_}{colname}), keys %$cols };

    return $cols;
}

sub _table_pk_info {
    my ($self, $table) = @_;

    my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];

    return $pk;
}

sub _table_uniq_info {
    my ($self, $table) = @_;

    my $constraints = $self->_constraints_for($table, 'U');

    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
    return \@uniqs;
}

sub _table_fk_info {
    my ($self, $table) = @_;

    my $local_columns = $self->_constraints_for($table, 'R');

    my $dbh = $self->schema->storage->dbh;
    local $dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $dbh->prepare(<<'EOF');
select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
from sysconstraints c
join systables t on c.tabid = t.tabid
join sysreferences r on c.constrid = r.constrid
join sysconstraints rc on rc.constrid = r.primary
join systables rt on r.ptabid = rt.tabid
join sysindexes ri on rc.idxname = ri.idxname
where t.tabname = ? and c.constrtype = 'R'
EOF
    $sth->execute($table);
    my $remotes = $sth->fetchall_hashref('local_constraint');
    $sth->finish;

    my @rels;

    while (my ($local_constraint, $remote_info) = each %$remotes) {
        push @rels, {
            local_columns => $local_columns->{$local_constraint},
            remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})),
            remote_table => $remote_info->{remote_table},
        };
    }

    return \@rels;
}

# This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
# it doesn't work at all
sub _informix_datetime_precision {
    my @date_type = qw/DUMMY year  month day   hour   minute  second  fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
    my @start_end = (  [],   [1,5],[5,7],[7,9],[9,11],[11,13],[13,15],[15,16],    [16,17],    [17,18],    [18,19],    [19,20]    );

    my ($self, $collength) = @_;

    my $i = ($collength % 16) + 1;
    my $j = int(($collength % 256) / 16) + 1;
    my $k = int($collength / 256);

    my $len = $start_end[$i][1] - $start_end[$j][0];
    $len = $k - $len;

    if ($len == 0 || $j > 11) {
        return $date_type[$j] . ' to ' . $date_type[$i];
    }

    $k  = $start_end[$j][1] - $start_end[$j][0];
    $k += $len;

    return $date_type[$j] . "($k) to " . $date_type[$i];
}

sub _columns_info_for {
    my $self = shift;
    my ($table) = @_;

    my $result = $self->next::method(@_);

    my $dbh = $self->schema->storage->dbh;
    local $dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $dbh->prepare(<<'EOF');
select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
from syscolumns c
join systables t on c.tabid = t.tabid
left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
where t.tabname = ?
EOF
    $sth->execute($table);
    my $cols = $sth->fetchall_hashref('colname');
    $sth->finish;

    while (my ($col, $info) = each %$cols) {
        $col = $self->_lc($col);

        my $type = $info->{coltype} % 256;

        if ($type == 6) { # SERIAL
            $result->{$col}{is_auto_increment} = 1;
        }

        my $data_type = $result->{$col}{data_type};

        if (looks_like_number $data_type) {
            if ($type == 7) {
                $result->{$col}{data_type} = 'date';
            }
            elsif ($type == 10) {
                $result->{$col}{data_type} = 'datetime year to fraction(5)';
                # this doesn't work yet
#                $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
            }
            elsif ($type == 17 || $type == 52) {
                $result->{$col}{data_type} = 'bigint';
            }
            elsif ($type == 40) {
                $result->{$col}{data_type} = 'lvarchar';
                $result->{$col}{size}      = $info->{collength};
            }
            elsif ($type == 12) {
                $result->{$col}{data_type} = 'text';
            }
            elsif ($type == 11) {
                $result->{$col}{data_type}           = 'bytea';
                $result->{$col}{original}{data_type} = 'byte';
            }
            elsif ($type == 41) {
                # XXX no way to distinguish opaque types boolean, blob and clob
                $result->{$col}{data_type} = 'blob';
            }
            elsif ($type == 21) {
                $result->{$col}{data_type} = 'list';
            }
            elsif ($type == 20) {
                $result->{$col}{data_type} = 'multiset';
            }
            elsif ($type == 19) {
                $result->{$col}{data_type} = 'set';
            }
        }

        if ($type == 15) {
            $result->{$col}{data_type} = 'nchar';
        }
        elsif ($type == 16) {
            $result->{$col}{data_type} = 'nvarchar';
        }
        # XXX untested!
        elsif ($info->{coltype} == 2061) {
            $result->{$col}{data_type} = 'idssecuritylabel';
        }

        # XXX colmin doesn't work for min size of varchar columns, it's NULL
#        if (lc($data_type) eq 'varchar') {
#            $result->{$col}{size}[1] = $info->{colmin};
#        }
       
        my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};

        next unless $default_type;

        if ($default_type eq 'C') {
            my $current = 'current year to fraction(5)';
            $result->{$col}{default_value} = \$current;
        }
        elsif ($default_type eq 'T') {
            my $today = 'today';
            $result->{$col}{default_value} = \$today;
        }
        else {
            $default = (split ' ', $default, 2)[-1];

            $default =~ s/\s+\z// if looks_like_number $default;

            # remove trailing 0s in floating point defaults
            # disabled, this is unsafe since it might be a varchar default
            #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;

            $result->{$col}{default_value} = $default;
        }
    }

    # fix up data_types some more
    while (my ($col, $info) = each %$result) {
        my $data_type = $info->{data_type};

        if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
            delete $info->{size};
        }

        if (lc($data_type) eq 'decimal') {
            no warnings 'uninitialized';

            $info->{data_type} = 'numeric';

            my @size = @{ $info->{size} || [] };

            if ($size[0] == 16 && $size[1] == -4) {
                delete $info->{size};
            }
            elsif ($size[0] == 16 && $size[1] == 2) {
                $info->{data_type} = 'money';
                delete $info->{size};
            }
        }
        elsif (lc($data_type) eq 'smallfloat') {
            $info->{data_type} = 'real';
        }
        elsif (lc($data_type) eq 'float') {
            $info->{data_type} = 'double precision';
        }
        elsif ($data_type =~ /^n?(?:var)?char\z/i) {
            $info->{size} = $info->{size}[0];
        }
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>

=head1 AUTHOR

See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
# vim:et sw=4 sts=4 tw=0:
Commit	Line	Data
bc5afe55	1	package DBIx::Class::Schema::Loader::DBI::Informix;
	2
	3	use strict;
	4	use warnings;
942bd5e0	5	use mro 'c3';
bc5afe55	6	use base qw/DBIx::Class::Schema::Loader::DBI/;
bc5afe55	7	use Carp::Clan qw/^DBIx::Class/;
bc5afe55	8	use Scalar::Util 'looks_like_number';
2b74a06b	9	use namespace::clean;
bc5afe55	10
f671b630	11	our $VERSION = '0.07002';
bc5afe55	12
	13	=head1 NAME
	14
	15	DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
	16	Informix Implementation.
	17
	18	=head1 DESCRIPTION
	19
	20	See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
	21
	22	=cut
	23
	24	sub _setup {
	25	my $self = shift;
	26
	27	$self->next::method(@_);
	28
	29	if (not defined $self->preserve_case) {
	30	$self->preserve_case(0);
	31	}
b511f36e	32	elsif ($self->preserve_case) {
	33	$self->schema->storage->sql_maker->quote_char('"');
	34	$self->schema->storage->sql_maker->name_sep('.');
	35	}
bc5afe55	36	}
	37
	38	sub _tables_list {
	39	my ($self, $opts) = @_;
	40
	41	my $dbh = $self->schema->storage->dbh;
	42	my $sth = $dbh->prepare(<<'EOF');
	43	select tabname from systables t
	44	where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
	45	EOF
	46	$sth->execute;
	47
	48	my @tables = map @$_, @{ $sth->fetchall_arrayref };
	49
	50	return $self->_filter_tables(\@tables, $opts);
	51	}
	52
	53	sub _constraints_for {
	54	my ($self, $table, $type) = @_;
	55
	56	my $dbh = $self->schema->storage->dbh;
	57	local $dbh->{FetchHashKeyName} = 'NAME_lc';
	58
	59	my $sth = $dbh->prepare(<<'EOF');
	60	select c.constrname, i.*
	61	from sysconstraints c
	62	join systables t on t.tabid = c.tabid
	63	join sysindexes i on c.idxname = i.idxname
	64	where t.tabname = ? and c.constrtype = ?
	65	EOF
	66	$sth->execute($table, $type);
	67	my $indexes = $sth->fetchall_hashref('constrname');
	68	$sth->finish;
	69
	70	my $cols = $self->_colnames_by_colno($table);
	71
	72	my $constraints;
	73	while (my ($constr_name, $idx_def) = each %$indexes) {
	74	$constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
	75	}
	76
	77	return $constraints;
	78	}
	79
	80	sub _idx_colnames {
	81	my ($self, $idx_info, $table_cols_by_colno) = @_;
	82
	83	return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
	84	}
	85
	86	sub _colnames_by_colno {
	87	my ($self, $table) = @_;
	88
	89	my $dbh = $self->schema->storage->dbh;
	90	local $dbh->{FetchHashKeyName} = 'NAME_lc';
	91
	92	my $sth = $dbh->prepare(<<'EOF');
	93	select c.colname, c.colno
	94	from syscolumns c
	95	join systables t on c.tabid = t.tabid
	96	where t.tabname = ?
	97	EOF
	98	$sth->execute($table);
	99	my $cols = $sth->fetchall_hashref('colno');
100	$cols = { map +($_, $cols->{$_}{colname}), keys %$cols };
101
102	return $cols;
103	}
104
105	sub _table_pk_info {
106	my ($self, $table) = @_;
107
108	my $pk = (values %{ $self->_constraints_for($table, 'P') \|\| {} })[0];
109
110	return $pk;
111	}
112
113	sub _table_uniq_info {
114	my ($self, $table) = @_;
115
116	my $constraints = $self->_constraints_for($table, 'U');
117
118	my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
119	return \@uniqs;
120	}
121
122	sub _table_fk_info {
123	my ($self, $table) = @_;
124
125	my $local_columns = $self->_constraints_for($table, 'R');
126
127	my $dbh = $self->schema->storage->dbh;
128	local $dbh->{FetchHashKeyName} = 'NAME_lc';
129
130	my $sth = $dbh->prepare(<<'EOF');
131	select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
132	from sysconstraints c
133	join systables t on c.tabid = t.tabid
134	join sysreferences r on c.constrid = r.constrid
135	join sysconstraints rc on rc.constrid = r.primary
136	join systables rt on r.ptabid = rt.tabid
137	join sysindexes ri on rc.idxname = ri.idxname
138	where t.tabname = ? and c.constrtype = 'R'
139	EOF
140	$sth->execute($table);
141	my $remotes = $sth->fetchall_hashref('local_constraint');
142	$sth->finish;
143
144	my @rels;
145
146	while (my ($local_constraint, $remote_info) = each %$remotes) {
147	push @rels, {
148	local_columns => $local_columns->{$local_constraint},
149	remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})),
150	remote_table => $remote_info->{remote_table},
151	};
152	}
153
154	return \@rels;
155	}
156
f916de47	157	# This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
	158	# it doesn't work at all
	159	sub _informix_datetime_precision {
	160	my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
	161	my @start_end = ( [], [1,5],[5,7],[7,9],[9,11],[11,13],[13,15],[15,16], [16,17], [17,18], [18,19], [19,20] );
	162
	163	my ($self, $collength) = @_;
	164
	165	my $i = ($collength % 16) + 1;
	166	my $j = int(($collength % 256) / 16) + 1;
	167	my $k = int($collength / 256);
	168
	169	my $len = $start_end[$i][1] - $start_end[$j][0];
	170	$len = $k - $len;
	171
	172	if ($len == 0 \|\| $j > 11) {
	173	return $date_type[$j] . ' to ' . $date_type[$i];
	174	}
	175
	176	$k = $start_end[$j][1] - $start_end[$j][0];
	177	$k += $len;
	178
	179	return $date_type[$j] . "($k) to " . $date_type[$i];
	180	}
	181
bc5afe55	182	sub _columns_info_for {
	183	my $self = shift;
	184	my ($table) = @_;
	185
	186	my $result = $self->next::method(@_);
	187
	188	my $dbh = $self->schema->storage->dbh;
	189	local $dbh->{FetchHashKeyName} = 'NAME_lc';
	190
	191	my $sth = $dbh->prepare(<<'EOF');
c7e6dc1f	192	select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
bc5afe55	193	from syscolumns c
	194	join systables t on c.tabid = t.tabid
	195	left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
	196	where t.tabname = ?
	197	EOF
	198	$sth->execute($table);
	199	my $cols = $sth->fetchall_hashref('colname');
	200	$sth->finish;
	201
	202	while (my ($col, $info) = each %$cols) {
c7e6dc1f	203	$col = $self->_lc($col);
c7e6dc1f	204
bc5afe55	205	my $type = $info->{coltype} % 256;
	206
	207	if ($type == 6) { # SERIAL
	208	$result->{$col}{is_auto_increment} = 1;
	209	}
	210
c7e6dc1f	211	my $data_type = $result->{$col}{data_type};
	212
	213	if (looks_like_number $data_type) {
bc5afe55	214	if ($type == 7) {
	215	$result->{$col}{data_type} = 'date';
	216	}
	217	elsif ($type == 10) {
58f0690e	218	$result->{$col}{data_type} = 'datetime year to fraction(5)';
f916de47	219	# this doesn't work yet
f916de47	220	# $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
bc5afe55	221	}
c7e6dc1f	222	elsif ($type == 17 \|\| $type == 52) {
	223	$result->{$col}{data_type} = 'bigint';
	224	}
	225	elsif ($type == 40) {
	226	$result->{$col}{data_type} = 'lvarchar';
	227	$result->{$col}{size} = $info->{collength};
	228	}
	229	elsif ($type == 12) {
	230	$result->{$col}{data_type} = 'text';
	231	}
	232	elsif ($type == 11) {
	233	$result->{$col}{data_type} = 'bytea';
	234	$result->{$col}{original}{data_type} = 'byte';
	235	}
	236	elsif ($type == 41) {
	237	# XXX no way to distinguish opaque types boolean, blob and clob
	238	$result->{$col}{data_type} = 'blob';
	239	}
	240	elsif ($type == 21) {
	241	$result->{$col}{data_type} = 'list';
	242	}
	243	elsif ($type == 20) {
	244	$result->{$col}{data_type} = 'multiset';
	245	}
	246	elsif ($type == 19) {
	247	$result->{$col}{data_type} = 'set';
	248	}
	249	}
	250
	251	if ($type == 15) {
	252	$result->{$col}{data_type} = 'nchar';
	253	}
	254	elsif ($type == 16) {
	255	$result->{$col}{data_type} = 'nvarchar';
	256	}
	257	# XXX untested!
	258	elsif ($info->{coltype} == 2061) {
	259	$result->{$col}{data_type} = 'idssecuritylabel';
bc5afe55	260	}
bc5afe55	261
c7e6dc1f	262	# XXX colmin doesn't work for min size of varchar columns, it's NULL
	263	# if (lc($data_type) eq 'varchar') {
	264	# $result->{$col}{size}[1] = $info->{colmin};
	265	# }
	266
bc5afe55	267	my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
	268
	269	next unless $default_type;
	270
	271	if ($default_type eq 'C') {
c7e6dc1f	272	my $current = 'current year to fraction(5)';
bc5afe55	273	$result->{$col}{default_value} = \$current;
	274	}
	275	elsif ($default_type eq 'T') {
c7e6dc1f	276	my $today = 'today';
bc5afe55	277	$result->{$col}{default_value} = \$today;
	278	}
	279	else {
5cd983b7	280	$default = (split ' ', $default, 2)[-1];
25e1e7bf	281
25e1e7bf	282	$default =~ s/\s+\z// if looks_like_number $default;
bc5afe55	283
bc5afe55	284	# remove trailing 0s in floating point defaults
a60e0f45	285	# disabled, this is unsafe since it might be a varchar default
a60e0f45	286	#$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
bc5afe55	287
	288	$result->{$col}{default_value} = $default;
	289	}
	290	}
	291
c7e6dc1f	292	# fix up data_types some more
	293	while (my ($col, $info) = each %$result) {
	294	my $data_type = $info->{data_type};
	295
	296	if ($data_type !~ /^(?:[nl]?(?:var)?char\|decimal)\z/i) {
	297	delete $info->{size};
	298	}
	299
	300	if (lc($data_type) eq 'decimal') {
	301	no warnings 'uninitialized';
	302
	303	$info->{data_type} = 'numeric';
	304
	305	my @size = @{ $info->{size} \|\| [] };
	306
	307	if ($size[0] == 16 && $size[1] == -4) {
	308	delete $info->{size};
	309	}
	310	elsif ($size[0] == 16 && $size[1] == 2) {
	311	$info->{data_type} = 'money';
	312	delete $info->{size};
	313	}
	314	}
	315	elsif (lc($data_type) eq 'smallfloat') {
	316	$info->{data_type} = 'real';
	317	}
	318	elsif (lc($data_type) eq 'float') {
	319	$info->{data_type} = 'double precision';
	320	}
	321	elsif ($data_type =~ /^n?(?:var)?char\z/i) {
	322	$info->{size} = $info->{size}[0];
	323	}
	324	}
	325
bc5afe55	326	return $result;
	327	}
	328
	329	=head1 SEE ALSO
	330
	331	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	332	L<DBIx::Class::Schema::Loader::DBI>
	333
	334	=head1 AUTHOR
	335
	336	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	337
	338	=head1 LICENSE
	339
	340	This library is free software; you can redistribute it and/or modify it under
	341	the same terms as Perl itself.
	342
	343	=cut
	344
	345	1;
	346	# vim:et sw=4 sts=4 tw=0: