in reply to Inheritance and class hierarchies in Class::DBI

Recently I've been playing around with a class wrapper for tables that is pretty close to what you want. At present it goes something like this:

package DBManager;

use strict;
use warnings;
use DBI;
use Date::Manip;
use Class::Singleton;

our @ISA = qw(Class::Singleton);

1;

sub _new_instance {
    my $type = shift;
    my $class = ref $type || $type;
    
    die "DBManager::instance must be invoked as DBManager->instance" i
+f ! defined $class;
    
    my $dbh = DBI->connect("dbi:SQLite:databasefilename", "", "");

    die "Cannot connect to database: $DBI::errstr\n"
        unless defined $dbh;
        
    $dbh->{AutoCommit} = 0;
    $dbh->{RaiseError} = 1;

    return bless {dbh => $dbh}, $class;
}


sub DESTROY {
    my $self = shift;
    
    $self->{dbh}->disconnect () if defined $self->{dbh};
}


package DBObject;

require Exporter;
our @ISA = ('Exporter');

our @EXPORT = qw(new);

sub new {
    my ($class, %params) = @_;

    die "DBObject::new must be invoked as DBObject->new"
        unless defined $class;

    die "A table definition (tableDef => ['name', 'column info'] is re
+quired by $class->new ()"
        unless 'ARRAY' eq ref $params{tableDef};

    die "database handle must be from a DBManager derived object"
        if exists $params{db} and ! $params{db}->isa ('DBManager');

    my $self = bless {%params}, $class;
    my %cols = map {s/^\s*//; s/\s*$//; /(\w+)\s*(.*)/; $1 => $2}
        split /,/, $params{tableDef}[1];

    $self->{cols} = \%cols;    
    $self->setDbh ();
    
    return $self;
}


sub DESTROY {
    my $self = shift;
    
    $self->{db} = undef;
}

[download]
sub setDbh {
    my ($self) = @_;

    $self->{db} = DBManager->instance ();
    my $dbh = $self->{db}->{dbh};
    my ($tableName, $columns) = @{$self->{tableDef}};
    
    eval {
        $dbh->do ("CREATE TABLE IF NOT EXISTS $tableName ($columns)");
        $dbh->commit ();
        $self->{tableName} = $tableName;
    };
    
    die "$@" if $@;
}


sub dbh {
    my $self = shift;
    my $db = $self->{db};
    
    die ref($self) . " requires a database handle to complete an actio
+n"
        unless defined $db and $db->isa ('DBManager');

    return $db->{dbh};
}


sub insert {
    my ($self, %params) = @_;
    my $dbh = $self->dbh ();
    my $mustCreate = 0;

    for (keys %params) {
        if (lc eq 'create') {
            $mustCreate = 1;
            delete $params{create};
            next;
        }
        
        $self->{values}{$_} ||= $params{$_};
    }

    my $colVals = '';
    my $colList = '';
    
    # Build column and value compare strings
    for my $col (keys %{$self->{cols}}) {
        my $type = $self->{cols}{$col};
        
        next if $col eq 'id';
        
        if (! exists $self->{values}{$col} or ! defined $self->{values
+}{$col}) {
            die "Value for $col missing in " . ref ($self) . "->insert
+ ()\n"
                if $type =~ /NOT NULL/i;
            next;
        }

        $colVals .= "'$self->{values}{$col}',";
        $colList .= "$col, ";
    }

    # Trim bogus trailing stuff
    s/,\s*$// for $colList, $colVals;
    
    my $results = $self->fetch_all (%params);

    die "Record to be inserted exists in " . ref ($self) . "->insert (
+)\n"
        if %$results and $mustCreate;

    # create record if it doesn't exist already
    if (! %$results) {
        # Insert the record
        my $stmt = "INSERT INTO $self->{tableName} ($colList) VALUES (
+$colVals)";

        $dbh->do ($stmt);
        $dbh->commit ();

        # Fetch newly inserted record
        $results = $self->fetch_all (%params);
    }

    ($self->{id}) = keys %$results;
    
    delete $self->{values};
    return $self->{id};
}


sub delete {
    my ($self) = @_;
    my $dbh = $self->dbh ();
    
    die "id required for delete" if ! defined $self->{id};
    
    eval {
        $dbh->do ("DELETE FROM $self->{tableDef}[0] WHERE id = '$self-
+>{id}'");
        $dbh->commit ();
        $self->{id} = undef;
    };
    
    if ($@) {
        $dbh->rollback ();
        die "Delete failed: $@";
    }
}


sub update {
    my ($self, %params) = @_;
    my $dbh = $self->dbh ();
    
    die "Assignment pairs must be provided in a values hash for Update
+"
        if ! exists $params{values};
    
    $params{match}{id} = $self->{id}
        unless exists $params{match} and defined $params{match};
    
    eval {
        my $results = $self->fetch_all (%{$params{match}});
        
        die "Record matching update spec not found" if ! %$results;
        
        my $assignments = '';
        
        for my $col (keys %{$params{values}}) {
            die "Bogus column name $col" unless exists $self->{cols}{$
+col};
            $assignments .= "$col = '$params{values}{$col}', ";
        }

        # Trim bogus trailing stuff
        $assignments =~ s/,\s*$//;
        
        # Update the record
        my ($id) = keys %$results;
        my $stmt = "UPDATE $self->{tableName} SET $assignments WHERE i
+d = $id";
        $dbh->do ($stmt);
        $dbh->commit ();
    };
    
    if ($@) {
        $dbh->rollback ();
        die "update failed: $@";
    }
    
    return $self->{id};
}


sub fetch {
    my ($self, %params) = @_;
    
    $params{id} = '$self->{id}' unless %params;
    
    my $colMatch = $self->BuildMatchList (%params);
    my $stmt = "SELECT ALL * FROM $self->{tableDef}[0] $colMatch";
    my $sth = $self->dbh ()->prepare ($stmt);

    $sth->execute ();
    return $sth->fetchrow_hashref ();
}


sub fetch_all {
    my ($self, %params) = @_;
    my $colMatch = '';
    
    $colMatch = $self->BuildMatchList (%params)
        unless exists $params{match} and $params{match} eq 'ALL';
    
    my $stmt = "SELECT ALL * FROM $self->{tableDef}[0] $colMatch";
    my $sth = $self->dbh ()->prepare ($stmt);

    $sth->execute ();
    return $sth->fetchall_hashref ('id');
}


sub BuildMatchList {
    my ($self, %params) = @_;
    my $colMatch = '';

    # Build column compare strings
    for my $col (keys %params) {
        die "Bogus column name $col" unless exists $self->{cols}{$col}
+;
        $colMatch .= $col;
        if ('ARRAY' eq ref $params{$col}) {
            $colMatch .= $params{$col}[0];
        } else {
            $colMatch .= ' = ';

            if ($params{$col} =~ /'/) {
                $colMatch .= "$params{$col}";
            } else {
                $colMatch .= "'$params{$col}'";
            }
        }

        $colMatch .= " AND ";
    }

    # Trim bogus trailing stuff
    $colMatch =~ s/ AND $//;
    $colMatch = "WHERE $colMatch" if length $colMatch;
    
    return $colMatch;
}

[download]
1;


package Group;

use base 'DBObject';
require Exporter;
our @ISA = ('DBObject');
our @EXPORT = qw( );

my $groupTableDef = ['groups',
     'id INTEGER PRIMARY KEY NOT NULL,
     groupid INTEGER NOT NULL,
     user INTEGER NOT NULL'
    ];


sub new {
    my ($class, %params) = @_;
    
    $params{tableDef} = $groupTableDef unless exists $params {tableDef
+};
    return $class->SUPER::new (%params);
}

1;

[download]

It would be pretty easy to add columns to the table definition in derived classes rather than expecting the most derived class to supply the whole thing, although I've not had a need for that yet so it's not done that way.

Given that Task is derived from DBObject with a 'starts' column you can do stuff like: 

    my $task = Task->new;
    my $now = Date::Manip::ParseDate ('today');
    my $tasks = $task->fetch_all (starts => ["<= '$now'"]);
    my @readyTasks =
        sort {$a->{starts} cmp $b->{starts}} values %$tasks;

[download]
DWIM is Perl's answer to Gödel

In Section Seekers of Perl Wisdom