—
—
—

              
package DBICx::Modeler;
use warnings;
use strict;
HideShow 10 lines of Pod
=head1 NAME
DBICx::Modeler - A Moose-based model layer over DBIx::Class
=head1 VERSION
Version 0.005
=cut
our $VERSION = '0.005';
HideShow 82 lines of Pod
=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( @_ );
}
HideShow 56 lines of Pod
=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