view release on metacpan or  search on metacpan

lib/HTML/Tested/ClassDBI.pm  view on Meta::CPAN

=head1 NAME

HTML::Tested::ClassDBI - Enhances HTML::Tested to work with Class::DBI

=head1 SYNOPSIS

  package MyClass;
  use base 'HTML::Tested::ClassDBI';
  
  __PACKAGE__->ht_add_widget('HTML::Tested::Value'
		  , id => cdbi_bind => "Primary");
  __PACKAGE__->ht_add_widget('HTML::Tested::Value'
		  , x => cdbi_bind => "");
  __PACKAGE__->ht_add_widget('HTML::Tested::Value::Upload'
  	, x => cdbi_upload => "largeobjectoid");
  __PACKAGE__->bind_to_class_dbi('MyClassDBI');

  # And later somewhere ...
  # Query and load underlying Class::DBI:
  my $list = MyClass->query_class_dbi(search => x => 15);

  # or sync it to the database:
  $obj->cdbi_create_or_update;
	
=head1 DESCRIPTION

This class provides mapping between Class::DBI and HTML::Tested objects.

It inherits from HTML::Tested. Widgets created with C<ht_add_widget> can have
additional C<cdbi_bind> property.

After calling C<bind_to_class_dbi> you would be able to automatically
synchronize between HTML::Tested::ClassDBI instance and underlying Class::DBI.

=cut

use strict;
use warnings FATAL => 'all';

package HTML::Tested::ClassDBI;
use base 'HTML::Tested';
use Carp;
use HTML::Tested::ClassDBI::Field;
use Data::Dumper;

my @_cdata = qw(_CDBI_Class _PrimaryFields _Field_Handlers _PrimaryKey);
__PACKAGE__->mk_classdata($_) for @_cdata;

our $VERSION = '0.23';

sub class_dbi_object { shift()->class_dbi_object_gr('_CDBIM_', @_); }

sub class_dbi_object_gr {
	my ($self, $gr, $val) = @_;
	return $self->{_class_dbi_objects}->{$gr} if @_ == 2;
	$self->{_class_dbi_objects}->{$gr} = $val;
}

sub cdbi_bind_from_fields {
	my ($class, $gr) = @_;
	for my $v (@{ $class->Widgets_List }) {
		my $wgr = $v->options->{cdbi_group} || '_CDBIM_';
		$v->options->{cdbi_group} = $wgr;
		next unless $wgr eq $gr;
		my $f = HTML::Tested::ClassDBI::Field->new($class, $v, $gr)
				or next;
		$class->_Field_Handlers->{ $v->options->{cdbi_group} }
			->{$v->name} = $f;
	}
}

sub CDBI_Class { return shift()->_CDBI_Class->{_CDBIM_} }
sub PrimaryFields { return shift()->_PrimaryFields->{_CDBIM_} }
sub Field_Handlers { return shift()->_Field_Handlers->{_CDBIM_} }
sub PrimaryKey { return shift()->_PrimaryKey->{_CDBIM_} }

=head1 METHODS

=head2 $class->bind_to_class_dbi($cdbi_class)

Binds $class to $cdbi_class, by going over all fields declared with C<cdbi_bind>
or C<cdbi_upload> option.

C<cdbi_bind> option value could be one of the following:
name of the column, empty string for the column named the same as field or for
array of columns.

C<cdbi_upload> can be used to upload file into the database. Uploaded file is
stored as PostgreSQL's large object. Its OID is assigned to the bound column.

C<cdbi_upload_with_mime> uploads the file and prepends its mime type as a
header. Use HTML::Tested::ClassDBI::Upload->strip_mime_header to pull it from
the data.

C<cdbi_readonly> boolean option can be used to make its widget readonly thus
skipping its value during update. Read only widgets will not be validated.

C<cdbi_primary> boolean option is used to make an unique column behave as
primary key. C<cdbi_load> will use this field while retrieving the object from
the database.

=cut
sub bind_to_class_dbi { shift()->bind_to_class_dbi_gr('_CDBIM_', @_); }

=head2 $class->bind_to_class_dbi_gr($group, $cdbi_class)

Binds $class to $cdbi class in group $group. Special group _CDBIM_ is used
as the default group.

=cut
sub bind_to_class_dbi_gr {
	my ($class, $gr, $dbi_class, $opts) = @_;
	$class->$_({}) for grep { !$class->$_ } @_cdata;
	$class->_CDBI_Class->{$gr} = $dbi_class;
	$class->_Field_Handlers->{$gr} = {};
	$class->_PrimaryFields->{$gr} = {};
	$class->cdbi_bind_from_fields($gr);
	$class->_load_db_info($gr);

	my $pk = $opts ? $opts->{PrimaryKey} : undef;
	$class->_PrimaryKey->{$gr} = $pk if $pk;
	confess "# No Primary fields given\n"
		unless ($pk || %{ $class->_PrimaryFields->{$gr} });
}

sub _get_cdbi_pk_for_retrieve {
	my ($self, $gr) = @_;
	my $pk = $self->_PrimaryKey->{$gr} or goto PFIELDS;

	my %pkh;
	for my $f (@$pk) {
		my $v = $self->$f;
		goto PFIELDS unless defined($v);

		my $h = $self->_Field_Handlers->{$gr}->{$f};
		$pkh{ $h ? $h->column_name : $f } = $v;
	}
	return \%pkh if %pkh;

PFIELDS:
	my $res = {};
	my %pf = %{ $self->_PrimaryFields->{$gr} };
	my ($pv, $pc);
	while (my ($k, $v) = each %pf) {
		$pv = $self->$k;
		next unless defined $pv;
		$pc = $v;
		last;
	}
	return undef unless defined($pv);
	my @vals = split('_', $pv);
	for (my $i = 0; $i < @$pc; $i++) {
		$res->{ $pc->[$i] } = $vals[$i];
	}
	return $res;
}

sub _fill_in_from_class_dbi {
	my ($self, $gr, $is_update) = @_;
	my $fhs = $self->_Field_Handlers->{$gr};
	my $cdbi = $self->class_dbi_object_gr($gr);
	while (my ($f, $h) = each %$fhs) {
		next if ($is_update && defined $self->{$f});
		$self->$f($h->get_column_value($cdbi));
	}
}

sub cdbi_retrieve { shift()->_call_for_all('cdbi_retrieve_gr', @_); }

sub cdbi_retrieve_gr {
	my ($self, $gr) = @_;
	my $pk = $self->_get_cdbi_pk_for_retrieve($gr);
	return unless defined($pk);