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.07';
   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->quoted_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-2010 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