libropkg-perl 0.4-1.2 / usr / share / perl5 / RoPkg / DBObject.pm

############################################################################
##      Copyright (C) 2005 Subredu Manuel                                  #
##      Author Subredu Manuel <diablo@iasi.roedu.net>                      #
##                                                                         #
## This program is free software; you can redistribute it and/or modify    #
## it under the terms of the GNU General Public License as published by    #
## the Free Software Foundation; either version 2 of the License, or       #
## (at your option) any later version.                                     #
##                                                                         #
## This program is distributed in the hope that it will be useful,         #
## but WITHOUT ANY WARRANTY; without even the implied warranty of          #
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the           #
## GNU General Public License for more details.                            #
##                                                                         #
## You should have received a copy of the GNU General Public License       #
## along with this program; if not, write to the Free Software             #
## Foundation, Inc., 59 Temple Place - Suite 330, Boston,                  #
## MA 02111-1307,USA.                                                      #
############################################################################

package RoPkg::DBObject;

use strict;
use warnings;

use Scalar::Util qw(blessed);
use English      qw(-no_match_vars);
use SQL::Abstract;

use RoPkg::DB;
use RoPkg::Object;
use RoPkg::Exceptions;
use RoPkg::Utils qw(CheckParam ElemInList);

use vars qw($VERSION $dbo_method);
use base qw(RoPkg::Object);

$VERSION = '0.1.4';

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

   CheckParam(\%opt, qw(dbo dbo_method));

   $dbo_method = $opt{dbo_method};
   $self = $class->SUPER::new(%opt);

   $self->_init();
   $self->_inject();

   return $self;
}

sub _init {
  my ($self) = @_;
  my $qc;

  if ( $self->{quote_char} ) {
    $qc = $self->{quote_char};
  }
  else {
    $qc = q{};
  }

  $self->{_sql_table} = '_this_must_be_set_';
  $self->{_sa} = SQL::Abstract->new( quote_char => $qc );

  return $self;
}

sub dbh {
  my ($self, $dbh) = @_;

  if (!blessed($self)) {
    OutsideClass->throw('Called outside class instance');
  }

  if ($dbh) {
    $self->{dbh} = $dbh;
  }
  else {
    $self->{dbh} = $self->{dbo}->$dbo_method();
  }

  return $self->{dbh};
}

sub dbo {
  my ($self, $dbo) = @_;

  if (!blessed($self)) {
    OutsideClass->throw('Called outside class instance');
  }

  if ($dbo) {
    $self->{dbo} = $dbo;
  }

  return $self->{dbo};
}

sub dbo_method {
  my ($self, $dbo_mt) = @_;
  
  if (!blessed($self)) {
    OutsideClass->throw('Called outside class instance');
  }

  if ($dbo_mt) {
    $self->{dbo_method} = $dbo_mt;
    $dbo_method = $dbo_mt;
  }

  return $dbo_method;
}

sub _build_where_hash {
  my ($self, @fields) = @_;
  my %data;

  if ( @fields ) {
    foreach(@fields) {
        if (! defined $self->{$_}) {
          Param::Missing->throw($_ . ' is not defined !');
        }
      $data{$_} = $self->{$_};
    }
  }

  return \%data;
}

sub _build_data_hash {
  my ($self, @fields) = @_;
  my %data;

  foreach(keys %{ $self->{methods} }) {
    next if ( ElemInList($_, @fields));
    if (defined $self->{$_}) {
      $data{$_} = $self->{$_};
    }
  }

  return \%data;
}

sub SQL_Insert {
  my ($self) = @_;
  my $data;
  my ($sth, $sql, @bval);

  $data  = $self->_build_data_hash();

  ($sql, @bval) = $self->{_sa}->insert($self->{_sql_table}, $data);
  $sth = $self->dbh()->prepare($sql);
  return $sth->execute(@bval);
}

sub SQL_Update {
  my ($self, @fields) = @_;
  my ($where, $data);
  my ($sth, $sql, @bval);

  $data  = $self->_build_data_hash(@fields);
  $where = $self->_build_where_hash(@fields);

  ($sql, @bval) = $self->{_sa}->update($self->{_sql_table}, $data, $where);
  $sth = $self->dbh()->prepare($sql);
  return $sth->execute(@bval);
}

sub SQL_Delete {
  my ($self, @fields) = @_;
  my ($where, $data);
  my ($sth, $sql, @bval);

  $data  = $self->_build_data_hash();
  $where = $self->_build_where_hash(@fields);

  ($sql, @bval) = $self->{_sa}->delete($self->{_sql_table}, $data, $where);
  $sth = $self->dbh()->prepare($sql);
  return $sth->execute(@bval);
}

sub SQL_Select {
  my ($self, @fields) = @_;
  my ($where);
  my ($sth, $sql, @bval);

  $where = $self->_build_where_hash(@fields);

  ($sql, @bval) = $self->{_sa}->select($self->{_sql_table}, q{*}, $where);
  $sql .= ' LIMIT 1';
  $sth = $self->dbh()->prepare($sql);
  $sth->execute(@bval);

  if ( $sth->rows == 0 ) {
    DB::NoResults->throw(
      message  => 'No records matched your query',
      pkg_name => ref $self);
  }
  
  my $result = $sth->fetchrow_hashref;

  foreach(keys %{ $result }) {
    $self->$_($result->{$_});
  }

  return 1;
}

sub _check_exceptions {
  my ($self) = @_;

  if (ref $EVAL_ERROR) {
    $EVAL_ERROR->rethrow;
  }
  else {
    if ($EVAL_ERROR) {
      die $EVAL_ERROR;
    }
  }

  #syntactic sugar
  return 1;
}

1;

__END__

=head1 NAME

 RoPkg::DBObject - General pourpose database object.

=head1 VERSION

0.1.4

=head1 DESCRIPTION

This class can be used as a base class for objects who
holds all their information in a database. The class
provides the base methods to add/delete/update/select the
object to/from a database. 

RoPkg::DBObject inherits RoPkg::Object .

=head1 SYNOPSIS

 package RoPkg::Person;

 use strict;
 use warnings;

 use RoPkg::DBObject;
 use RoPkg::Exceptions;
 
 use vars qw($VERSION @ISA);

 @ISA=qw(RoPkg::DBObject);

 my $methods = {
   id => '-',
   Name => '-',
   Addr => '-',
 };

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

   $opt{methods} = $methods;
   $self = $class->SUPER::new(%opt);

   return $self;
 }

 sub AddToDB {
   my ($self) = @_;

   OutsideClass->throw('Called from outside class')
     if ( !$self or ref($self) ne $CLASS);

   return $self->SQL_Insert();
 }

 1;

 tester.pl

 use warnings;
 use strict;

 use RoPkg::Person;
 use RoPkg::DB;

 sub main {
   my ($p, $db);
   
   $db = new RoPkg::DB();
   $db->add('dsn...', 'user', 'pass', 'dbc');
   $p = new RoPkg::Person(dbo => $db, dbo_method => 'db_dbc');

   $p->id(1);
   $p->Name('John Doe');
   $p->Addr('home');
   $p->AddToDB();
 }

 main();

=head1 SUBROUTINES/METHODS

=head2 new($hashref)

Constructor of the class. At this moment new() accepts 3 parameters:

=over 3

=item *) dbo

=item *) dbo_method

=item *) quote_char

=back

B<dbo> and B<dbo_method> B<must> be given to the constructor.
B<quote_char> is optional. I<dbo> is the database object (a 
instance of RoPkg::DB)and I<dbo_method> dbo_method is the 
name of the method used to have access to the database handle.
B<quote_char> is the char used internally by DBI to quote
the table names, field names and so on. Default, the quote_char
is empty (no quotation). If you are using PostgreSQL and
you have upcase chars in table and fields names use
quote_char => q{"} .

Exceptions:

RoPkg::DBObject uses the exceptions provided by RoPkg::Exceptions.
new() throws the following exceptions:

=over 2

=item *) Param::Mising

=item *) Param::Wrong

=back

Param::Missing is raised when I<dbo> or I<dbo_method> parameters
have not been specified in the parameters list.

Param::Wrong is raised when I<dbo> or I<dbo_method> parameters
are not defined (or empty).

=head2 dbo($dbo)

get/set method. If $dbo is present (and defined), the internal
$dbo object will be replaced with the new one. If $dbo is not
present, the method acts as a get method, and will return the
database object. The method will raise OutsideClass exception
if is called outside the class instance.

=head2 dbo_method($dbo_method)

get/set method. If $dbo_method is present (and defined), the
internal $dbo_method value will be replaced with the one
specified by $dbo_method parameter. Otherwise, the get
behaviour will be selected, and the method will return
the current value of $dbo_method. The method will raise
OutsideClass exception if is called outside the class
instance.

=head2 dbh()

Returns the DBI object used by this object.

=head1 SQL METHODS

The following methods are responsable for all operations
involving the database. All methods use SQL::Abstract
to generate sql queries to ensure portability of the queries.

The data that will be added/deleted to the database, is taken
from the methods provided by I<$methods> . 

=head2 SQL_Insert()

add the current object to the database. Returns the value
of DBI->execute.

=head2 SQL_Update(@fields)

update the data from database. The fields array hold all the
field names who will uniquely identify the object in the
database (usually the id of the object).

=head2 SQL_Delete(@fields)

update the data from database. The fields array hold all the
field names who will uniquely identify the object in the
database (usually the id of the object).

=head2 SQL_Select(@fields)

searches into the database for the object and initialize
the current object with the values found.  The fields array
hold all the field names who will uniquely identify the 
object in the database (usually the id of the object).
This method is special. It will look only at the first
record who meet the requirements (in sql 'LIMIT 1'). Also,
if no records are found DB::NoResults exception is raised.

=head1 DEPENDENCIES

RoPkg::Object require perl 5.008 or later and the following modules:

=over 3

=item SQL::Abstract

=item RoPkg::Object

=item RoPkg::Exceptions

=back

=head1 PERL CRITIC

The code is perl critic level 2 compliant and almost level 1 compliant

=head1 DIAGNOSTICS

This module comes with his own tests. To run the tests unpack the source,
and use 'make test' command.

=head1 CONFIGURATION AND ENVIRONMENT

This module does not use any configuration files or environment
variables. The dependencies however can use them. Please read
the man page of each dependency to be sure.

=head1 INCOMPATIBILITIES

Do not install this version on the same machine with Simba <= 0.7.1

=head1 BUGS AND LIMITATIONS

None known to the author

=head1 AUTHOR

Subredu Manuel <diablo@iasi.roedu.net>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2005 Subredu Manuel.  All Rights Reserved.
This module is free software; you can redistribute it 
and/or modify it under the same terms as Perl itself.
The LICENSE file contains the full text of the license.

=cut