use strict;
use 5.006;
=head1 NAME
Mixin::ExtraFields::Hive - infest your objects with hives
=head1 VERSION
version 0.004
$Id: Hive.pm 28691 2007-04-03 00:14:59Z rjbs $
=cut
our $VERSION = '0.004';
=head1 SYNOPSIS
use Mixin::ExtraFields::Hive -hive => {
moniker => 'registry',
driver => 'DBI',
};
=head1 DESCRIPTION
This module provides a Data::Hive to other classes' objects as a mix-in,
powered by Mixin::ExtraFields. It behaves like Mixin::ExtraFields, but
generates a different set of methods. It can use any Mixin::ExtraFields
driver.
=head1 GENERATED METHODS
=head2 hive
The main export of this module is the C<hive> method, generated by importing
the C<-hive> group. The method will be imported under the moniker given to the
C<hive> group. If this all sounds like Greek, you should probably re-read the
L<Mixin::ExtraFields> documentation. As a simple example, however, the code in
the L</Synopsis>, above, would generate a C<registry> method instead of a
C<hive> method.
This method will return a L<Data::Hive> object for extra fields for the object
on which it's called. At present, the Data::Hive object is recreated for each
call to the C<hive> method. In the future, it will be possible to cache these
on the object or in some other manner.
=head2 other methods
At present, two support methods are installed by this mixin. These methods may
go away in the future, when a more purpose-built subclass of Data::Hive::Store
is used.
These methods are:
_mutate_hive - acts as a combined get/set extra accessor
_exists_hive - acts as the standard exists_extra method
_empty_hive - deletes all hive data
_delete_hive - deletes a single hive entry
=cut
use Data::Hive 1.001;
# I wish this was easier. -- rjbs, 2006-12-09
use Sub::Exporter -setup => {
groups => [ hive => \'gen_fields_group', ],
};
sub default_moniker { 'hive' }
sub methods { qw(hive mutate exists empty delete) }
sub _build_mutate_method {
my ($self, $arg) = @_;
my $id_method = $arg->{id_method};
my $driver = $arg->{driver};
my $driver_set = $self->driver_method_name('set');
my $driver_get = $self->driver_method_name('get');
return sub {
my $self = shift;
my $name = shift;
my $id = $self->$$id_method;
if (@_) {
my $value = shift @_;
$$driver->$driver_set($self, $id, $name, $value);
} else {
$$driver->$driver_get($self, $id, $name);
}
};
}
sub _build_hive_method {
my ($self, $arg) = @_;
my $id_method = $arg->{id_method};
my $moniker = ${ $arg->{moniker} };
my %store_args = (
method => $self->method_name('mutate', $moniker),
);
for my $which (qw(exists delete)) {
my $method_name = $self->method_name($which, $moniker);
$store_args{ $which } = sub { $_[0]->param_store->$method_name($_[1]) };
}
sub {
my ($self) = @_;
my $id = $self->$$id_method;
# We should really get around to caching these in some awesome way.
# -- rjbs, 2006-12-09
Data::Hive->NEW({
store_class => 'Param',
store_args => [ $self, \%store_args ],
});
}
}
sub build_method {
my ($self, $method, $arg) = @_;
return $self->_build_mutate_method($arg) if $method eq 'mutate';
return $self->_build_hive_method($arg) if $method eq 'hive';
$method = 'delete_all' if $method eq 'empty';
$self->SUPER::build_method($method, $arg);
}
sub driver_method_name {
my ($self, $method) = @_;
$self->SUPER::method_name($method, 'extra');
}
sub method_name {
my ($self, $method, $moniker) = @_;
return $moniker if $method eq 'hive';
return "_$method\_$moniker";
}
=head1 AUTHOR
This code was written by Ricardo SIGNES. His work in 2006 was sponsored by
Listbox.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2006, Ricardo SIGNES. This code is free software, and is
available under the same terms as perl itself.
=head1 TODO
=over
=item * provide a customizable means to cache created Data::Hive objects
=back
=cut
1;