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