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
  36 sub columns {
  37   my($proto, $dbh, $table ) = @_;
  38   my $oldkhv=$dbh->{FetchHashKeyName};
  39   $dbh->{FetchHashKeyName}="NAME";
  40   my $sth = $dbh->prepare("SHOW COLUMNS FROM $table") or die $dbh->errstr;
  41   $sth->execute or die $sth->errstr;
  42   my @r = map {
  43     $_->{'Type'} =~ /^(\w+)\(?([^)]+)?\)?( \d+)?$/
  44       or die "Illegal type: ". $_->{'Type'}. "\n";
  45     my($type, $length) = ($1, $2);
  46     [
  47       $_->{'Field'},
  48       $type,
  49       $_->{'Null'},
  50       $length,
  51       $_->{'Default'},
  52       $_->{'Extra'}
  53     ]
  54   } @{ $sth->fetchall_arrayref( {} ) };
  55   $dbh->{FetchHashKeyName}=$oldkhv;
  56   @r;
  57 }
  58
  59 #sub primary_key {
  60 #  my($proto, $dbh, $table ) = @_;
  61 #  my $primary_key = '';
  62 #  my $sth = $dbh->prepare("SHOW INDEX FROM $table")
  63 #    or die $dbh->errstr;
  64 #  $sth->execute or die $sth->errstr;
  65 #  my @pkey = map { $_->{'Column_name'} } grep {
  66 #    $_->{'Key_name'} eq "PRIMARY"
  67 #  } @{ $sth->fetchall_arrayref( {} ) };
  68 #  scalar(@pkey) ? $pkey[0] : '';
  69 #}
  70
  71 sub primary_key {
  72   my($proto, $dbh, $table) = @_;
  73   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  74   $pkey;
  75 }
  76
  77 sub unique {
  78   my($proto, $dbh, $table) = @_;
  79   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  80   $unique_href;
  81 }
  82
  83 sub index {
  84   my($proto, $dbh, $table) = @_;
  85   my($pkey, $unique_href, $index_href) = $proto->_show_index($dbh, $table);
  86   $index_href;
  87 }
  88
  89 sub _show_index {
  90   my($proto, $dbh, $table ) = @_;
  91   my $oldkhv=$dbh->{FetchHashKeyName};
  92   $dbh->{FetchHashKeyName}="NAME";
  93   my $sth = $dbh->prepare("SHOW INDEX FROM $table")
  94     or die $dbh->errstr;
  95   $sth->execute or die $sth->errstr;
  96
  97   my $pkey = '';
  98   my(%index, %unique);
  99   foreach my $row ( @{ $sth->fetchall_arrayref({}) } ) {
 100     if ( $row->{'Key_name'} eq 'PRIMARY' ) {
 101       $pkey = $row->{'Column_name'};
 102     } elsif ( $row->{'Non_unique'} ) { #index
 103       push @{ $index{ $row->{'Key_name'} } }, $row->{'Column_name'};
 104     } else { #unique
 105       push @{ $unique{ $row->{'Key_name'} } }, $row->{'Column_name'};
 106     }
 107   }
 108   $dbh->{FetchHashKeyName}=$oldkhv;
 109
 110   ( $pkey, \%unique, \%index );
 111 }
 112
 113 sub column_callback {
 114   my( $proto, $dbh, $table, $column_obj ) = @_;
 115
 116   my $hashref = { 'explicit_null' => 1, };
 117
 118   $hashref->{'effective_local'} = 'AUTO_INCREMENT'
 119     if $column_obj->type =~ /^(\w*)SERIAL$/i;
 120
 121   if ( $column_obj->default =~ /^(NOW)\(\)$/i
 122        && $column_obj->type =~ /^(TIMESTAMP|DATETIME)$/i ) {
 123
 124     $hashref->{'effective_default'} = 'CURRENT_TIMESTAMP';
 125     $hashref->{'effective_type'} = 'TIMESTAMP';
 126
 127   }
 128
 129   $hashref;
 130
 131 }
 132
 133 =head1 AUTHOR
 134
 135 Ivan Kohler <ivan-dbix-dbschema@420.am>
 136
 137 =head1 COPYRIGHT
 138
 139 Copyright (c) 2000 Ivan Kohler
 140 Copyright (c) 2000 Mail Abuse Prevention System LLC
 141 Copyright (c) 2007 Freeside Internet Services, Inc.
 142 All rights reserved.
 143 This program is free software; you can redistribute it and/or modify it under
 144 the same terms as Perl itself.
 145
 146 =head1 BUGS
 147
 148 =head1 SEE ALSO
 149
 150 L<DBIx::DBSchema>, L<DBIx::DBSchema::DBD>, L<DBI>, L<DBI::DBD>
 151
 152 =cut
 153
 154 1;
 155