File Coverage

blib/lib/DBICx/Modeler.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package DBICx::Modeler;

use warnings;
use strict;

=head1 NAME

DBICx::Modeler - A Moose-based model layer over DBIx::Class

=head1 VERSION

Version 0.005

=cut

our $VERSION = '0.005';

=head1 SYNOPSIS

    # Given the following schema:

    My::Schema::Artist
    My::Schema::Cd
    My::Schema::Track

    # ... and the following model:

    My::Model::Artist

    use DBICx::Modeler::Model

    My::Model::Cd ...
    My::Model::Track ...

    ...

    my $modeler = DBICx::Modeler->new( schema => ..., namespace => My::Model );

    my $artist = $modeler->create( Artist => { ... } ) # $artist is My::Model::Artist

    my $cd = $artist->create_related( cds => { ... } ) # $cd is My::Model::Cd

    ...

    my $search = $artist->cds( { title => ... } ) # Start a search ...
    $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};
    return $model_class if $model_class;

    for my $namespace ( $self->namespaces ) {
        my $potential_model_class = "${namespace}::${moniker}";

        if (Class::Inspector->loaded( $potential_model_class )) {
        }
        else {
            eval "require $potential_model_class;";
            if ($@) {
                my $file = join '/', split '::', $potential_model_class;
                if ($@ =~ m/^Can't locate $file/) {
                    TRACE->( "[$self] Unable to load file ($file) for $potential_model_class" );
                    next;
                }
                else {
                    die "Couldn't load class $potential_model_class for $moniker: $@" if $@;
                }
            }
        }
        $model_class = $potential_model_class;
        last; # We found something!
    }

    croak "Couldn't find model class for (moniker) $moniker" unless $model_class;

    $self->_moniker_by_model_class_map->{$model_class} = $moniker;
    return $self->_model_class_by_moniker_map->{$moniker} = $model_class;
}

sub model_class_by_result_class {
    my $self = shift;
    my $result_class = shift;
    my $moniker = $self->schema_class->source( $result_class )->source_name;
    return $self->model_class_by_moniker( $moniker );
}

sub model_sources {
    my $self = shift;
    return @{ $self->_model_source_list };
}

sub _model_source {
    my $self = shift;
    my $model_source = shift;

    $model_source = $self->_model_source_lookup_map->{$model_source} while defined $model_source && ! ref $model_source;

    return $model_source;
}

sub model_source {
    my $self = shift;
    my $model_source = shift;
    return $self->_model_source( $model_source ) or croak "Couldn't find model source with key $model_source";
}

sub model {
    my $self = shift;
    return $self->model_source( @_ );
}

sub model_source_by_moniker {
    my $self = shift;
    my $moniker = shift;
    my $model_source = $self->_model_source( "::${moniker}" ) or
        croak "Couldn't find model source for (moniker) $moniker";
    return $model_source;
}

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

    my $model_source = $self->_model_source( "+${model_class}" );

    return $model_source if $model_source;

    TRACE->( "[$self] Building model source for $model_class" );
    # The model class might not have been loaded yet
    $self->ensure_class_loaded( $model_class );

    die "Can't get model source for $model_class since it doesn't have a model meta" unless $model_class->can( '_model__meta' );

    my $parent_model_meta = $model_class->_model__meta->parent;

    die "Strange, model source for $model_class doesn't exist, but it doesn't have a parent" unless $parent_model_meta;

    my $parent_model_class = $parent_model_meta->model_class;
    my $parent_model_source = $self->model_source_by_model_class( $parent_model_class );

    $model_source = $parent_model_source->clone( model_class => $model_class );

    $self->_register_model_source( $model_source );

    return $model_source;
}

sub _register_model_source {
    my $self = shift;
    my $model_source = shift;
    push @{ $self->_model_source_list }, $model_source;

    my $moniker = $model_source->moniker;
    my $moniker_key = "::${moniker}";
    my $model_class = $model_source->model_class;
    my $model_class_key = "+${model_class}";

    $self->_model_source_lookup_map->{$model_class_key} = $model_source;

    $self->_model_source_lookup_map->{$model_class} = $model_class_key;
    $self->_model_source_lookup_map->{$moniker} = $model_class_key;
    $self->_model_source_lookup_map->{$moniker_key} = $model_class_key;
    # TODO Add more aliasing
}

sub create {
    my $self = shift;
    my $key = shift;
    return $self->model_source( $key )->create( @_ );
}

sub inflate {
    my $self = shift;
    my $key = shift;
    return $self->model_source( $key )->inflate( @_ );
}

sub search {
    my $self = shift;
    my $key = shift;
    return $self->model_source( $key )->search( @_ );
}

=head1 AUTHOR

Robert Krimen, C<< <rkrimen at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-dbicx-modeler at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DBICx-Modeler>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc DBICx::Modeler


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBICx-Modeler>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/DBICx-Modeler>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/DBICx-Modeler>

=item * Search CPAN

L<http://search.cpan.org/dist/DBICx-Modeler/>

=back


=head1 ACKNOWLEDGEMENTS


=head1 COPYRIGHT & LICENSE

Copyright 2009 Robert Krimen, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut

1; # End of DBICx::Modeler