1package DBIx::Class::Schema::Loader::DBI::mysql; 2 3use strict; 4use warnings; 5use base 'DBIx::Class::Schema::Loader::DBI'; 6use Carp::Clan qw/^DBIx::Class/; 7use Class::C3; 8 9our $VERSION = '0.05003'; 10 11=head1 NAME 12 13DBIx::Class::Schema::Loader::DBI::mysql - DBIx::Class::Schema::Loader::DBI mysql Implementation. 14 15=head1 SYNOPSIS 16 17 package My::Schema; 18 use base qw/DBIx::Class::Schema::Loader/; 19 20 __PACKAGE__->loader_options( debug => 1 ); 21 22 1; 23 24=head1 DESCRIPTION 25 26See L<DBIx::Class::Schema::Loader::Base>. 27 28=cut 29 30sub _tables_list { 31 my $self = shift; 32 33 return $self->next::method(undef, undef); 34} 35 36sub _table_fk_info { 37 my ($self, $table) = @_; 38 39 my $dbh = $self->schema->storage->dbh; 40 my $table_def_ref = $dbh->selectrow_arrayref("SHOW CREATE TABLE `$table`") 41 or croak ("Cannot get table definition for $table"); 42 my $table_def = $table_def_ref->[1] || ''; 43 44 my $qt = qr/["`]/; 45 46 my (@reldata) = ($table_def =~ 47 /CONSTRAINT $qt.*$qt FOREIGN KEY \($qt(.*)$qt\) REFERENCES $qt(.*)$qt \($qt(.*)$qt\)/ig 48 ); 49 50 my @rels; 51 while (scalar @reldata > 0) { 52 my $cols = shift @reldata; 53 my $f_table = shift @reldata; 54 my $f_cols = shift @reldata; 55 56 my @cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; lc $_ } 57 split(/\s*,\s*/, $cols); 58 59 my @f_cols = map { s/(?: \Q$self->{_quoter}\E | $qt )//x; lc $_ } 60 split(/\s*,\s*/, $f_cols); 61 62 push(@rels, { 63 local_columns => \@cols, 64 remote_columns => \@f_cols, 65 remote_table => $f_table 66 }); 67 } 68 69 return \@rels; 70} 71 72# primary and unique info comes from the same sql statement, 73# so cache it here for both routines to use 74sub _mysql_table_get_keys { 75 my ($self, $table) = @_; 76 77 if(!exists($self->{_cache}->{_mysql_keys}->{$table})) { 78 my %keydata; 79 my $dbh = $self->schema->storage->dbh; 80 my $sth = $dbh->prepare('SHOW INDEX FROM '.$self->_table_as_sql($table)); 81 $sth->execute; 82 while(my $row = $sth->fetchrow_hashref) { 83 next if $row->{Non_unique}; 84 push(@{$keydata{$row->{Key_name}}}, 85 [ $row->{Seq_in_index}, lc $row->{Column_name} ] 86 ); 87 } 88 foreach my $keyname (keys %keydata) { 89 my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } 90 @{$keydata{$keyname}}; 91 $keydata{$keyname} = \@ordered_cols; 92 } 93 $self->{_cache}->{_mysql_keys}->{$table} = \%keydata; 94 } 95 96 return $self->{_cache}->{_mysql_keys}->{$table}; 97} 98 99sub _table_pk_info { 100 my ( $self, $table ) = @_; 101 102 return $self->_mysql_table_get_keys($table)->{PRIMARY}; 103} 104 105sub _table_uniq_info { 106 my ( $self, $table ) = @_; 107 108 my @uniqs; 109 my $keydata = $self->_mysql_table_get_keys($table); 110 foreach my $keyname (keys %$keydata) { 111 next if $keyname eq 'PRIMARY'; 112 push(@uniqs, [ $keyname => $keydata->{$keyname} ]); 113 } 114 115 return \@uniqs; 116} 117 118sub _extra_column_info { 119 no warnings 'uninitialized'; 120 my ($self, $info) = @_; 121 my %extra_info; 122 123 if ($info->{mysql_is_auto_increment}) { 124 $extra_info{is_auto_increment} = 1 125 } 126 if ($info->{mysql_type_name} =~ /\bunsigned\b/i) { 127 $extra_info{extra}{unsigned} = 1; 128 } 129 if ($info->{mysql_values}) { 130 $extra_info{extra}{list} = $info->{mysql_values}; 131 } 132 if ( $info->{COLUMN_DEF} =~ /^CURRENT_TIMESTAMP\z/i 133 && $info->{mysql_type_name} =~ /^TIMESTAMP\z/i) { 134 135 $extra_info{default_value} = \'CURRENT_TIMESTAMP'; 136 } 137 138 return \%extra_info; 139} 140 141=head1 SEE ALSO 142 143L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 144L<DBIx::Class::Schema::Loader::DBI> 145 146=head1 AUTHOR 147 148See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 149 150=head1 LICENSE 151 152This library is free software; you can redistribute it and/or modify it under 153the same terms as Perl itself. 154 155=cut 156 1571; 158