1package DBIx::Class::Schema::Loader::DBI::mysql;
2
3use strict;
4use warnings;
5use base 'DBIx::Class::Schema::Loader::DBI';
6use mro 'c3';
7use Carp::Clan qw/^DBIx::Class/;
8use List::Util qw/any first/;
9use Try::Tiny;
10use Scalar::Util 'blessed';
11use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/;
12use namespace::clean;
13use DBIx::Class::Schema::Loader::Table ();
14
15our $VERSION = '0.07049';
16
17=head1 NAME
18
19DBIx::Class::Schema::Loader::DBI::mysql - DBIx::Class::Schema::Loader::DBI mysql Implementation.
20
21=head1 DESCRIPTION
22
23See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
24
25=cut
26
27sub _setup {
28    my $self = shift;
29
30    $self->schema->storage->sql_maker->quote_char("`");
31    $self->schema->storage->sql_maker->name_sep(".");
32
33    $self->next::method(@_);
34
35    if (not defined $self->preserve_case) {
36        $self->preserve_case(0);
37    }
38
39    if ($self->db_schema && $self->db_schema->[0] eq '%') {
40        my @schemas = try {
41            $self->_show_databases;
42        }
43        catch {
44            croak "no SHOW DATABASES privileges: $_";
45        };
46
47        @schemas = grep {
48            my $schema = $_;
49            not any { lc($schema) eq lc($_) } $self->_system_schemas
50        } @schemas;
51
52        $self->db_schema(\@schemas);
53    }
54}
55
56sub _show_databases {
57    my $self = shift;
58
59    return map $_->[0], @{ $self->dbh->selectall_arrayref('SHOW DATABASES') };
60}
61
62sub _system_schemas {
63    my $self = shift;
64
65    return ($self->next::method(@_), 'mysql');
66}
67
68sub _table_fk_info {
69    my ($self, $table) = @_;
70
71    my $table_def_ref = eval { $self->dbh->selectrow_arrayref("SHOW CREATE TABLE ".$table->sql_name) };
72    my $table_def = $table_def_ref->[1];
73
74    return [] if not $table_def;
75
76    my $qt  = qr/["`]/;
77    my $nqt = qr/[^"`]/;
78
79    my (@reldata) = ($table_def =~
80        /CONSTRAINT ${qt}${nqt}+${qt} FOREIGN KEY \($qt(.*)$qt\) REFERENCES (?:$qt($nqt+)$qt\.)?$qt($nqt+)$qt \($qt(.+)$qt\)\s*(.*)/ig
81    );
82
83    my @rels;
84    while (scalar @reldata > 0) {
85        my ($cols, $f_schema, $f_table, $f_cols, $rest) = splice @reldata, 0, 5;
86
87        my @cols   = map { s/$qt//g; $self->_lc($_) }
88            split(/$qt?\s*$qt?,$qt?\s*$qt?/, $cols);
89
90        my @f_cols = map { s/$qt//g; $self->_lc($_) }
91            split(/$qt?\s*$qt?,$qt?\s*$qt?/, $f_cols);
92
93        # Match case of remote schema to that in SHOW DATABASES, if it's there
94        # and we have permissions to run SHOW DATABASES.
95        if ($f_schema) {
96            my $matched = first {
97                lc($_) eq lc($f_schema)
98            } try { $self->_show_databases };
99
100            $f_schema = $matched if $matched;
101        }
102
103        my $remote_table = do {
104            # Get ->tables_list to return tables from the remote schema, in case it is not in the db_schema list.
105            local $self->{db_schema} = [ $f_schema ] if $f_schema;
106
107            first {
108                lc($_->name) eq lc($f_table)
109                && ((not $f_schema) || lc($_->schema) eq lc($f_schema))
110            } $self->_tables_list;
111        };
112
113        # The table may not be in any database, or it may not have been found by the previous code block for whatever reason.
114        if (not $remote_table) {
115            my $remote_schema = $f_schema || $self->db_schema && @{ $self->db_schema } == 1 && $self->db_schema->[0];
116
117            $remote_table = DBIx::Class::Schema::Loader::Table->new(
118                loader => $self,
119                name   => $f_table,
120                ($remote_schema ? (
121                    schema => $remote_schema,
122                ) : ()),
123            );
124        }
125
126        my %attrs;
127
128        if ($rest) {
129            my @on_clauses = $rest =~ /(ON DELETE|ON UPDATE) (RESTRICT|CASCADE|SET NULL|NO ACTION) ?/ig;
130
131            while (my ($clause, $value) = splice @on_clauses, 0, 2) {
132                $clause = lc $clause;
133                $clause =~ s/ /_/;
134
135                $value = uc $value;
136
137                $attrs{$clause} = $value;
138            }
139        }
140
141# The default behavior is RESTRICT. Specifying RESTRICT explicitly just removes
142# that ON clause from the SHOW CREATE TABLE output. For this reason, even
143# though the default for these clauses everywhere else in Schema::Loader is
144# CASCADE, we change the default here to RESTRICT in order to reproduce the
145# schema faithfully.
146        $attrs{on_delete}     ||= 'RESTRICT';
147        $attrs{on_update}     ||= 'RESTRICT';
148
149# MySQL does not have a DEFERRABLE attribute, but there is a way to defer FKs.
150        $attrs{is_deferrable}   = 1;
151
152        push(@rels, {
153            local_columns => \@cols,
154            remote_columns => \@f_cols,
155            remote_table => $remote_table,
156            attrs => \%attrs,
157        });
158    }
159
160    return \@rels;
161}
162
163# primary and unique info comes from the same sql statement,
164#   so cache it here for both routines to use
165sub _mysql_table_get_keys {
166    my ($self, $table) = @_;
167
168    if(!exists($self->{_cache}->{_mysql_keys}->{$table->sql_name})) {
169        my %keydata;
170        my $sth = $self->dbh->prepare('SHOW INDEX FROM '.$table->sql_name);
171        $sth->execute;
172        while(my $row = $sth->fetchrow_hashref) {
173            next if $row->{Non_unique};
174            push(@{$keydata{$row->{Key_name}}},
175                [ $row->{Seq_in_index}, $self->_lc($row->{Column_name}) ]
176            );
177        }
178        foreach my $keyname (keys %keydata) {
179            my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] }
180                @{$keydata{$keyname}};
181            $keydata{$keyname} = \@ordered_cols;
182        }
183        $self->{_cache}->{_mysql_keys}->{$table->sql_name} = \%keydata;
184    }
185
186    return $self->{_cache}->{_mysql_keys}->{$table->sql_name};
187}
188
189sub _table_pk_info {
190    my ( $self, $table ) = @_;
191
192    return $self->_mysql_table_get_keys($table)->{PRIMARY};
193}
194
195sub _table_uniq_info {
196    my ( $self, $table ) = @_;
197
198    my @uniqs;
199    my $keydata = $self->_mysql_table_get_keys($table);
200    foreach my $keyname (sort keys %$keydata) {
201        next if $keyname eq 'PRIMARY';
202        push(@uniqs, [ $keyname => $keydata->{$keyname} ]);
203    }
204
205    return \@uniqs;
206}
207
208sub _columns_info_for {
209    my $self = shift;
210    my ($table) = @_;
211
212    my $result = $self->next::method(@_);
213
214    while (my ($col, $info) = each %$result) {
215        if ($info->{data_type} eq 'int') {
216            $info->{data_type} = 'integer';
217        }
218        elsif ($info->{data_type} eq 'double') {
219            $info->{data_type} = 'double precision';
220        }
221        my $data_type = $info->{data_type};
222
223        delete $info->{size} if $data_type !~ /^(?: (?:var)?(?:char(?:acter)?|binary) | bit | year)\z/ix;
224
225        # information_schema is available in 5.0+
226        my ($precision, $scale, $column_type, $default) = eval { $self->dbh->selectrow_array(<<'EOF', {}, $table->name, lc($col)) };
227SELECT numeric_precision, numeric_scale, column_type, column_default
228FROM information_schema.columns
229WHERE table_schema = schema() AND table_name = ? AND lower(column_name) = ?
230EOF
231        my $has_information_schema = not $@;
232
233        $column_type = '' if not defined $column_type;
234
235        if ($data_type eq 'bit' && (not exists $info->{size})) {
236            $info->{size} = $precision if defined $precision;
237        }
238        elsif ($data_type =~ /^(?:float|double precision|decimal)\z/i) {
239            if (defined $precision && defined $scale) {
240                if ($precision == 10 && $scale == 0) {
241                    delete $info->{size};
242                }
243                else {
244                    $info->{size} = [$precision,$scale];
245                }
246            }
247        }
248        elsif ($data_type eq 'year') {
249            if ($column_type =~ /\(2\)/) {
250                $info->{size} = 2;
251            }
252            elsif ($column_type =~ /\(4\)/ || $info->{size} == 4) {
253                delete $info->{size};
254            }
255        }
256        elsif ($data_type =~ /^(?:date(?:time)?|timestamp)\z/) {
257            if (not (defined $self->datetime_undef_if_invalid && $self->datetime_undef_if_invalid == 0)) {
258                $info->{datetime_undef_if_invalid} = 1;
259            }
260        }
261        elsif ($data_type =~ /^(?:enum|set)\z/ && $has_information_schema
262               && $column_type =~ /^(?:enum|set)\(/) {
263
264            delete $info->{extra}{list};
265
266            while ($column_type =~ /'((?:[^']* (?:''|\\')* [^']*)* [^\\']?)',?/xg) {
267                my $el = $1;
268                $el =~ s/''/'/g;
269                push @{ $info->{extra}{list} }, $el;
270            }
271        }
272
273        # Sometimes apparently there's a bug where default_value gets set to ''
274        # for things that don't actually have or support that default (like ints.)
275        if (exists $info->{default_value} && $info->{default_value} eq '') {
276            if ($has_information_schema) {
277                if (not defined $default) {
278                    delete $info->{default_value};
279                }
280            }
281            else { # just check if it's a char/text type, otherwise remove
282                delete $info->{default_value} unless $data_type =~ /char|text/i;
283            }
284        }
285    }
286
287    return $result;
288}
289
290sub _extra_column_info {
291    no warnings 'uninitialized';
292    my ($self, $table, $col, $info, $dbi_info) = @_;
293    my %extra_info;
294
295    if ($dbi_info->{mysql_is_auto_increment}) {
296        $extra_info{is_auto_increment} = 1
297    }
298    if ($dbi_info->{mysql_type_name} =~ /\bunsigned\b/i) {
299        $extra_info{extra}{unsigned} = 1;
300    }
301    if ($dbi_info->{mysql_values}) {
302        $extra_info{extra}{list} = $dbi_info->{mysql_values};
303    }
304    if ((not blessed $dbi_info) # isa $sth
305        && lc($dbi_info->{COLUMN_DEF})      eq 'current_timestamp'
306        && lc($dbi_info->{mysql_type_name}) eq 'timestamp') {
307
308        my $current_timestamp = 'current_timestamp';
309        $extra_info{default_value} = \$current_timestamp;
310    }
311
312    return \%extra_info;
313}
314
315sub _dbh_column_info {
316    my $self = shift;
317
318    local $SIG{__WARN__} = sigwarn_silencer(
319        qr/^column_info: unrecognized column type/
320    );
321
322    $self->next::method(@_);
323}
324
325sub _table_comment {
326    my ( $self, $table ) = @_;
327    my $comment = $self->next::method($table);
328    if (not $comment) {
329        ($comment) = try { $self->schema->storage->dbh->selectrow_array(
330            qq{SELECT table_comment
331                FROM information_schema.tables
332                WHERE table_schema = schema()
333                  AND table_name = ?
334            }, undef, $table->name);
335        };
336        # InnoDB likes to auto-append crap.
337        if (not $comment) {
338            # Do nothing.
339        }
340        elsif ($comment =~ /^InnoDB free:/) {
341            $comment = undef;
342        }
343        else {
344            $comment =~ s/; InnoDB.*//;
345        }
346    }
347    return $comment;
348}
349
350sub _column_comment {
351    my ( $self, $table, $column_number, $column_name ) = @_;
352    my $comment = $self->next::method($table, $column_number, $column_name);
353    if (not $comment) {
354        ($comment) = try { $self->schema->storage->dbh->selectrow_array(
355            qq{SELECT column_comment
356                FROM information_schema.columns
357                WHERE table_schema = schema()
358                  AND table_name = ?
359                  AND lower(column_name) = ?
360            }, undef, $table->name, lc($column_name));
361        };
362    }
363    return $comment;
364}
365
366sub _view_definition {
367    my ($self, $view) = @_;
368
369    return scalar $self->schema->storage->dbh->selectrow_array(
370        q{SELECT view_definition
371            FROM information_schema.views
372           WHERE table_schema = schema()
373             AND table_name = ?
374        }, undef, $view->name,
375    );
376}
377
378=head1 SEE ALSO
379
380L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
381L<DBIx::Class::Schema::Loader::DBI>
382
383=head1 AUTHORS
384
385See L<DBIx::Class::Schema::Loader/AUTHORS>.
386
387=head1 LICENSE
388
389This library is free software; you can redistribute it and/or modify it under
390the same terms as Perl itself.
391
392=cut
393
3941;
395# vim:et sw=4 sts=4 tw=0:
396