File Coverage

blib/lib/DBIx/Class/DynamicSubclass.pm

Criterion	Covered	Total	%
statement	42	46	91.3
branch	11	18	61.1
condition	4	12	33.3
subroutine	8	8	100.0
pod	2	5	40.0
total	67	89	75.2

package DBIx::Class::DynamicSubclass;
use base qw/DBIx::Class/;
use strict;
use warnings;

our $VERSION = 0.04;

__PACKAGE__->mk_group_accessors(inherited => qw/_typecast_map typecast_column/);

=head1 NAME

DBIx::Class::DynamicSubclass - Convenient way to use dynamic subclassing.

=head1 SYNOPSIS

    package My::Schema::Game;

    __PACKAGE__->load_components(qw/DynamicSubclass Core/);
    __PACKAGE__->add_column(qw/id name data type/);

    __PACKAGE__->typecast_map(type => {
        1 => 'My::Schema::Game::Online',
        2 => 'My::Schema::Game::Shareware',
        3 => 'My::Schema::Game::PDA',
    });

    $game = $schema->resultset('Game')->new({..., type => 1});
    #  ref $game = 'My::Schema::Game::Online'

    @games = $game->search({type => 2});
    # @games are all of class My::Schema::Game::Shareware

    $game->type(3); # game is now of class My::Schema::Game::PDA

    $game =  $schema->resultset('Game')->new({});
    # or
    $game->type(undef);
    # game is now of type My::Schema::Game


    #Dynamic properties with DBIx::Class::FrozenColumns
    package My::Schema::Game;
    __PACKAGE__->load_components(qw/... FrozenColumns .../);

    package My::Schema::Game::Online;
    use base 'My::Schema::Game';
    __PACKAGE__->add_frozen_columns(data => qw/flash server_host server_port/);

    package My::Schema::Game::Shareware;
    use base 'My::Schema::Game';
    __PACKAGE__->add_frozen_columns(data => qw/price download_url/);

    ...

    $game->type(1); #game would have now additional columns 'flash', 'server_host', etc.
    $game->server_host('...'); #(stored in 'data')

    $game->type(2);
    $game->server_host; #error
    $game->price('$3.00'); #ok

    $game = $rs->new({
        type  => 1,
        flash => 'game.swf',
    }); #ok

    #More flexible way

    package My::Schema::Game;
    __PACKAGE__->typecast_column('type');

    sub classify { #called each time the object gets or losses its 'type'
        my $self = shift;
        #decide which class do you want
        bless $self, $class;
    }

=head1 DESCRIPTION

This plugin implements methodics described here
L.

DynamicSubclass has 2 ways to work: static defining and dynamic defining.

Static defining is used in most cases. This is when you define

    __PACKAGE__->typecast_map(defining_column => {column_value => 'subclass', ...});

The plugin preloads all of the subclasses and changes the class of the row object
when you are creating new object or fetching it from a database or changing
'defining_column' value.
If the value is not exists in the 'typecast_map' then object is blessed into
the base class and losses all of its additional methods/columns/etc.

Dynamic defining is when you only say

    __PACKAGE__->typecast_column('defining_column');

and define a method 'classify' that would bless a row object into proper class.
This method is called when object is created, fetched or have its
'defining_column' value changed.

=head1 METHODS

=head2 typecast_map

Arguments: $column, %typecast_hash

%typecast_hash is a hash with keys equal to possible $column values and with
subclasses as values.

=head2 classify

A standart method for static subclassing. You should redefine this method in your
result source in order to use dynamic subclassing (second way).

=head1 OVERLOADED METHODS

new, inflate_result, store_column

=head1 SEE ALSO

L, L.

=head1 AUTHOR

Pronin Oleg

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut

sub typecast_map {
    my ($this, $column, $map) = @_;
    $this->throw_exception("cannot find column '$column'")
        unless $this->has_column($column);
    $this->throw_exception("typecast map must be a hash reference")
        unless $map && ref $map && ref $map eq 'HASH';
    $this->ensure_class_loaded($_) for values %$map;
    $this->_typecast_map($map);
    $this->typecast_column($column);
}

sub inflate_result {
    my $self = shift;
    my $ret = $self->next::method(@_);
    $ret->classify;
    return $ret;
}

sub new {
    my $this = shift;
    my $data = shift;

    my $deferred;
    if ($this->can('add_frozen_columns')) {
        my $real_columns = $this->result_source_instance->_columns;
        map {
            $deferred->{$_} = delete $data->{$_}
                unless index($_, '-') == 0 or exists $real_columns->{$_};
        } keys %$data;
    }

    my $ret = $this->next::method($data, @_);
    $ret->classify;

    if ($deferred) {
        $ret->set_columns($deferred);
    }

    return $ret;
}

sub classify {
    my $self = shift;
    my $col = $self->typecast_column or $self->throw_exception(
        'Neither typecast_map defined nor "classify" method redefined in your result source'
    );

    my $val = $self->get_column($col);
    $val = '' unless defined $val;
    if (my $target_class = $self->_typecast_map->{$val}) {
        bless $self, $target_class;
    }
    else {
        bless $self, $self->result_source->result_class;
    }

    return $self;
}

sub store_column {
    my ($self, $column, $value) = @_;
    my $tc_col;
    if ($tc_col = $self->typecast_column and $tc_col eq $column) {
        my $ret = $self->next::method($column, $value);
        $self->classify;
        return $ret;
    }

    $self->next::method($column, $value);
}

1;