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