File Coverage

blib/lib/Apache/Voodoo/Table/Probe/MySQL.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

################################################################################
#
# Apache::Voodoo::Table::Probe::mysql
#
# Probes a MySQL database to get information about various tables.
#
# This is old and crufty and not for public use
#
################################################################################
package Apache::Voodoo::Table::Probe::MySQL;

$VERSION = "3.0200";

use strict;
use warnings;

use DBI;
use Tie::Hash::Indexed;

our $DEBUG = 0;

sub new {
	my $class = shift;
	my $self = {};

	$self->{'dbh'} = shift;

	bless $self, $class;
	return $self;
}

sub list_tables {
	my $self = shift;

	my $res = $self->{'dbh'}->selectall_arrayref("show tables") || die $DBI::errstr;

	return map { $_->[0] } @{$res};
}

sub probe_table {
	my $self = shift;

	my $table = shift;

	my $dbh = $self->{'dbh'};

	tie my %data, 'Tie::Hash::Indexed';

	$data{table} = $table;
	$data{primary_key} = '';

	tie my %columns, 'Tie::Hash::Indexed';
	$data{columns} = \%columns;

	# get foreign key infomation about the given table
	my $db_name = $dbh->{'Name'};
	$db_name =~ s/:.*//;
	my $sth = $dbh->foreign_key_info(undef,undef,undef,undef,$db_name,$table) || die DBI->errstr;
	my %foreign_keys;
	foreach (@{$sth->fetchall_arrayref()}) {
		next unless $_->[2];	# not a foreign key
		$foreign_keys{$_->[7]} = [ $_->[2], $_->[3] ];
	}

	# Sadly the column_info method doesn't tell us if the column is auto increment or not.
	# So we're going after the column info using ye olde explain.
	my $table_info = $dbh->selectall_arrayref("explain $table") || return { 'ERRORS' => [ "explain of table $table failed. $DBI::errstr" ] };
	foreach my $row (@{$table_info}) {
		my $name = $row->[0];

		tie my %column, 'Tie::Hash::Indexed';

		#
		# figure out the column type
		#
		my $type = $row->[1];
		my ($size) = ($type =~ /\(([\d,]+)\)/);

		$type =~ s/[,\d\(\) ]+/_/g;
		$type =~ s/_$//g;

		if ($self->can($type)) {
			$self->$type(\%column,$size);
		}
		else {
			push(@{$data{'ERRORS'}},"unsupported type $row->[1]");
		}

		# is this param required for add / edit (does the column allow nulls)
		$column{'required'} = 1 unless $row->[2] eq "YES";

		if ($row->[3] eq "PRI") {
			# primary key.  NOTE THAT CLUSTERED PRIMARY KEYS ARE NOT SUPPORTED
			$data{'primary_key'} = $name;

			# is the primary key user supplied
			unless ($row->[5] eq "auto_increment") {
				$data{'pkey_user_supplied'} = 1;
			}
		}
		elsif ($row->[3] eq "UNI") {
			# unique index.
			$column{'unique'} = 1;
		}

		#
		# figure out foreign keys
		#
		my $ref_table = '';
		my $ref_id    = '';
		if (scalar(%foreign_keys)) {
			# there are foreign keys defined for this table
			if (defined($foreign_keys{$name})) {
				# this column is a foreign key
				($ref_table,$ref_id) = @{$foreign_keys{$name}};
			}
		}
		elsif ($name =~ /^(\w+)_id$/) {
			# this column follows the standard naming convention
			# let's assume that it's supposed to be a foreign key.
			$ref_table = $1;
		}

		if ($ref_table) {
			my $ref_table_info = $dbh->selectall_arrayref("explain $ref_table");
			if (ref($ref_table_info)) {
				# figure out table structure

				my $ref_data = $self->probe_table($ref_table);

				tie my %ref_info, 'Tie::Hash::Indexed';
				%ref_info = (
					'table'          => $ref_table,
					'primary_key'    => $ref_id || $ref_data->{'primary_key'},
					'select_label'   => $ref_table,
					'select_default' => $row->[4],
					'columns'        => [
						grep { $ref_data->{'columns'}->{$_}->{'type'} eq "varchar" }
						keys %{$ref_data->{'columns'}}
					]
				);

				$column{'references'} = \%ref_info;
			}
			else {
				warn("No such table $ref_table: $DBI::errstr");
			}
		}

		$data{'columns'}->{$name} = \%column;
	}

	if (defined($data{'ERRORS'})) {
		print STDERR join("\n",@{$data{'ERRORS'}});
		print "\n";
		exit;
	}

	return \%data;
}

sub tinyint_unsigned   { shift()->int_handler_unsigned(@_,1); }
sub smallint_unsigned  { shift()->int_handler_unsigned(@_,2); }
sub mediumint_unsigned { shift()->int_handler_unsigned(@_,3); }
sub int_unsigned       { shift()->int_handler_unsigned(@_,4); }
sub integer_unsigned   { shift()->int_handler_unsigned(@_,4); }
sub bigint_unsigned    { shift()->int_handler_unsigned(@_,8); }

sub int_handler_unsigned {
	my ($self,$column,$size,$bytes) = @_;

	$column->{'type'}  = 'unsigned_int';
	$column->{'bytes'} = $bytes;
}

sub tinyint   { shift()->int_handler(@_,1); }
sub smallint  { shift()->int_handler(@_,2); }
sub mediumint { shift()->int_handler(@_,3); }
sub int       { shift()->int_handler(@_,4); }
sub integer   { shift()->int_handler(@_,4); }
sub bigint    { shift()->int_handler(@_,8); }

sub int_handler {
	my ($self,$column,$size,$bytes) = @_;

	$column->{'type'}  = 'signed_int';
	$column->{'bytes'} = $bytes;
}

sub text {
	my ($self,$column,$size) = @_;
	$column->{'type'} = 'text';
}

sub char {
	my $self = shift;
	$self->varchar(@_);
}

sub varchar {
	my ($self,$column,$size) = @_;

	$column->{'type'} = 'varchar';
	$column->{'length'} = $size;
}

sub decimal_unsigned {
	my ($self,$column,$size) = @_;

	my ($l,$r) = split(/,/,$size);

	$column->{'type'}   = 'unsigned_decimal';
	$column->{'left'}   = $l - $r;
	$column->{'right'}  = $r;
	$column->{'length'} = $r+$l+1;
}

sub decimal {
	my ($self,$column,$size) = @_;

	my ($l,$r) = split(/,/,$size);

	$column->{'type'}   = 'signed_decimal';
	$column->{'left'}   = $l - $r;
	$column->{'right'}  = $r;
	$column->{'length'} = $r+$l+2;
}

sub date {
	my ($self,$column,$size) = @_;

	$column->{'type'} = 'date';
}

sub time {
	my ($self,$column,$size) = @_;

	$column->{'type'} = 'time';
}

sub datetime {
	my ($self,$column,$size) = @_;

	$column->{'type'} = 'datetime';
}

sub timestamp {
	# timestamp is a 'magically' updated column that we don't touch
}

1;

################################################################################
# Copyright (c) 2005-2010 Steven Edwards ([e-mail]).
# All rights reserved.
#
# You may use and distribute Apache::Voodoo under the terms described in the
# LICENSE file include in this package. The summary is it's a legalese version
# of the Artistic License :)
#
################################################################################