view release on metacpan or  search on metacpan

lib/DBICx/Modeler.pm  view on Meta::CPAN

    $search->search( { ... } ) # Refine the search ...
    my @cds = $search->slice( 0, 9 ) # Get the first 10     
                                     # Each is of type My::Model::Cd

=head1 DESCRIPTION

DBICx::Modeler is tool for making a thin, Moose-based model layer over a DBIx::Class schema

=head1 CAVEAT EMPTOR

=head2 Many-to-many is not handled

Many-to-many relationships are ignored, for now. You'll have to access C<_model__storage> (which is the DBIx::Class::Row) if you want
to play with them

=head2 The same storage object can be present in different model objects

    # With the following example:
    $artist->cds( ... )->slice( 0 )->artist # $artist and ->artist are different objects

This shouldn't be too difficult to fix.

=head2 The modeler will probably barf when trying to modify  immutable Model:: classes

This shouldn't be too difficult to fix, either.

=head2 Use C<DBIC_MODELER> to trace modeler setup

Set C<DBIC_MODELER> to 1 if you want to trace what is going on in the modeler internally

    $ENV{DBIC_MODELER} = 1

=head1 METHODS

DBICx::Modeler->new( ... )

    schema          The connected DBIx::Class schema to use/inspect

    namespace       The package containing the Moose classes that will mimic the class structure of <schema>

$modeler->model( <moniker> )

    Return the model source for <moniker>

$modeler->create( <moniker> => ... )

    Create a new row for <moniker> and return the modeled object

$modeler->search( <moniker> => ... )

    Make a search of <moniker> that will inflate into modeled objects

=cut

use Moose;

use DBICx::Modeler::Carp;
use constant TRACE => DBICx::Modeler::Carp::TRACE;

use Class::Inspector();
use Scalar::Util qw/weaken/;

use DBICx::Modeler::Model::Source;

#########
# Class #
#########

sub ensure_class_loaded {
    shift;
    my $class = shift;
    return $class if Class::Inspector->loaded( $class );
    eval "require $class;";
    die "Couldn't load class $class: $@" if $@;
    return $class;
}

sub _expand_relative_name {
    my ($self, $name) = @_;
    my $class = ref $self || $self;

    return unless $name;

    my $parent_class = $class;

    if ($name =~ s/^\+//) {
        # Hammatime: Don't touch this!
    }
    else {
        if ($name =~ s/^\-//) {
            # User wants the parent (wants to be a sibling)
            my @class = split m/::/, $parent_class;
            pop @class;
            $parent_class = join '::', @class;
        }
        $name = $parent_class . '::' . $name;
    }
    return $name;
}

###########
# Object ##
###########

has schema => qw/is ro required 1/;
has schema_class => qw/is ro lazy_build 1/;

has [qw/
    namespace
    skip_moniker
/] => qw/is rw/;

has [qw/
    create_refresh
    sibling_namespace
/] => qw/is rw default 1/;

has skip_schema_modeler_accessor => qw/is rw default 0/;
has [qw/ _model_source_list /] => qw/is ro required 1 lazy 1 isa ArrayRef/, default => sub { [] };
has [qw/ _namespace_list /] => qw/is ro lazy_build 1 isa ArrayRef/;
sub _build__namespace_list {
    my $self = shift;
    my $class = ref $self || $self;

    my $default_namespace = do {
        my @default = split m/::/, $class;
        if ( my $name = $self->sibling_namespace ) {
            $name = "Model" if $name eq 1;
            pop @default; # Use Example::${name} instead of Example::Modeler::${name} (e.g. Example::Model)
            push @default, $name;
        }
        "+" . join "::", @default;
    };

    my $namespace = $self->namespace;
    $namespace = [] unless defined $namespace;
    $namespace = [ $namespace ] unless ref $namespace eq "ARRAY";
    unless (@$namespace) {
        croak "You didn't specify a namespace" if $class eq __PACKAGE__;
        @$namespace = ("?"); # Use the default namespace if none specified
    }
    @$namespace = map { $_ eq "?" ? $default_namespace : $_ } @$namespace;

    $_ = $self->_expand_relative_name( $_ ) for @$namespace;

    return [ @$namespace ];
}
has [qw/
    _model_source_lookup_map
    _model_class_by_moniker_map
    _moniker_by_model_class_map
/] => qw/is ro required 1 lazy 1 isa HashRef/, default => sub { {} };

sub _build_schema_class {
    my $self = shift;
    return ref $self->schema;
}

sub BUILD {
    my $self = shift;
    my $given = shift;

    $self->skip_moniker( $given->{skip} ) if ! exists $given->{skip_moniker} && $given->{skip};

    my $schema = $self->schema;
    my $schema_class = $self->schema_class;

    $self->_setup_schema_modeler_accessor unless $self->skip_schema_modeler_accessor;
    $self->_setup_base_model_sources;
    {
        $self->schema->modeler( $self );
        weaken $self->schema->{modeler};
    }

    return 1;
}

sub _setup_schema_modeler_accessor {
    my $self = shift;
    return if $self->schema_class->can( qw/modeler/ );
    $self->schema_class->mk_group_accessors( simple => qw/modeler/ );
}

sub _setup_base_model_sources {
    my $self = shift;
    my %option = @_;

    for my $moniker ($self->schema->sources) {
        my $model_class = $self->model_class_by_moniker( $moniker ); # Initialize base model classes & moniker_by_model_class/model_class_by_moniker
        my $model_source = DBICx::Modeler::Model::Source->new(
            moniker => $moniker,
            modeler => $self,
            schema => $self->schema,
            model_class => $model_class,
        );
        $model_class->_model__meta->initialize_base_model_class( $model_source );
        $self->_register_model_source( $model_source );
    }
}

sub namespaces {
    my $self = shift;
    return @{ $self->_namespace_list }
}

sub moniker_by_model_class {
    my $self = shift;
    my $model_class = shift;

    return $self->model_source_by_model_class( $model_class )->moniker;
#    croak "Couldn't find moniker for (model class) $model_class" unless $moniker;
}

sub find_model_class {
    my $self = shift;
    my $query = shift;

    if ($query =~ s/^\+//) {
        return $self->ensure_class_loaded( $query );
    }

    # A relative class... 'moniker'
    return $self->model_class_by_moniker( $query );
}

sub model_class_by_moniker {
    my $self = shift;
    my $moniker = shift;

    # Has to be done this way, because the model source might not be loaded yet

    my $model_class = $self->_model_class_by_moniker_map->{$moniker};