view release on metacpan or  search on metacpan

lib/Data/ObjectDriver/BaseObject.pm  view on Meta::CPAN

# $Id$

package Data::ObjectDriver::BaseObject;
use strict;
use warnings;

our $HasWeaken;
eval q{ use Scalar::Util qw(weaken) }; ## no critic
$HasWeaken = !$@;

use Carp ();

use Class::Trigger qw( pre_save post_save post_load pre_search
                       pre_insert post_insert pre_update post_update
                       pre_remove post_remove post_inflate );

use Data::ObjectDriver::ResultSet;

## Global Transaction variables
our @WorkingDrivers;
our $TransactionLevel = 0;

sub install_properties {
    my $class = shift;
    my($props) = @_;
    my $columns = delete $props->{columns};
    $props->{columns} = [];
    {
        no strict 'refs'; ## no critic
        *{"${class}::__properties"} = sub { $props };
    }

    foreach my $col (@$columns) {
        $class->install_column($col);
    }
    return $props;
}

sub install_column {
    my($class, $col, $type) = @_;
    my $props = $class->properties;

    push @{ $props->{columns} }, $col;
    $props->{column_names}{$col} = ();
    # predefine getter/setter methods here
    # Skip adding this method if the class overloads it.
    # this lets the SUPER::columnname magic do it's thing
    if (! $class->can($col)) {
        no strict 'refs'; ## no critic
        *{"${class}::$col"} = $class->column_func($col);
    }
    if ($type) {
        $props->{column_defs}{$col} = $type;
    }
}

sub properties {
    my $this = shift;
    my $class = ref($this) || $this;
    $class->__properties;
}

# see docs below

sub has_a {
    my $class = shift;
    my @args = @_;

    # Iterate over each remote object
    foreach my $config (@args) {
        my $parentclass = $config->{class};

        # Parameters
        my $column = $config->{column};
        my $method = $config->{method};
        my $cached = $config->{cached} || 0;
        my $parent_method = $config->{parent_method};

        # column is required
        if (!defined($column)) {
            die "Please specify a valid column for $parentclass"
        }

        # create a method name based on the column
        if (! defined $method) {
            if (!ref($column)) {
                $method = $column;
                $method =~ s/_id$//;
                $method .= "_obj";
            } elsif (ref($column) eq 'ARRAY') {
                foreach my $col (@{$column}) {
                    my $part = $col;
                    $part =~ s/_id$//;
                    $method .= $part . '_';
                }
                $method .= "obj";
            }
        }

        # die if we have clashing methods method
        if (! defined $method || defined(*{"${class}::$method"})) {
            die "Please define a valid method for $class->$column";
        }

        if ($cached) {
            # Store cached item inside this object's namespace
            my $cachekey = "__cache_$method";

            no strict 'refs'; ## no critic
            *{"${class}::$method"} = sub {
                my $obj = shift;

                return $obj->{$cachekey}
                    if defined $obj->{$cachekey};

                my $id = (ref($column) eq 'ARRAY')
                    ? [ map { $obj->{column_values}->{$_} } @{$column}]
                    : $obj->{column_values}->{$column}
                    ;
                ## Hold in a variable here too, so we don't lose it immediately
                ## by having only the weak reference.
                my $ret = $parentclass->lookup($id);
                if ($HasWeaken) {
                    $obj->{$cachekey} = $ret;
                    weaken($obj->{$cachekey});
                }
                return $ret;
            };
        } else {
            if (ref($column)) {
                no strict 'refs'; ## no critic
                *{"${class}::$method"} = sub {
                    my $obj = shift;
                    return $parentclass->lookup([ map{ $obj->{column_values}->{$_} } @{$column}]);
                };
            } else {
                no strict 'refs'; ## no critic
                *{"${class}::$method"} = sub {
                    return $parentclass->lookup(shift()->{column_values}->{$column});
                };
            }
        }

        # now add to the parent
        if (!defined $parent_method) {
            $parent_method = lc($class);
            $parent_method =~ s/^.*:://;

            $parent_method .= '_objs';
        }
        if (ref($column)) {
            no strict 'refs'; ## no critic
            *{"${parentclass}::$parent_method"} = sub {
                my $obj = shift;
                my $terms = shift || {};
                my $args = shift;

                my $primary_key = $obj->primary_key;

                # inject pk search into given terms.
                # composite key, ugh
                foreach my $key (@$column) {
                    $terms->{$key} = shift(@{$primary_key});
                }

                return $class->search($terms, $args);
            };
        } else {
            no strict 'refs'; ## no critic
            *{"${parentclass}::$parent_method"} = sub {
                my $obj = shift;
                my $terms = shift || {};
                my $args = shift;
                # TBD - use primary_key_to_terms
                $terms->{$column} = $obj->primary_key;
                return $class->search($terms, $args);
            };
        };
    } # end of loop over class names
    return;
}

sub driver {
    my $class = shift;
    $class->properties->{driver} ||= $class->properties->{get_driver}->();