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.08';
   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     $default = '' unless defined($default);
  52     $default = \0 if $default eq '0';
  53     $default = \'NOW()' if uc($default) eq 'CURRENT_TIMESTAMP';
  54
  55     [
  56       $_->{'Field'},
  57       $type,
  58       ( $_->{'Null'} =~ /^YES$/i ? 'NULL' : '' ),
  59       $length,
  60       $default,
  61       $_->{'Extra'}
  62     ]
  63   } @{ $sth->fetchall_arrayref( {} ) };
  64   $dbh->{FetchHashKeyName}=$oldkhv;
  65   @r;
  66 }
  67
  68 #sub primary_key {
  69 #  my($proto, $dbh, $table ) = @_;
  70 #  my $primary_key = '';
  71 #  my $sth = $dbh->prepare("SHOW INDEX FROM $table")
  72 #    or die $dbh->errstr;
  73 #  $sth->execute or die $sth->errstr;
  74 #  my @pkey = map { $_->{'Column_name'} } grep {
  75 #    $_->{'Key_name'} eq "PRIMARY"
  76 #  } @{ $sth->fetchall_arrayref( {} ) };
  77 #  scalar(@pkey) ? $pkey[0] : '';
  78 #}
  79
  80 sub primary_key {
  81   my($proto, $dbh, $table) = @_;
  82   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  83   $pkey;
  84 }
  85
  86 sub unique {
  87   my($proto, $dbh, $table) = @_;
  88   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  89   $unique_href;
  90 }
  91
  92 sub index {
  93   my($proto, $dbh, $table) = @_;
  94   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  95   $index_href;
  96 }
  97
  98 sub _show_index {
  99   my($proto, $dbh, $table ) = @_;
 100   my $oldkhv=$dbh->{FetchHashKeyName};
 101   $dbh->{FetchHashKeyName}="NAME";
 102   my $sth = $dbh->prepare("SHOW INDEX FROM $table")
 103     or die $dbh->errstr;
 104   $sth->execute or die $sth->errstr;
 105
 106   my $pkey = '';
 107   my(%index, %unique);
 108   foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) {
 109     if ( $row->{'Key_name'} eq 'PRIMARY' ) {
 110       $pkey = $row->{'Column_name'};
 111     } elsif ( $row->{'Non_unique'} ) { #index
 112       push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'};
 113     } else { #unique
 114       push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'};
 115     }
 116   }
 117   $dbh->{FetchHashKeyName}=$oldkhv;
 118
 119   ( $pkey, \%unique, \%index );
 120 }
 121
 122 sub column_callback {
 123   my( $proto, $dbh, $table, $column_obj ) = @_;
 124
 125   my $hashref = { 'explicit_null' => 1, };
 126
 127   $hashref->{'effective_local'} = 'AUTO_INCREMENT'
 128     if $column_obj->type =~ /^(\w*)SERIAL$/i;
 129
 130   if ( $column_obj->quoted_default =~ /^(NOW)\(\)$/i
 131        && $column_obj->type =~ /^(TIMESTAMP|DATETIME)$/i ) {
 132
 133     $hashref->{'effective_default'} = 'CURRENT_TIMESTAMP';
 134     $hashref->{'effective_type'} = 'TIMESTAMP';
 135
 136   }
 137
 138   $hashref;
 139
 140 }
 141
 142 sub alter_column_callback {
 143   my( $proto, $dbh, $table, $old_column, $new_column ) = @_;
 144   my $old_name = $old_column->name;
 145   my $new_def = $new_column->line($dbh);
 146
 147 # this would have been nice, but it appears to be doing too much...
 148
 149 #  return {} if $old_column->line($dbh) eq $new_column->line($dbh);
 150 #
 151 #  #{ 'sql_alter' =>
 152 #  { 'sql_alter_null' =>
 153 #      "ALTER TABLE $table CHANGE $old_name $new_def",
 154 #  };
 155
 156   return {} if $old_column->null eq $new_column->null;
 157   { 'sql_alter_null' =>
 158       "ALTER TABLE $table MODIFY $new_def",
 159   };
 160
 161
 162 }
 163
 164 =head1 AUTHOR
 165
 166 Ivan Kohler <ivan-dbix-dbschema@420.am>
 167
 168 =head1 COPYRIGHT
 169
 170 Copyright (c) 2000 Ivan Kohler
 171 Copyright (c) 2000 Mail Abuse Prevention System LLC
 172 Copyright (c) 2007-2010 Freeside Internet Services, Inc.
 173 All rights reserved.
 174 This program is free software; you can redistribute it and/or modify it under
 175 the same terms as Perl itself.
 176
 177 =head1 BUGS
 178
 179 =head1 SEE ALSO
 180
 181 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 182
 183 =cut
 184
 185 1;
 186