HTML::Tested::ClassDBI - Enhances HTML::Tested to work with Class::DBI
Index
Code Index:
NAME
HTML::Tested::ClassDBI - Enhances HTML::Tested to work with Class::DBI
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;
DESCRIPTION
This class provides mapping between Class::DBI and HTML::Tested objects.
It inherits from HTML::Tested. Widgets created with ht_add_widget can have
additional cdbi_bind property.
After calling bind_to_class_dbi you would be able to automatically
synchronize between HTML::Tested::ClassDBI instance and underlying Class::DBI.
METHODS
$class->bind_to_class_dbi($cdbi_class)
Binds $class to $cdbi_class, by going over all fields declared with cdbi_bind
or cdbi_upload option.
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.
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.
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.
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.
cdbi_primary boolean option is used to make an unique column behave as
primary key. cdbi_load will use this field while retrieving the object from
the database.
$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.
$obj->cdbi_load
Loads Class::DBI object using primary key field - the widget with special
cdbi_bind => 'Primary'.
This method populates the rest of the bound fields with values of the loaded
Class::DBI object.
Returns retrieved Class::DBI object or undef.
$class->query_class_dbi($func, @params)
This function loads underlying Class::DBI objects using query function $func
(e.g search) with parameters contained in @params.
For each of those objects new HTML::Tested::ClassDBI instance is created.
$obj->cdbi_create($args)
Creates new database record using $obj fields.
Additional (optional) arguments are given by $args hash refernce.
$class->cdbi_create_gr($group, $args)
Creates new database record using $obj fields in group $group.
$obj->cdbi_update($args)
Updates database records using $obj fields.
Additional (optional) arguments are given by $args hash refernce.
$obj->cdbi_create_or_update($args)
Calls cdbi_create or cdbi_update based on whether the database record
exists already.
Additional (optional) arguments are given by $args hash refernce.
$obj->cdbi_construct
Constructs underlying Class::DBI object using $obj fields.
$obj->cdbi_delete
Deletes database record using $obj fields.
$class->cdbi_set_many($class_objs, $cdbi_objs)
Initializes class_dbi_object field of $class_objs arrayref from the
Class::DBI objects given in $cdbi_objs.
Useful to avoid overhead of retrieving Class::DBI objects one by one.
AUTHOR
Boris Sukholitko
CPAN ID: BOSU
boriss@gmail.com
COPYRIGHT
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
SEE ALSO
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_} }
sub bind_to_class_dbi { shift()->bind_to_class_dbi_gr('_CDBIM_', @_); }
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);
my $cdbi = $self->_CDBI_Class->{$gr}->retrieve(ref($pk) ? %$pk : $pk);
$self->class_dbi_object_gr($gr, $cdbi);
return $cdbi;
}
sub cdbi_load { return shift()->_call_for_all('cdbi_load_gr', @_); }
sub _get_cdbi_object {
my ($self, $gr) = @_;
return $self->class_dbi_object_gr($gr) || $self->cdbi_retrieve_gr($gr);
}
sub cdbi_load_gr {
my ($self, $gr) = @_;
my $cdbi = $self->_get_cdbi_object($gr) or return;
$self->_fill_in_from_class_dbi($gr);
return $cdbi;
}
sub query_class_dbi {
my ($class, $func, @params) = @_;
my @cdbis = $class->CDBI_Class->$func(@params);
return [ map {
my $c = $class->new;
$c->class_dbi_object($_);
$c->_fill_in_from_class_dbi('_CDBIM_');
$c;
} @cdbis ];
}
sub _call_for_all {
my ($self, $func, @args) = @_;
$self->$func($_, @args) for keys %{ $self->_CDBI_Class };
return $self->class_dbi_object;
}
sub cdbi_create { return shift()->_call_for_all('cdbi_create_gr', @_); }
sub cdbi_create_gr {
my ($self, $gr, $args) = @_;
my $cargs = $self->_get_cdbi_pk_for_retrieve($gr) || {};
$self->_update_fields($gr, sub { $cargs->{ $_[0] } = $_[1]; }, $args);
my $res;
eval { $res = $self->_CDBI_Class->{$gr}->create($cargs); };
confess "SQL error: $@\n" . Dumper($self) if $@;
$self->class_dbi_object_gr($gr, $res);
$self->_fill_in_from_class_dbi($gr, 1);
return $res;
}
sub _update_fields {
my ($self, $gr, $setter, $args) = @_;
while (my ($field, $h) = each %{ $self->_Field_Handlers->{$gr} }) {
$h->update_column($setter, $self, $field)
if exists $self->{$field};
}
my $cdbi = $self->_CDBI_Class->{$gr};
while (my ($n, $v) = each %{ $args || {} }) {
$setter->($n, $v) if $cdbi->can($n);
}
}
sub cdbi_update { return shift()->_call_for_all('cdbi_update_gr', @_); }
sub cdbi_update_gr {
my ($self, $gr, $args) = @_;
my $cdbi = $self->_get_cdbi_object($gr)
or confess("# Nothing found to update");
$self->_update_fields($gr, sub {
my ($c, $val) = @_;
no warnings 'uninitialized';
$cdbi->$c($val) if $cdbi->$c ne $val;
}, $args);
eval { $cdbi->update; };
confess "SQL error: $@\n" . Dumper($self) if $@;
$self->_fill_in_from_class_dbi($gr, 1);
return $cdbi;
}
sub cdbi_create_or_update {
return shift()->_call_for_all('cdbi_create_or_update_gr', @_);
}
sub cdbi_create_or_update_gr {
my ($self, $gr, $args) = @_;
return $self->_get_cdbi_object($gr) ? $self->cdbi_update_gr($gr, $args)
: $self->cdbi_create_gr($gr, $args);
}
sub cdbi_construct { return shift()->cdbi_construct_gr('_CDBIM_'); }
sub cdbi_construct_gr {
my ($self, $gr) = @_;
my $pk = $self->_get_cdbi_pk_for_retrieve($gr)
or confess "No primary key for $gr";
return $self->_CDBI_Class->{$gr}->construct($pk);
}
sub cdbi_delete { shift()->cdbi_delete_gr('_CDBIM_', @_); }
sub cdbi_delete_gr {
my $c = shift()->cdbi_construct_gr(shift());
$c->delete;
}
sub _load_db_info {
my ($class, $gr) = @_;
while (my ($n, $h) = each %{ $class->_Field_Handlers->{$gr} }) {
my $w = $class->ht_find_widget($n);
$h->setup_type_info($class->_CDBI_Class->{$gr}, $w);
}
}
sub cdbi_set_many {
my ($class, $h_objs, $c_objs) = @_;
my @pcs = $class->CDBI_Class->primary_columns;
my %c_objs;
for my $co (@$c_objs) {
$c_objs{ join('_', map { $co->$_ } @pcs) } = $co;
}
for my $ho (@$h_objs) {
my $pk = $ho->_get_cdbi_pk_for_retrieve('_CDBIM_');
my $co = $c_objs{ join('_', grep { defined($_) }
map { $pk->{$_} } @pcs) };
$ho->class_dbi_object($co);
}
}
1;