Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Simple DBI Abstraction Class

by rob_au (Abbot)
on Aug 02, 2001 at 17:02 UTC ( [id://101631]=sourcecode: print w/replies, xml ) Need Help??
Category: Miscellaneous
Author/Contact Info rob_au
Description: A while ago, I asked the collective wisdom of the Monastery regarding Metadata and DBI Abstraction in the context of utilising a simplier DBI interface for a medium-to-large web site I was working on. From this node, I received a number of very useful suggestions and recommendations via both follow-up nodes and the chatterbox, one of which almost led me to distraction with Tangram. After this experience I set about re-inventing the wheel to a certain extent, implementing a very basic abstraction class (which I later found had many similarities, in a basic form, to BingoX::Carbon to which princepawn directed me).
 
To this end, I present this very simple DBI abstraction class which may help others, who like myself, have need for a simple DBI abstraction class with a minimal learning curve (although if I had the time, I think I would have gone down the path of BingoX::Carbon). This module has been written to interface a PostgreSQL database and introduces new, connect, disconnect, param, select_array and select_hash abstraction methods which should be very easy to use for anyone familiar with the DBI interface. At this stage, the commit method has not been implemented, this abstraction class representing a read-only interface at this point in time.
 
In practical terms, this abstraction class allowed me to build a catalogue and shopping interface to a PostgreSQL database comprised of more than 5,000 products in under a fortnight of development time.
 
package Simple::Abstraction;

use Carp;
use DBI;
use strict;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw();

our $VERSION = '0.33';

sub commit {
    my ($parent, $args) = @_;
    my ($self) = {};
    bless ($self);
    return undef unless (defined($parent->{dbh}));
    print STDERR "Simple::Abstraction->commit - Not implemented at thi
+s time\n" if ($parent->{debug});
    return;
};

sub connect {
    my ($param) = shift;
    my ($class) = ref($param) || $param;
    my ($parent) = {};
    bless ($parent, $class);
    my (%args) = @_;
    $parent->{debug} = ($args{'debug'} =~ /^\d+$/) ? $args{'debug'} : 
+0;
    $parent->{driver} = (length($args{'driver'})) ? $args{'driver'} : 
+"Pg";
    $parent->{username} = (length($args{'username'})) ? $args{'usernam
+e'} : undef;
    $parent->{password} = (length($args{'password'})) ? $args{'passwor
+d'} : undef;
    $parent->{database} = (length($args{'database'})) ? $args{'databas
+e'} : "test";
    $parent->{hostname} = (length($args{'hostname'})) ? $args{'hostnam
+e'} : "localhost";
    $parent->{dsn} = "DBI:" . $parent->{driver} . ":dbname=" . $parent
+->{database} . ";host=" . $parent->{hostname};

    print STDERR "Simple::Abstraction->connect - Creating connection t
+o DSN '", $parent->{dsn}, "'\n" if ($parent->{debug});

    unless ($parent->{dbh} = DBI->connect($parent->{dsn}, $parent->{us
+ername}, $parent->{password})) {
        croak "Cannot connect to '", $parent->{dsn}, "' - ", $DBI::err
+str, "\n";
    };
    return ($parent);
};

sub disconnect {
    my ($parent, $args) = @_;
    unless ($parent->{dbh}->disconnect) {
        croak "Cannot disconnect from '", $parent->{dsn}, "' - ", $DBI
+::errstr, "\n";
    };
    undef $parent;
    return 1;
};

sub new {
    my ($parent, $type, $args) = @_;
    my ($self) = {};
    bless ($self);
    return undef unless (defined($parent->{dbh}));

    $self->{type} = $type;
    $self->{parent} = \$parent;

    print STDERR "Simple::Abstraction->new - Creating new object of ty
+pe '", $self->{type}, "'\n" if (${$self->{parent}}->{debug});

    if (ref($args) eq 'HASH') {
        foreach my $param (keys(%{$args})) {
            $$args{$param} =~ s/\"/\\\"/g;
            eval qq/
                \$self->{data}->{$param} = "$$args{$param}";
            /;
            print STDERR "Simple::Abstraction->new - Setting parameter
+ '", $param, "' for object of type '", $self->{type}, "'\n" if (${$se
+lf->{parent}}->{debug});
        };
    };

    return ($self);
};

sub param {
    my ($self) = shift;
    my ($args) = @_;
    return undef unless (defined($self->{type}));

    if (ref($args) eq 'HASH') {
        foreach my $param (keys(%{$args})) {
            $$args{$param} =~ s/\"/\\\"/g;
            eval qq/
                \$self->{data}->{$param} = "$$args{$param}";
            /;
            print STDERR "Simple::Abstraction->param - Setting paramet
+er '", $param, "' for object of type '", $self->{type}, "'\n" if (${$
+self->{parent}}->{debug});
        };
    } elsif (defined($args)) {
        my ($param) = $args;
        if (defined($self->{data}->{$args})) {
            print STDERR "Simple::Abstraction->param - Returning param
+eter '", $args, "' for object of type '", $self->{type}, "'\n" if (${
+$self->{parent}}->{debug});
            return ($self->{data}->{$args});
        };
    } else {
        return (keys (%{$self->{data}}));
    };

    return;
};

sub select_array {
    my ($parent, $type, $args, $order) = @_;
    my ($self) = {};
    bless ($self);
    return undef unless (defined($parent->{dbh}));
    $self->{type} = $type;

    my (@results);

    print STDERR "Simple::Abstraction->select_array - Creating new arr
+ay for select results from table '", $self->{type}, "'\n" if ($parent
+->{debug});

    my ($sth) = $parent->{dbh}->prepare("select * from $self->{type}")
+;
    $sth->execute;

    my (@fields, @search);
    for (my $index = 0; $index < $sth->{NUM_OF_FIELDS}; $index++) {
        if (defined($$args{$sth->{NAME}->[$index]})) {
            push (@search, $sth->{NAME}->[$index]." ~~ '".$$args{$sth-
+>{NAME}->[$index]}."'");
        };
        push (@fields, $sth->{NAME}->[$index]);
    };
    my ($sth) = $parent->{dbh}->prepare("select * from $self->{type}" 
+.
        (($#search >= 0) ? " where ".join(" and ", @search) : undef) .
+ 
        ((ref($order) eq 'ARRAY') ? " order by ".join(", ", @{$order})
+ : undef)
    );
    $sth->execute;
    while (my (@row) = $sth->fetchrow_array) {
        my (%row);
        foreach my $field (@fields) {
            $row{$field} = shift(@row);
        };
        push (@results, $parent->new($self->{type}, \%row));
    };

    return (@results);
};


sub select_hash {
    my ($parent, $type, $args) = @_;
    my ($self) = {};
    bless ($self);
    return undef unless (defined($parent->{dbh}));
    $self->{type} = $type;

    my (%results);

    print STDERR "Simple::Abstraction->select_hash - Creating new hash
+ for select results from table '", $self->{type}, "'\n" if ($parent->
+{debug});

    my ($sth) = $parent->{dbh}->prepare("select * from $self->{type}")
+;
    $sth->execute;

    my (@fields, @search);
    for (my $index = 0; $index < $sth->{NUM_OF_FIELDS}; $index++) {
        if (defined($$args{$sth->{NAME}->[$index]})) {
            push (@search, $sth->{NAME}->[$index]." ~~ '".$$args{$sth-
+>{NAME}->[$index]}."'");
        };
        push (@fields, $sth->{NAME}->[$index]);
    };
    my ($sth) = $parent->{dbh}->prepare("select * from $self->{type}".
+(($#search >= 0) ? " where ".join(" and ", @search) : undef));
    $sth->execute;
    while (my (@row) = $sth->fetchrow_array) {
        my (%row);
        foreach my $field (@fields) {
            $row{$field} = shift(@row);
        };
        my ($result) = $parent->new($self->{type}, \%row);
        $results{$result->param($fields[0])} = $result;
    };

    return (%results);
};

1;

__END__

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://101631]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others about the Monastery: (5)
As of 2024-04-19 16:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found