DBSchema/DBD/mysql.pm

   1 package DBIx::DBSchema::DBD::mysql;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA %typemap);
   5 use DBIx::DBSchema::DBD;
   6
   7 $VERSION = '0.09';
   8 @ISA = qw(DBIx::DBSchema::DBD);
   9
  10 %typemap = (
  11   'TIMESTAMP'      => 'DATETIME',
  12   'SERIAL'         => 'INTEGER',
  13   'BIGSERIAL'      => 'BIGINT',
  14   'BOOL'           => 'TINYINT',
  15   'LONG VARBINARY' => 'LONGBLOB',
  16   'TEXT'           => 'LONGTEXT',
  17 );
  18
  19 =head1 NAME
  20
  21 DBIx::DBSchema::DBD::mysql - MySQL native driver for DBIx::DBSchema
  22
  23 =head1 SYNOPSIS
  24
  25 use DBI;
  26 use DBIx::DBSchema;
  27
  28 $dbh = DBI->connect('dbi:mysql:database', 'user', 'pass');
  29 $schema = new_native DBIx::DBSchema $dbh;
  30
  31 =head1 DESCRIPTION
  32
  33 This module implements a MySQL-native driver for DBIx::DBSchema.
  34
  35 =cut
  36     use Data::Dumper;
  37
  38 sub columns {
  39   my($proto, $dbh, $table ) = @_;
  40   my $oldkhv=$dbh->{FetchHashKeyName};
  41   $dbh->{FetchHashKeyName}="NAME";
  42   my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr;
  43   $sth->execute or die $sth->errstr;
  44   my @r = map {
  45     #warn Dumper($_);
  46     $_->{'Type'} =~ /^(\w+)\(?([^)]+)?\)?( \d+)?$/
  47       or die "Illegal type: ". $_->{'Type'}. "\n";
  48     my($type, $length) = ($1, $2);
  49
  50     my $default = $_->{'Default'};
  51     if ( defined($default) ) {
  52       $default = \"''"    if $default eq '';
  53       $default = \0       if $default eq '0';
  54       $default = \'NOW()' if uc($default) eq 'CURRENT_TIMESTAMP';
  55     } else {
  56       $default = '';
  57     }
  58
  59     [
  60       $_->{'Field'},
  61       $type,
  62       ( $_->{'Null'} =~ /^YES$/i ? 'NULL' : '' ),
  63       $length,
  64       $default,
  65       $_->{'Extra'}
  66     ]
  67   } @{ $sth->fetchall_arrayref( {} ) };
  68   $dbh->{FetchHashKeyName}=$oldkhv;
  69   @r;
  70 }
  71
  72 #sub primary_key {
  73 #  my($proto, $dbh, $table ) = @_;
  74 #  my $primary_key = '';
  75 #  my $sth = $dbh->prepare("SHOW INDEX FROM $table")
  76 #    or die $dbh->errstr;
  77 #  $sth->execute or die $sth->errstr;
  78 #  my @pkey = map { $_->{'Column_name'} } grep {
  79 #    $_->{'Key_name'} eq "PRIMARY"
  80 #  } @{ $sth->fetchall_arrayref( {} ) };
  81 #  scalar(@pkey) ? $pkey[0] : '';
  82 #}
  83
  84 sub primary_key {
  85   my($proto, $dbh, $table) = @_;
  86   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  87   $pkey;
  88 }
  89
  90 sub unique {
  91   my($proto, $dbh, $table) = @_;
  92   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  93   $unique_href;
  94 }
  95
  96 sub index {
  97   my($proto, $dbh, $table) = @_;
  98   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  99   $index_href;
 100 }
 101
 102 sub _show_index {
 103   my($proto, $dbh, $table ) = @_;
 104   my $oldkhv=$dbh->{FetchHashKeyName};
 105   $dbh->{FetchHashKeyName}="NAME";
 106   my $sth = $dbh->prepare("SHOW INDEX FROM $table")
 107     or die $dbh->errstr;
 108   $sth->execute or die $sth->errstr;
 109
 110   my $pkey = '';
 111   my(%index, %unique);
 112   foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) {
 113     if ( $row->{'Key_name'} eq 'PRIMARY' ) {
 114       $pkey = $row->{'Column_name'};
 115     } elsif ( $row->{'Non_unique'} ) { #index
 116       push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'};
 117     } else { #unique
 118       push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'};
 119     }
 120   }
 121   $dbh->{FetchHashKeyName}=$oldkhv;
 122
 123   ( $pkey, \%unique, \%index );
 124 }
 125
 126 sub column_callback {
 127   my( $proto, $dbh, $table, $column_obj ) = @_;
 128
 129   my $hashref = { 'explicit_null' => 1, };
 130
 131   $hashref->{'effective_local'} = 'AUTO_INCREMENT'
 132     if $column_obj->type =~ /^(\w*)SERIAL$/i;
 133
 134   if ( $column_obj->quoted_default =~ /^(NOW)\(\)$/i
 135        && $column_obj->type =~ /^(TIMESTAMP|DATETIME)$/i ) {
 136
 137     $hashref->{'effective_default'} = 'CURRENT_TIMESTAMP';
 138     $hashref->{'effective_type'} = 'TIMESTAMP';
 139
 140   }
 141
 142   # MySQL no longer supports defaults for text/blob columns
 143   if ( $column_obj->type =~ /(TEXT|BLOB)/i
 144        and defined $column_obj->default ) {
 145
 146     # There's no way to unset the default cleanly.
 147     # An empty string isn't quite right.
 148     $column_obj->{'default'} = undef;
 149   }
 150
 151   $hashref;
 152
 153 }
 154
 155 sub alter_column_callback {
 156   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 157   my $old_name = $old_column->name;
 158   my $new_def = $new_column->line($dbh);
 159
 160   my $hashref = {};
 161
 162   my %canonical = (
 163     'INTEGER'          => 'INT',
 164     'SERIAL'           => 'INT',
 165     'BIGSERIAL'        => 'BIGINT',
 166     'REAL'             => 'DOUBLE', #'FLOAT',
 167     'DOUBLE PRECISION' => 'DOUBLE',
 168   );
 169   foreach ($old_column, $new_column) {
 170     $_->type($canonical{uc($_->type)}) if $canonical{uc($_->type)};
 171   }
 172
 173   my %canonical_length = (
 174     'INT'      => 11,
 175     'BIGINT'   => 20,
 176     'DECIMAL' => '10,0',
 177   );
 178   $new_column->length( $canonical_length{uc($new_column->type)} )
 179     if $canonical_length{uc($new_column->type)}
 180     && ($new_column->length||'') eq '';
 181
 182   #change type/length
 183   if ( uc($old_column->type) ne uc($new_column->type)
 184        || ($old_column->length||'') ne ($new_column->length||'')
 185      )
 186   {
 187     my $old_def = $old_column->line($dbh);
 188     $hashref->{'sql_alter_type'} =
 189       "CHANGE $old_name $new_def";
 190   }
 191
 192   #change nullability
 193   if ( $old_column->null ne $new_column->null ) {
 194     $hashref->{'sql_alter_null'} =
 195       "ALTER TABLE $table MODIFY $new_def";
 196   }
 197
 198   $hashref;
 199 }
 200
 201 =head1 AUTHOR
 202
 203 Ivan Kohler <ivan-dbix-dbschema@420.am>
 204
 205 =head1 COPYRIGHT
 206
 207 Copyright (c) 2000 Ivan Kohler
 208 Copyright (c) 2000 Mail Abuse Prevention System LLC
 209 Copyright (c) 2007-2013 Freeside Internet Services, Inc.
 210 All rights reserved.
 211 This program is free software; you can redistribute it and/or modify it under
 212 the same terms as Perl itself.
 213
 214 =head1 BUGS
 215
 216 =head1 SEE ALSO
 217
 218 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 219
 220 =cut
 221
 222 1;
 223