File Coverage

blib/lib/Pinwheel/Model/Base.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Pinwheel::Model::Base;

=head1 NAME

Pinwheel::Model::Base - Base class for PinWheel models

=head1 SYNOPSIS

  # Given $obj which is some PinWheel model...

  $obj->has_key($column_name);
  $column_names = $obj->keys; # unordered array ref
  $value = $obj->get($key);

  $sql_param = $obj->sql_param;
  @route_params = $obj->route_param;

=head1 DESCRIPTION

=over 4

=cut

use Carp qw(confess);
use Class::ISA;

use Pinwheel::Database qw(prepare);


sub new
{
    my ($class, $model, $data) = @_;
    my ($ctx, $key, $obj);

    $ctx = Pinwheel::Context::get('Model--' . $model->{table});
    $obj = $ctx->{$key} if ($key = $data->{id});

    if ($obj) {
        $obj->{data} = {%{$obj->{data}}, %$data};
    } else {
        $obj = bless {model => $model, data => $data}, $class;
        $ctx->{$key} = $obj if ($key);
    }
    return $obj;
}

sub STORABLE_freeze
{
    my ($obj, $cloning) = @_;
    return Storable::freeze($obj->{data});
}

sub STORABLE_attach
{
    my ($class, $cloning, $data) = @_;
    return new($class, \%{"$class\::model"}, Storable::thaw($data));
}

=item $bool = $obj-Ehas_key($key)

Returns true iff C<$obj> has a key named C<$key>.  If the column hasn't been
fetched yet, C returns false.

=cut

sub has_key { exists($_[0]->{data}{$_[1]}) }

=item $keys = $obj-Ekeys

Return an (unordered) list of the current data keys in the model object.  This
only includes the columns where data has been fetched.

=cut

sub keys { return [ keys(%{$_[0]->{data}}) ] }

=item $value = $obj-Eget($key)

TODO, document me.

=cut

sub get
{
    my ($self, $key) = @_;
    my ($getter);

    $getter = $self->{model}{getters}{$key};
    return $getter ? $self->$getter() : $self->{data}{$key};
}

sub _prefetched_link
{
    my ($self, $key, $data) = @_;
    my ($pkg, $model, $obj);

    $pkg = $self->{model}{associations}{$key};
    $pkg = $self->_inherit_association($key) if !defined($pkg);
    confess "Unknown relation $key" if !defined($pkg);
    $model = $pkg->{model};
    confess "Unable to resolve relation $key" if !defined($model);

    if (defined($data->{id})) {
        $model = Pinwheel::Model::_find_inherited_model($model, $data);
        $obj = Pinwheel::Model::Base::new($model->{model_class}, $model, $data);
    }
    $self->{data}{$key} = $obj;
}

sub _inherit_association
{
    my ($self, $key) = @_;
    my ($classname, $pkg);

    foreach $classname (Class::ISA::super_path(ref($self))) {
        $pkg = \%::;
        $pkg = $pkg->{"$_\::"} foreach split(/::/, $classname);
        if (defined($pkg->{model})) {
            $pkg = $pkg->{model}{associations}{$key};
        } else {
            $pkg = undef;
        }
        last if defined($pkg);
    }
    $self->{model}{associations}{$key} = $pkg;
    return $pkg;
}

sub _fill_out
{
    my $self = shift;
    my ($data, $sth, $row, $key);

    $data = $self->{data};
    $sth = prepare("SELECT * FROM `$self->{model}{table}` WHERE id = ?");
    $sth->execute($data->{id});
    $row = $sth->fetchrow_hashref();
    foreach $key (CORE::keys %{$self->{model}{fields}}) {
        $data->{$key} = $row->{$key} unless exists($data->{$key});
    }
}

=item $sql_param = $obj-Esql_param

Turns C<$obj> into a SQL query parameter; see L.

Default: C<$obj-Eid>.

=cut

sub sql_param { $_[0]->id }

=item @route_params = $obj-Eroute_param

Turns C<$obj> into route parameter(s); see L.

Default: C<$obj-Eid>.

=cut

sub route_param { $_[0]->id }

sub DESTROY { }

=back

=head1 AUTHOR

A&M Network Publishing

=cut

1;