File Coverage

lib/Class/DBI/AutoIncrement.pm

Criterion	Covered	Total	%
statement	27	101	26.7
branch	0	36	0.0
condition	0	21	0.0
subroutine	9	17	52.9
pod	4	4	100.0
total	40	179	22.3

#################################################################
#
#   Class::DBI::AutoIncrement - Emulate auto-incrementing columns in a Class::DBI table
#
#   $Id: AutoIncrement.pm,v 1.7 2006/06/08 08:58:32 erwan Exp $
#
#   060412 erwan Created
#   060517 erwan Added croak when no other parent than Class::DBI::AutoIncrement
#   060607 erwan Fixed rt 19752, backward compatibility issue with create()
#   060607 erwan Refactor to use maximum_value_of() (credits to David Westbrook)
#
#################################################################

#################################################################
#
#   an object holding data describing one auto-incremented table.
#   in charge of incrementing that table's index
#
#################################################################

package Class::DBI::AutoIncrement::Descriptor;

use 5.006;
use strict;
use warnings;
use base qw(Class::Accessor);

Class::Accessor->mk_accessors('table',  # name of the table to auto-increment
			      'column', # name of the auto-incremented column in that table
			      'min',    # the start value for the index sequence
			      'step',   # the increment step of the index sequence
			      'cache',  # if true, the index value is cached instead of being queried upon each insert
			      'index',  # value of the index used at the last insert (if caching is on)
			      );

sub new { return bless({},__PACKAGE__); }

1;

#################################################################
#
#   Class::DBI::AutoIncrement
#
#################################################################

package Class::DBI::AutoIncrement;

use 5.006;
use strict;
use warnings;
use Carp qw(croak confess);

our $VERSION = '0.05';

# set at runtime by _set_inheritance()
our @ISA;

##################################################################
#
#   PRIVATE FUNCTIONS
#
##################################################################

#-----------------------------------------------------------------
#
#   _set_inheritance - make Class::DBI::AutoIncrement inherit from the same parents as the calling class
#                      see discussion below.
#

my $inherited = 0;

sub _set_inheritance {
    return if ($inherited);

    my($caller) = shift;
    no strict 'refs';

    my @parents = grep { $_ ne __PACKAGE__ } @{"$caller\::ISA"};
    croak __PACKAGE__." expects class $caller to inherit from at least 1 more parent class" if (scalar @parents == 0);

    # inherit from same parents as the calling class, this in order
    # to have the proper inheritance toward the local *::DBI class,
    # without having to know its name and explicitly 'use base' it

    # this might not always work, since it redefines the class hierarchy under time
    # plus we then require twice the same set of parent classes...
    # an alternative would be to emulate ::SUPER-> and skip __PACKAGE__ while
    # calling the methods insert() and create()...

    foreach my $class (@parents) {
        eval qq{ require $class; };
        if (defined $@ && $@ ne "") {
            confess "BUG: \'require $class\' failed because of: ".$@;
        }
    }
    push @ISA, @parents;

    $inherited = 1;
}

#-----------------------------------------------------------------
#
#   _get_descriptor - instanciate an object holding information about the calling class
#

my $descriptors;

sub _get_descriptor {
    my $class = shift;
    if (!exists $descriptors->{$class}) {
        $descriptors->{$class} = new Class::DBI::AutoIncrement::Descriptor($class);
    }
    return $descriptors->{$class};
}

#-----------------------------------------------------------------
#
#   _do_increment - increment sequence if needed, see insert() and create()
#

sub _do_increment {
    my($proto,$class,$values) = @_;

    _set_inheritance($class);

    my $info = _get_descriptor($class);

    # check that we know all that should be known (column name, table name...)
    if (!defined $info->column) {
        croak "no auto-incremented column has been specified for class $class.";
    }

    if (!defined $info->table) {
        croak "no database table has been specified for class $class.";
    }

    my $column = $info->column;

    # if the index column is not set, set it to its next known value
    if (!exists $values->{$column} || !defined $values->{$column}) {
	my $index;

	if (!defined $info->index) {

	    my $id = $proto->maximum_value_of($info->column);

	    if (defined $id) {
		$index = $id + $info->step;
	    } else {
		# table is empty, this will be the first row inserted
		$index = $info->min;
	    }

	    # if caching is on, save the index for next time we need it
	    if ($info->cache) {
		$info->index($index);
	    }
	} else {
	    # we are caching the index, and we know the current highest index
	    $info->index($info->step+$info->index);
	    $index = $info->index;
	}

        $values->{$column} = $index;
    }
}

##################################################################
#
#   PUBLIC (INHERITED) FUNCTIONS
#
##################################################################

#-----------------------------------------------------------------
#
#   autoincrement - register which column should be automatically incremented
#

sub autoincrement {
    my($proto,$column,%args) = @_;
    my $class = ref $proto || $proto;
    _set_inheritance($class);

    if (!defined $column) {
        croak "you must define a column name to autoincrement.";
    }

    my $info = _get_descriptor($class);

    if (defined $info->column()) {
        croak "class $class already has one auto-incremented column";
    }

    $info->column($column);

    if (exists $args{Min}) {
	if ($args{Min} !~ /^-?\d+$/) {
	    croak "parameter 'Min' of method 'autoincrement' must be a number.";
	}
	$info->min($args{Min});
    } else {
	$info->min(0);
    }

    if (exists $args{Step}) {
	if ($args{Step} !~ /^-?\d+$/) {
	    croak "parameter 'Step' of method 'autoincrement' must be a number.";
	}
	$info->step($args{Step});
    } else {
	$info->step(1);
    }

    if (exists $args{Cache} && $args{Cache}) {
	$info->cache(1);
    } else {
	$info->cache(0);
    }
}

#-----------------------------------------------------------------
#
#   table - override *::DBI->table() in order to intercept the table name
#

sub table {
    my($proto,$table,@args) = @_;
    my $class = ref $proto || $proto;
    _set_inheritance($class);

    if (defined $table) {
        my $info = _get_descriptor($class);
        $info->table($table);
    }

    return $class->SUPER::table($table,@args);
}

#-----------------------------------------------------------------
#
#   insert - insert a new value, after incrementing its sequence if necessary
#

sub insert {
    my($proto,$values) = @_;
    my $class = ref $proto || $proto;
    _do_increment($proto,$class,$values);
    return $class->SUPER::insert($values);
}

# backward compatibility
sub create {
    my($proto,$values) = @_;
    my $class = ref $proto || $proto;
    _do_increment($proto,$class,$values);
    return $class->SUPER::create($values);
}

1;

__END__