File Coverage

blib/lib/Class/Persistent/Plugin/MySQL.pm

Criterion	Covered	Total	%
statement	9	221	4.0
branch	1	102	0.9
condition	0	6	0.0
subroutine	3	14	21.4
pod	0	11	0.0
total	13	354	3.6

#
# Class::Persistent::Plugin::MySQL - Plugin to enable persistence through the MySQL-database.
# $Id$
#
# Copyright (C) 2000 by Heiko Wundram.
# All rights reserved.
#
# This program is free software; you can redistribute and/or modify it under the same terms as Perl itself.
#
# $Log$
#

package Class::Persistent::Plugin::MySQL;
$Class::Persistent::Plugin::MySQL::VERSION = '0.01';

use DBI qw(:sql_types);

use Carp;

sub new
{
    my ($class,$dsn,$user,$passwd) = @_;
    $class = ref $class ? ref $class : $class;
    my $dbh = DBI->connect( $dsn, $user, $passwd,
			    { PrintError => 0, RaiseError => 0 } )
	or confess("Cannot connect to database: $DBI::errstr!");
    my $self = {};

    $self->{"_dbh"} = $dbh;

    bless( $self, $class );

    return $self;
}

sub normalize_pkg
{
    my ($pkg) = @_;

    $pkg =~ s/:/_/g;
    return $pkg;
}

sub get_max_id
{
    if( @_ != 2 )
    {
	confess "get_max_id can only be called with one arguments!";
    }

    my ($class,$pkg) = @_;
    ref $class or confess "get_max_id can only be called on an instance of the storage class!";
    my $dbh = $class->{"_dbh"};
    my $db_pkg = normalize_pkg($pkg);
    my $sth;
    my $ret_val;

    ( $sth = $dbh->prepare("SELECT max(_id) FROM $db_pkg") )
	or confess("Something is really wrong with the database!");

    if( !$sth->execute() )
    {
	$ret_val = 0;
    }
    else
    {
	($ret_val) = $sth->fetchrow_array;
    }
    $sth->finish();

    return $ret_val+1;
}

sub load
{
    if( @_ < 3 || @_ > 4 )
    {
	confess "load can only be called with two or three arguments!";
    }

    my ($class,$out,$pkg,$type) = @_;
    ref $class or confess "load can only be called on an instance of the storage class!";
    ref $out or confess "load can only be called on an instance of the container class!";
    my $dbh = $class->{"_dbh"};
    my $db_pkg = normalize_pkg($pkg);
    my $sth = $class->{"_sth"};
    my $ret_val;
    my $set_val;
    my ($attribs,$types);

    if( $sth )
    {
	$set_val = $sth->fetchrow_hashref();
	if( !$set_val )
	{
	    $ret_val = 1;
	    $sth->finish();
	    delete $class->{"_sth"};
	}
	else
	{
	    $ret_val = 0;
	}
    }
    else
    {
	( $sth = $dbh->prepare("SELECT * FROM $db_pkg".($type?" WHERE $type":"")) )
	    or confess("Something is really wrong with the database!");

	if( !$sth->execute() )
	{
	    $set_val = undef;
	    $ret_val = -1;
	}
	else
	{
	    $set_val = $sth->fetchrow_hashref();
	    $ret_val = 0;
	    $class->{"_sth"} = $sth;
	}
    }

    if( $ret_val == 0 )
    {
	($attribs,$types) = split_hash($set_val);
	$out->set_attributes_type($attribs,$types);
    }

    return $ret_val;
}

sub split_hash
{
    if( @_ != 1 )
    {
	confess "split_hash can only be called with one argument!";
    }

    my ($set_val) = @_;
    my $key;
    my ($attribs,$types) = ({},{});

    foreach $key (keys %$set_val)
    {
	if( $key =~ /^(.*)_type$/ )
	{
	    $types->{$1} = $set_val->{$key};
	}
	else
	{
	    $attribs->{$key} = $set_val->{$key};
	}
    }

    return ($attribs,$types);
}

sub store
{
    if( @_ != 3 )
    {
	confess "store can only be called with two arguments!";
    }

    my ($class,$out,$pkg) = @_;
    ref $class or confess "store can only be called on an instance of the storage class!";
    ref $out or confess "store can only be called on an instance of the container class!";
    my $dbh = $class->{"_dbh"};
    my $db_pkg = normalize_pkg($pkg);
    my $sth;
    my ($attribs,$types);
    my ($statement_pre,$statement_post,$statement);
    my %binds;
    my @binds;
    my ($attrib,$i);

    ($attribs,$types) = $out->get_attributes_type();

    construct_table($dbh,$db_pkg,$types);

    $statement_pre = "INSERT INTO $db_pkg (";
    $statement_post = "VALUES (";
    $i = 1;

    foreach $attrib (keys %$attribs)
    {
	$binds{$i++} = $attribs->{$attrib};
	$binds{$i++} = $types->{$attrib};

	$statement_pre .= $attrib.",".$attrib."_type,";
	$statement_post .= "?,?,";
    }

    $statement_pre =~ s/,$//;
    $statement_post =~ s/,$//;

    $statement = $statement_pre.") ".$statement_post.")";

    ( $sth = $dbh->prepare($statement) )
	or confess("Something amiss with the database!");

    foreach $attrib (keys %binds)
    {
	$sth->bind_param($attrib,$binds{$attrib},SQL_VARCHAR);
    }

    return $sth->execute(@binds);
}

sub save
{
    if( @_ != 3 )
    {
	confess "save can only be called with two arguments!";
    }

    my ($class,$out,$pkg) = @_;
    ref $class or confess "save can only be called on an instance of the storage class!";
    ref $out or confess "save can only be called on an instance of the container class!";
    my $dbh = $class->{"_dbh"};
    my $db_pkg = normalize_pkg($pkg);
    my $sth;
    my ($attribs,$types);
    my $statement;
    my %binds;
    my ($attrib,$i);

    ($attribs,$types) = $out->get_attributes_type();

    construct_table($dbh,$db_pkg,$types);

    $statement = "UPDATE $db_pkg SET ";
    $i = 1;

    foreach $attrib (keys %$attribs)
    {
	$binds{$i++} = $attribs->{$attrib};
	$binds{$i++} = $types->{$attrib};

	$statement .= $attrib."=?,".$attrib."_type=?,";
    }

    $statement =~ s/,$//;

    $statement .= " WHERE _id = ".$attribs->{"_id"};

    ( $sth = $dbh->prepare($statement) )
	or confess("Something amiss with the database!");

    foreach $attrib (keys %binds)
    {
	$sth->bind_param($attrib,$binds{$attrib},SQL_VARCHAR);
    }

    return $sth->execute();
}

sub delete
{
    if( @_ != 3 )
    {
	confess "delete requires two arguments!";
    }

    my ($class,$out,$pkg) = @_;
    ref $class or confess "delete can only be called on an instance of the storage class!";
    ref $out or confess "delete can only be called on an instance of the container class!";
    my $dbh = $class->{"_dbh"};
    my $db_pkg = normalize_pkg($pkg);
    my $sth;
    my ($attribs,$types);
    my $statement;

    ($attribs,$types) = $out->get_attributes_type();

    $statement = "DELETE FROM $db_pkg WHERE _id = ".$attribs->{"_id"};

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    return $sth->execute();
}

sub calc_refs
{
    if( @_ != 3 )
    {
	confess "calc_refs requires two arguments!";
    }

    my ($class,$out,$pkg) = @_;
    ref $class or confess "calc_refs can only be called on an instance of the storage class!";
    ref $out or confess "calc_refs can only be called on an instance of the container class!";
    my $dbh = $class->{"_dbh"};
    my $sth;
    my ($attribs,$types);
    my $id;
    my (@tables,$table);
    my $refs;
    my $vals;
    my $key;

    ($attribs,$types) = $out->get_attributes_type();

    $id = $attribs->{"_id"}."|$pkg";

    $statement = "SELECT * FROM pkg_list";

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    $sth->execute();

    while( ($table) = $sth->fetchrow_array() )
    {
	push @tables, $table;
    }

    foreach $table (@tables)
    {
	$statement = "SELECT * FROM $table";

	( $sth = $dbh->prepare($statement) )
	    or confess("Something is amiss with the database!");

	$sth->execute();

	while( $vals = $sth->fetchrow_hashref() )
	{
	    foreach $key (keys %$vals)
	    {
		if( $key =~ /_type$/ )
		{
		    next;
		}

		if( $vals->{$key."_type"} eq 'c' )
		{
		    if( $vals->{$key} eq $id )
		    {
			$refs++;
		    }
		}
	    }
	}
    }

    return $refs;
}

sub check_tables
{
    if( @_ != 1 )
    {
	confess "check_tables takes no arguments!";
    }

    my ($class) = @_;
    ref $class or confess "delete can only be called on an instance of the storage class!";
    my $dbh = $class->{"_dbh"};
    my $sth;
    my $statement;
    my (@tables,$table);
    my $count;
    my @delete;

    $statement = "SELECT * FROM pkg_list";

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    $sth->execute();

    while( ($table) = $sth->fetchrow_array() )
    {
	push @tables, $table;
    }

    foreach $table (@tables)
    {
	$statement = "SELECT COUNT(*) FROM $table";

	( $sth = $dbh->prepare($statement) )
	    or confess("Something is amiss with the database!");

	$sth->execute();

	($count) = $sth->fetchrow_array();

	if( $count == 0 )
	{
	    push @delete, $table;
	}
    }

    foreach $table (@delete)
    {
	$statement = "DROP TABLE $table";

	( $sth = $dbh->prepare($statement) )
	    or confess("Something is amiss with the database!");

	$sth->execute();

	$statement = "DELETE FROM pkg_list WHERE pkg = '$table'";

	( $sth = $dbh->prepare($statement) )
	    or confess("Something is amiss with the database!");

	$sth->execute();
    }
}

sub construct_table
{
    if( @_ != 3 )
    {
	confess "construct_table can only be called with two arguments!";
    }

    my ($dbh,$db_pkg,$types) = @_;
    my $statement;
    my $field;

    $statement = "CREATE TABLE pkg_list (pkg VARCHAR(255) NOT NULL,UNIQUE (pkg))";

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    $sth->execute();

    $statement = "INSERT INTO pkg_list VALUES (?)";

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    $sth->bind_param(1,$db_pkg,SQL_VARCHAR);

    $sth->execute();

    $statement = "CREATE TABLE $db_pkg (";

    foreach $field (keys %$types)
    {
	$statement .= $field." ";

	if( $types->{$field} eq 'n' )
	{
	    $statement .= "BIGINT,";
	}
	elsif( $types->{$field} eq 's' || $types->{$field} eq 'c' )
	{
	    $statement .= "LONGTEXT,";
	}
	else
	{
	    $statement .= "LONGBLOB,";
	}

	$statement .= $field."_type CHAR(1),";
    }

    $statement =~ s/,$/\)/;

    ( $sth = $dbh->prepare($statement) )
	or confess("Something is amiss with the database!");

    return $sth->execute();
}

sub DESTROY
{
    my ($class) = @_;

    $class->{"_dbh"}->disconnect() or croak("Could not disconnect from Datasource!");
}

1;