-package Reaction::InterfaceModel::DBIC::ModelBase;
+package Catalyst::Model::Reaction::InterfaceModel::DBIC;
use Reaction::Class;
use Catalyst::Component;
use Class::MOP;
-class ModelBase, is 'Reaction::Object', is 'Catalyst::Component', which {
+#XXX so yeah, thisis kinda hacky. big whop though, i need it.
+#this may just all together go away in the future
- has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1);
+class DBIC, is 'Reaction::Object', is 'Catalyst::Component', which {
+
+ has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1);
implements 'COMPONENT' => as {
my ($class, $app, $args) = @_;
my $model_name = $class;
$model_name =~ s/^[\w:]+::(?:Model|M):://;
- #this could be cut out later for a more elegant method
+ #XXXthis could be cut out later for a more elegant method
my @domain_models = $im_class->domain_models;
confess "Unable to locate domain model in ${im_class}"
if @domain_models < 1;
{
#I should probably MOPize this at some point maybe? nahhhh
+ #XXXMaybe I should just fix CRUDController and eliminate this shit period.
+ #pure bloat and namespace pollution
no strict 'refs';
foreach my $collection ( $im_class->parameter_attributes ){
my $classname = join '::', $class, $collection->name, 'ACCEPT_CONTEXT';
return $ctx->stash->{ref($self)} ||= $self->CONTEXTUAL_CLONE($ctx);
};
- #to do build in support for RestrictByUser natively or by subclass
+ #XXXto do build in support for RestrictByUser natively or by subclass
implements 'CONTEXTUAL_CLONE' => as {
my ($self, $ctx) = @_;
my $schema = $self->_schema->clone;
my $im_class = $self->config->{im_class};
- #this could be cut out later for a more elegant method
+ #XXXthis could be cut out later for a more elegant method
my @domain_models = $im_class->domain_models;
confess "Unable to locate domain model in ${im_class}"
if @domain_models < 1;
=head1 NAME
-Reaction::InterfaceModel::DBIC::ModelBase
+Catalyst::Model::Reaction::InterfaceModel::DBIC
=head1 DESCRIPTION
+++ /dev/null
-package ComponentUI::Controller::Bar;
-
-use strict;
-use warnings;
-use base 'Reaction::UI::CRUDController';
-use Reaction::Class;
-
-__PACKAGE__->config(
- model_base => 'TestDB',
- model_name => 'Bar',
- action => { base => { Chained => '/base', PathPart => 'bar' },
- list => { ViewPort => { layout => 'bar_list' } },
- update => { ViewPort => { layout => 'bar_form' } },
- create => { ViewPort => { layout => 'bar_form' } } },
-);
-
-1;
+++ /dev/null
-package ComponentUI::Controller::Baz;
-
-use strict;
-use warnings;
-use base 'Reaction::UI::CRUDController';
-use Reaction::Class;
-
-__PACKAGE__->config(
- model_base => 'TestDB',
- model_name => 'Baz',
- action => { base => { Chained => '/base', PathPart => 'baz' } },
-);
-
-1;
+++ /dev/null
-package ComponentUI::Controller::Foo;
-
-use strict;
-use warnings;
-use base 'Reaction::UI::CRUDController';
-use Reaction::Class;
-
-__PACKAGE__->config(
- model_base => 'TestDB',
- model_name => 'Foo',
- action => { base => { Chained => '/base', PathPart => 'foo' } },
-);
-
-1;
+++ /dev/null
-package ComponentUI::Model::Action;
-
-use Reaction::Class;
-
-use lib 't/lib';
-use RTest::TestDB;
-
-use aliased 'Reaction::InterfaceModel::Action::DBIC::ActionReflector';
-
-my $r = ActionReflector->new;
-
-$r->reflect_actions_for('RTest::TestDB::Foo' => __PACKAGE__);
-$r->reflect_actions_for('RTest::TestDB::Bar' => __PACKAGE__);
-$r->reflect_actions_for('RTest::TestDB::Baz' => __PACKAGE__);
-
-1;
package ComponentUI::Model::TestModel;
use lib 't/lib';
-use base 'Reaction::InterfaceModel::DBIC::ModelBase';
+use base 'Catalyst::Model::Reaction::InterfaceModel::DBIC';
__PACKAGE__->config
(
package ComponentUI::TestModel;
use lib 't/lib';
-use Reaction::InterfaceModel::DBIC::SchemaClass;
+use base 'Reaction::InterfaceModel::Object';
+use Reaction::Class;
+use Reaction::InterfaceModel::Reflector::DBIC;
-class TestModel, which {
- domain_model '_testdb_schema' =>
- (
- isa => 'RTest::TestDB',
- reflect => [
- 'Foo',
- ['Bar' => 'ComponentUI::TestModel::Bars'],
- ['Baz' => 'ComponentUI::TestModel::Baz', 'bazes' ],
- ],
- );
-};
+my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
+
+$reflector->reflect_schema
+ (
+ model_class => __PACKAGE__,
+ schema_class => 'RTest::TestDB',
+ sources => [qw/Foo Bar Baz/],
+ );
1;
+++ /dev/null
-package ComponentUI::TestModel::Bars;
-
-use lib 't/lib';
-use Reaction::InterfaceModel::DBIC::ObjectClass;
-
-class Bars, which{
- domain_model '_bars_store' =>
- (isa => 'RTest::TestDB::Bar', inflate_result => 1,
- reflect => [qw(name foo published_at avatar)],
- );
-
- reflect_actions
- (
- Create => { attrs =>[qw(name foo published_at avatar)] },
- Update => { attrs =>[qw(name foo published_at avatar)] },
- Delete => {},
- );
-
-};
-
-1;
+++ /dev/null
-package ComponentUI::TestModel::Baz;
-
-use lib 't/lib';
-use Reaction::InterfaceModel::DBIC::ObjectClass;
-
-class Baz, which{
- domain_model '_baz_store' =>
- (isa => 'RTest::TestDB::Baz', inflate_result => 1,
- handles => ['display_name'],
- reflect => [qw(id name foo_list)],
- );
-
- reflect_actions
- (
- Create => { attrs =>[qw(name)] },
- Update => { attrs =>[qw(name)] },
- Delete => {},
- );
-};
-
-1;
+++ /dev/null
-package ComponentUI::TestModel::Foo;
-
-use lib 't/lib';
-use Reaction::InterfaceModel::DBIC::ObjectClass;
-
-class Foo, which{
- domain_model '_foo_store' =>
- (isa => 'RTest::TestDB::Foo', inflate_result => 1,
- handles => ['display_name'],
- reflect => [qw(id first_name last_name baz_list)],
- );
-
- reflect_actions
- (
- Create => { attrs =>[qw(first_name last_name baz_list)] },
- Update => { attrs =>[qw(first_name last_name baz_list)] },
- Delete => {},
- CustomAction => { attrs =>[qw(last_name baz_list)] },
- );
-};
-
-1;
+++ /dev/null
-package ComponentUI::TestModel::Foo::Action::CustomAction;
-
-use Reaction::Class;
-
-class CustomAction is 'Reaction::InterfaceModel::Action', which {
- has first_name => (isa => 'NonEmptySimpleStr', is => 'rw', lazy_build => 1);
-};
-
-1;
+++ /dev/null
-package Reaction::InterfaceModel::Action::DBIC::ActionReflector;
-
-use Reaction::Class;
-
-use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
-use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
-use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
-
-class ActionReflector which {
-
- #this will break with immutable. need to port back from dbic::objectclass
- implements reflect_action_for => as {
- my ($self, $class, $action_class, $action, $super, $attrs ) = @_;
-
- my $str = "package ${action_class};\nuse Reaction::Class;\n";
- eval $str;
- confess "Error making ${action_class} a Reaction class: $@" if $@;
- warn $str if $ENV{REACTION_DEBUG};
- my $types = $self->reflect_action_types;
- if( exists $types->{$action} ){ #get defaults if action is a builtin
- my ($conf_super, $conf_attrs) = @{$types->{$action}};
- $super ||= $conf_super;
- $attrs ||= $conf_attrs;
- }
- $super = [ $super ] unless ref($super) eq 'ARRAY';
- $action_class->can('extends')->(@$super);
- warn "extends ".join(', ', map { "'$_'" } @$super).";\n"
- if $ENV{REACTION_DEBUG};
- $attrs ||= [];
- if ($attrs eq '*') {
- $self->reflect_all_writable_attrs($class => $action_class);
- } elsif (ref $attrs eq 'ARRAY' && @$attrs) {
- $self->reflect_attrs($class => $action_class, @$attrs);
- }
- $action_class->can('register_inc_entry')->();
- };
-
- implements reflect_actions_for => as {
- my ($self, $class, $reflected_prefix) = @_;
- foreach my $action ( keys %{ $self->reflect_action_types } ) {
- my @stem_parts = split('::', $class);
- my $last_part = pop(@stem_parts);
- my $action_class = "${reflected_prefix}::${action}${last_part}";
- $self->reflect_action_for($class, $action_class, $action);
- }
- };
-
- implements reflect_all_writable_attrs => as {
- my ($self, $from_class, $to_class) = @_;
- my $from_meta = $from_class->meta;
- foreach my $from_attr ($from_meta->compute_all_applicable_attributes) {
- next unless $from_attr->get_write_method;
- $self->reflect_attribute_to($from_class, $from_attr, $to_class);
- }
- };
-
- implements reflect_attrs => as {
- my ($self, $from_class, $to_class, @attrs) = @_;
- foreach my $attr_name (@attrs) {
- $self->reflect_attribute_to
- ($from_class,
- $from_class->meta->find_attribute_by_name($attr_name),
- $to_class);
- }
- };
-
- implements reflect_attribute_to => as {
- my ($self, $from_class, $from_attr, $to_class) = @_;
- my $attr_name = $from_attr->name;
- my $to_meta = $to_class->meta;
- my %opts; # = map { ($_, $from_attr->$_) } qw/isa is required/;
- my @extra;
- @opts{qw/isa is/} =
- map { my $meth = "_${_}_metadata"; $from_attr->$meth; }
- qw/isa is/;
- if ($from_attr->is_required) {
- if(defined $from_attr->default){
- @opts{qw/required default lazy/} = (1, $from_attr->default, 1);
- } else {
- %opts = (%opts, set_or_lazy_fail($from_attr->name));
- push(@extra, qq!set_or_lazy_fail('@{[$from_attr->name]}')!);
- }
- }
- $opts{predicate} = "has_${attr_name}";
-
- if (my $info = $from_class->result_source_instance
- ->relationship_info($attr_name)) {
- if ($info->{attrs}->{accessor} && $info->{attrs}->{accessor} eq 'multi') {
- confess "${attr_name} is multi and rw. we are confoos."; # XXX
- } else {
- $opts{valid_values} = sub {
- $_[0]->target_model
- ->result_source
- ->related_source($attr_name)
- ->resultset;
- };
- push(@extra, qq!valid_values => sub {
- \$_[0]->target_model
- ->result_source
- ->related_source('${attr_name}')
- ->resultset;
- }!);
- }
- } elsif ($from_attr->type_constraint->name eq 'ArrayRef'
- || $from_attr->type_constraint->is_subtype_of('ArrayRef')) {
- # it's a many-many. time for some magic.
- ($attr_name =~ m/^(.*)_list$/)
- || confess "Many-many attr must be called <name>_list for reflection";
- my $mm_name = $1;
- my ($hm_source, $far_side);
- my $source = $from_class->result_source_instance;
- eval { $hm_source = $source->related_source("links_to_${mm_name}_list"); }
- || confess "Can't find links_to_${mm_name}_list has_many for ${mm_name}_list";
- eval { $far_side = $hm_source->related_source($mm_name); }
- || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
- ." traversing many-many for ${mm_name}_list";
- $opts{default} = sub { [] };
- push(@extra, qq!default => sub { [] }!);
- $opts{valid_values} = sub {
- $_[0]->target_model
- ->result_source
- ->related_source("links_to_${mm_name}_list")
- ->related_source(${mm_name})
- ->resultset;
- };
- push(@extra, qq!valid_values => sub {
- \$_[0]->target_model
- ->result_source
- ->related_source('links_to_${mm_name}_list')
- ->related_source('${mm_name}')
- ->resultset;
- }!);
- }
- next unless $opts{is} eq 'rw';
- $to_meta->_process_attribute($from_attr->name => %opts);
- warn "has '".$from_attr->name."' => (".join(', ',
- (map { exists $opts{$_} ? ("$_ => '".$opts{$_}."'") : () }
- qw/isa is predicate/),
- @extra)
- .");\n" if $ENV{REACTION_DEBUG};
- };
-
- implements reflect_action_types => as {
- return {
- 'Create' => [ Create, '*' ],
- 'Update' => [ Update, '*' ],
- 'Delete' => [ Delete ],
- }
- };
-
-};
-
-1;
-
-=head1 NAME
-
-Reaction::InterfaceModel::Action::DBIC::ActionReflector
-
-=head1 DESCRIPTION
-
-=head2 Create
-
-=head2 Update
-
-=head2 Delete
-
-=head1 METHODS
-
-=head2 reflect_action_for
-
-=head2 reflect_action_types
-
-=head2 reflect_actions_for
-
-=head2 reflect_all_writable_attrs
-
-=head2 reflect_attribute_to
-
-=head2 reflect_attrs
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
package Reaction::InterfaceModel::Collection;
-use Reaction::InterfaceModel::ObjectClass;
+use Reaction::Class;
use Scalar::Util qw/refaddr blessed/;
+use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute';
# WARNING - DANGER: this is just an RFC, please DO NOT USE YET
-class Collection, which {
+class Collection is "Reaction::InterfaceModel::Object", which {
# consider supporting slice, first, iterator, last etc.
# pager functionality should probably be a role
# THEM CORRECT, OR FINAL. JUST A ROUGH DRAFT.
#domain_models are 'ro' unless otherwise specified
- domain_model _collection_store => (is => 'rw', isa => 'ArrayRef',
- lazy_build => 1, clearer => "_clear_collection_store");
+ has _collection_store => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy_build => 1,
+ clearer => "_clear_collection_store",
+ metaclass => DomainModelAttribute,
+ );
implements _build_collection_store => as { [] };
implements _build_collection_store => as {
my $self = shift;
my $im_class = $self->_im_class;
- [ $self->_source_resultset->search({}, {result_class => $im_class})->all ];
+ [ $self->_source_resultset->search(undef, {result_class => $im_class})->all ];
};
implements clone => as {
confess "Not yet implemented";
};
+
+ implements page => as {
+ my $self = shift;
+ my $rs = $self->_source_resultset->page(@_);
+ return (blessed $self)->new(
+ _source_resultset => $rs,
+ _im_class => $self->_im_class,
+ );
+ };
+
+ implements pager => as {
+ my $self = shift;
+ return $self->_source_resultset->pager(@_);
+ };
+
};
1;
role Where, which {
#requires qw/_source_resultset _im_class/;
-
implements where => as {
my $self = shift;
my $rs = $self->_source_resultset->search_rs(@_);
return $self;
};
+ #XXX may need a rename, but i needed this for ListView
+ implements find => as {
+ my $self = shift;
+ $self->_source_resultset
+ ->search({},{result_class => $self->_im_class})
+ ->find(@_);
+ };
};
1;
+++ /dev/null
-package Reaction::InterfaceModel::DBIC::Collection;
-
-use Reaction::Class;
-use aliased 'DBIx::Class::ResultSet';
-
-#this will be reworked to isa Reaction::InterfaceModel::Collection as soon as the
-#API for that is finalized.
-
-class Collection is ResultSet, is 'Reaction::Object', which {
-
- #this really needs to be smarter, fine for CRUD, shit for anything else
- # massive fucking reworking needed here, really
- implements '_default_action_args_for' => as { {} };
-
- implements '_override_action_args_for' => as {
- my ($self) = @_;
- # reset result_class
- my $rs = $self->search_rs
- ({}, { result_class => $self->result_source->result_class });
- return { target_model => $rs };
- };
-
- #feel like it should be an attribute
- implements '_action_class_map' => as { {} };
-
- #feel like it should be a lazy_build attribute
- implements '_default_action_class_prefix' => as {
- shift->result_class;
- };
-
- implements '_default_action_class_for' => as {
- my ($self, $action) = @_;
- return $self->_default_action_class_prefix.'::Action::'.$action;
- };
-
- implements '_action_class_for' => as {
- my ($self, $action) = @_;
- if (defined (my $class = $self->_action_class_map->{$action})) {
- return $class;
- }
- return $self->_default_action_class_for($action);
- };
-
- implements 'action_for' => as {
- my ($self, $action, %args) = @_;
- my $class = $self->_action_class_for($action);
- %args = (
- %{$self->_default_action_args_for($action)},
- %args,
- %{$self->_override_action_args_for($action)},
- );
- return $class->new(%args);
- };
-};
-
-1;
+++ /dev/null
-package Reaction::InterfaceModel::DBIC::ObjectClass;
-
-use Reaction::ClassExporter;
-use Reaction::Class;
-use aliased 'Reaction::InterfaceModel::DBIC::Collection';
-use Class::MOP;
-
-use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
-use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
-use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
-
-use aliased 'Reaction::Meta::InterfaceModel::Action::Class' => 'ActionClass';
-
-class ObjectClass, is 'Reaction::InterfaceModel::ObjectClass', which {
- override exports_for_package => sub {
- my ($self, $package) = @_;
- my %exports = $self->SUPER::exports_for_package($package);
-
- $exports{reflect_actions} = sub {
-
- my %actions = @_;
- my $meta = $package->meta;
- my $defaults = {
- 'Create' => { base => Create },
- 'Update' => { base => Update },
- 'Delete' => { base => Delete },
- };
-
- while (my($name,$opts) = each %actions) {
- my $action_class = delete $opts->{class} ||
- $package->_default_action_class_for($name);
-
- #support this for now, I don't know about defaults yet though.
- #especially, '*' for all writtable attributes. ugh
- my $super = delete $opts->{base} || $defaults->{$name}->{base} || [];
- my $attrs = delete $opts->{attrs} || [];
- $super = (ref($super) ne 'ARRAY' && $super) ? [ $super ] : [];
-
- $self->reflect_action($meta, $action_class, $super, $attrs);
- }
- };
-
-
- my $orig_domain_model = delete $exports{domain_model};
- $exports{domain_model} = sub {
- my($dm_name, %opts) = @_;
-
- my $reflect = delete $opts{reflect};
- my $inflate_result = delete $opts{inflate_result};
-
- my @attr_names = map {ref $_ ? $_->[0] : $_ } @$reflect;
- $opts{reflect} = [@attr_names];
- $orig_domain_model->($dm_name, %opts);
-
- #Create an inflate result_method for DBIC objects
- my $meta = $package->meta;
- if ($inflate_result) {
- my $inflate = sub {
- my $class = shift; my ($source) = @_;
- if($source->isa('DBIx::Class::ResultSourceHandle'))
- {
- $source = $source->resolve;
- }
- return $class->new
- ($dm_name, $source->result_class->inflate_result(@_));
- };
- $meta->add_method('inflate_result', $inflate);
- }
-
- #relationship magic
- my %rel_attrs = map{ @$_ } grep {ref $_} @$reflect;
- my $dm_meta = $opts{isa}->meta;
-
- for my $attr_name ( @attr_names ) {
-
- my $from_attr = $dm_meta->find_attribute_by_name($attr_name);
- confess "Failed to get attribute $attr_name from class $opts{isa}"
- unless $from_attr;
-
- if ( my $info = $opts{isa}->result_source_instance
- ->relationship_info($attr_name) ) {
-
- next unless(my $rel_accessor = $info->{attrs}->{accessor});
-
- unless ( $rel_attrs{$attr_name} ) {
- my ($im_class) = ($package =~ /^(.*)::\w+$/);
- my ($rel_class) = ($attr_name =~ /^(.*?)(_list)?$/);
- $rel_class = join '', map{ ucfirst($_) } split '_', $rel_class;
- $rel_attrs{$attr_name} = "${im_class}::${rel_class}";
- }
- Class::MOP::load_class($rel_attrs{$attr_name}) ||
- confess "Could not load ".$rel_attrs{$attr_name};
-
- #has_many rels
- if ($rel_accessor eq 'multi' &&
- ( $from_attr->type_constraint->name eq 'ArrayRef' ||
- $from_attr->type_constraint->is_subtype_of('ArrayRef') )
- ) {
-
- # # remove the old attribute and recreate it with new isa
- my %attr_opts = ( is => 'ro',
- lazy_build => 1,
- isa => Collection,
- clearer => "_clear_${attr_name}",
- domain_model => $dm_name,
- orig_attr_name => $attr_name,
- );
- $meta->add_attribute( $attr_name, %attr_opts);
-
- #remove old build and add a better one
- #proper collections will remove the result_class uglyness.
- my $build_method = sub {
- my $rs = shift->$dm_name->search_related_rs
- ($attr_name, {},
- {
- result_class => $rel_attrs{$attr_name} });
- return bless($rs => Collection);
- };
- $meta->remove_method( "build_${attr_name}");
- $meta->add_method( "build_${attr_name}", $build_method);
- } elsif ($rel_accessor eq 'single') {
- # # remove the old attribute and recreate it with new isa
- my %attr_opts = ( is => 'ro',
- lazy_build => 1,
- isa => $rel_attrs{$attr_name},
- clearer => "_clear_${attr_name}",
- domain_model => $dm_name,
- orig_attr_name => $attr_name,
- );
- $meta->add_attribute( $attr_name, %attr_opts);
-
- #delete and recreate the build method to properly inflate the
- #result into an IM::O class instead of the original
- #this probably needs some cleaning
- #proper collections will remove the result_class uglyness.
- my $build_method = sub {
- shift->$dm_name->find_related
- ($attr_name, {},
- {
- result_class => $rel_attrs{$attr_name}});
- };
- $meta->remove_method( "build_${attr_name}");
- $meta->add_method( "build_${attr_name}", $build_method);
- }
- } elsif ( $from_attr->type_constraint->name eq 'ArrayRef' ||
- $from_attr->type_constraint->is_subtype_of('ArrayRef')
- ) {
- #m2m magicness
- next unless $attr_name =~ m/^(.*)_list$/;
- my $mm_name = $1;
- my ($hm_source, $far_side);
- # we already get one for the rel info check, unify that??
- my $source = $opts{isa}->result_source_instance;
- eval { $hm_source = $source->related_source("links_to_${mm_name}_list"); }
- || confess "Can't find links_to_${mm_name}_list has_many for ${mm_name}_list";
- eval { $far_side = $hm_source->related_source($mm_name); }
- || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
- ." traversing many-many for ${mm_name}_list";
-
- # # remove the old attribute and recreate it with new isa
- my %attr_opts = ( is => 'ro',
- lazy_build => 1,
- isa => Collection,
- clearer => "_clear_${attr_name}",
- domain_model => $dm_name,
- orig_attr_name => $attr_name,
- );
- $meta->add_attribute( $attr_name, %attr_opts);
-
- #proper collections will remove the result_class uglyness.
- my $build_method = sub {
- my $rs = shift->$dm_name->result_source
- ->related_source("links_to_${mm_name}_list")
- ->related_source(${mm_name})
- ->resultset->search_rs
- ({},{result_class => $rel_attrs{$attr_name} });
- return bless($rs => Collection);
- };
- $meta->remove_method( "build_${attr_name}");
- $meta->add_method( "build_${attr_name}", $build_method);
- }
- }
- };
- return %exports;
- };
-};
-
-
-sub reflect_action{
- my($self, $meta, $action_class, $super, $attrs) = @_;
-
- Class::MOP::load_class($_) for @$super;
-
- #create the class
- my $ok = eval { Class::MOP::load_class($action_class) };
-
- confess("Class '${action_class}' does not seem to support method 'meta'")
- if $ok && !$action_class->can('meta');
-
- my $action_meta = $ok ?
- $action_class->meta : ActionClass->create($action_class, superclasses => $super);
-
- $action_meta->make_mutable if $action_meta->is_immutable;
-
- foreach my $attr_name (@$attrs){
- my $attr = $meta->find_attribute_by_name($attr_name);
- my $dm_isa = $meta->find_attribute_by_name($attr->domain_model)->_isa_metadata;
- my $from_attr = $dm_isa->meta->find_attribute_by_name($attr->orig_attr_name);
-
- #Don't reflect read-only attributes to actions
- if ($from_attr->_is_metadata ne 'rw') {
- warn("Not relecting read-only attribute ${attr_name} to ${action_class}");
- next;
- }
-
- #add the attribute to the class
- $action_class->meta->add_attribute
- ( $attr_name =>
- $self->reflected_attr_opts($meta, $dm_isa, $from_attr)
- );
- }
-
- $action_class->meta->make_immutable;
-}
-
-sub reflected_attr_opts{
- my ($self, $meta, $dm, $attr) = @_;
- my $attr_name = $attr->name;
-
- my %opts = (
- is => 'rw',
- isa => $attr->_isa_metadata,
- required => $attr->is_required,
- predicate => "has_${attr_name}",
- );
-
- if ($opts{required}) {
- $opts{default} = !$attr->has_default ?
- sub{confess("${attr_name} must be provided before calling reader")}
- : $attr->default;
- $opts{lazy} = 1;
- }
-
- #test for relationships
- my $source = $dm->result_source_instance;
- my $constraint = $attr->type_constraint;
- if (my $info = $source->relationship_info($attr_name)) {
- if ( $info->{attrs}->{accessor} &&
- $info->{attrs}->{accessor} eq 'multi') {
- confess "${attr_name} is multi and rw. we are confoos.";
- } else {
- $opts{valid_values} = sub {
- $_[0]->target_model->result_source
- ->related_source($attr_name)->resultset;
- };
- }
- } elsif ($constraint->name eq 'ArrayRef' ||
- $constraint->is_subtype_of('ArrayRef')) {
- # it's a many-many. time for some magic.
- my $link_rel = "links_to_${attr_name}";
- my ($mm_name) = ($attr_name =~ m/^(.*)_list$/);
- confess "Many-many attr must be called <name>_list for reflection"
- unless $mm_name;
-
- my ($hm_source, $far_side);
- eval { $hm_source = $source->related_source($link_rel); }
- || confess "Can't find ${link_rel} has_many for ${attr_name}";
- eval { $far_side = $hm_source->related_source($mm_name); }
- || confess "Can't find ${mm_name} belongs_to on " .
- $hm_source->result_class." traversing many-many for ${attr_name}";
-
- $opts{default} = sub { [] };
- $opts{valid_values} = sub {
- $_[0]->target_model->result_source->related_source($link_rel)
- ->related_source($mm_name)->resultset;
- };
- }
-
- return \%opts;
-}
-
-1;
-
-=head1 NAME
-
-Reaction::InterfaceModel::DBIC::ObjectClass
-
-=head1 SYNOPSIS
-
-=head2 domain_model
-
- package Prefab::AdminModel::User;
-
- class User, is Object, which{
- #create an attribute _user_store with type constraint MyApp::DB::User
- domain_model '_user_store' =>
- (isa => 'MyApp::DB::User',
- #mirror the following attributes from MyApp::DB::User
- #will create collections for rels which use result_classes of:
- # Prefab::AdminModel::(Group|ImagedDocument)
- # Prefab::AdminModel::DocumentNotes
- reflect => [qw/id username password created_d group_list imaged_document/,
- [doc_notes_list => 'Prefab::AdminModel::DocumentNotes']
- ],
- #automatically add a sub inflate_result that inflates the DBIC obj
- #to a Prefab::AdminModel::User with the dbic obj in _user_store
- inflate_result => 1,
- );
- };
-
-=head2 reflect_actions
-
- reflect_actions
- (
- Create => { attrs =>[qw(first_name last_name baz_list)] },
- Update => { attrs =>[qw(first_name last_name baz_list)] },
- Delete => {},
- );
-
-=head1 DESCRIPTION
-
-=head1 ATTRIBUTES
-
-=head2 isa
-
-=head2 reflect
-
-=head2 inflate_result
-
-=head2 handles
-
-=head1 METHODS
-
-=head2 reflect_actions
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-package Reaction::InterfaceModel::DBIC::SchemaClass;
-
-use Reaction::ClassExporter;
-use Reaction::Class;
-use aliased 'Reaction::InterfaceModel::DBIC::Collection';
-use Reaction::InterfaceModel::Object;
-use Class::MOP;
-
-# consider that the schema class should provide it's own connect method, that
-# way for single domain_models we could just let handles => take care of it
-# and for many domain_models we could iterate through them and connect.. or something
-# similar. is that crossing layers?? I think it seems reasonable TBH
-
-class SchemaClass which {
-
- overrides default_base => sub { ('Reaction::InterfaceModel::Object') };
-
- override exports_for_package => sub {
- my ($self, $package) = @_;
- my %exports = $self->SUPER::exports_for_package($package);
-
- $exports{domain_model} = sub{
- my($dm_name, %opts) = @_;
- my $meta = $package->meta;
-
- my $isa = $opts{isa};
- confess 'no isa declared!' unless defined $isa;
-
- unless( ref $isa || Moose::Util::TypeConstraints::find_type_constraint($isa) ){
- eval{ Class::MOP::load_class($isa) };
- warn "'${isa}' is not a valid Moose type constraint. Moose will treat it as ".
- "a class name and create an anonymous constraint for you. This class is ".
- "not currently load it and ObjectClass failed to load it. ($@)"
- if $@;
- }
-
- my $reflect = delete $opts{reflect};
- confess("parameter 'reflect' must be an array reference")
- unless ref $reflect eq 'ARRAY';
-
- $meta->add_domain_model($dm_name, is => 'ro', required => 1, %opts);
-
- for ( @$reflect ){
- my ($moniker,$im_class,$reader) = ref $_ eq 'ARRAY' ? @$_ : ($_);
-
- my $clearer = "_clear_${moniker}";
- $im_class ||= "${package}::${moniker}";
- Class::MOP::load_class($im_class) || confess "Could not load ${im_class}";
-
- unless($reader){
- $reader = $moniker;
- $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
- $reader = lc($moniker) . "_collection";
- }
- # problem: we should have fresh resultsets every time the reader is called
- # solution 1: override reader to return fresh resultsets each time.
- # solution 2: uing an around modifier on the reader,call clearer after
- # getting the collection from the $super->(), but before returning it.
- # #1 seems more efficient, but #2 seems more correct.
- my %args = (isa => Collection, domain_model => $dm_name,
- lazy_build => 1, reader => $reader, clearer => $clearer);
- my $attr = $meta->add_attribute($moniker, %args);
-
- # blessing into a collection is very dirty, but it'll have to do until I
- # create a proper collection object. This should happen as soon as me and mst
- # can deisgn a common API for Collections.
- my $build_method = sub {
- my $collection = shift->$dm_name->resultset( $moniker );
- $collection = $collection->search_rs({}, {result_class => $im_class});
- return bless($collection => Collection);
- };
-
- $meta->add_method( "build_${moniker}", $build_method);
-
- my $reader_method = sub{
- my ($super, $self) = @_;
- my $result = $super->($self);
- $self->$clearer;
- return $result;
- };
- $meta->add_around_method_modifier($attr->reader, $reader_method);
- }
- };
-
- return %exports;
- };
-};
-
-1;
-
-__END__;
-
-=head1 NAME
-
-Reaction::InterfaceModel::DBIC::SchemaClass
-
-=head1 SYNOPSYS
-
- package MyApp::AdminModel;
-
- use Reaction::InterfaceModel::DBIC::ObjectClass;
-
- #unless specified, the superclass will be Reaction::InterfaceModel::Object
- class AdminModel, which{
- domain_model'my_db_schema' =>
- ( isa => 'MyApp::Schema',
- reflect => [
- 'ResultSetA', # same as ['ResultSetA']
- [ResultSetB => 'MyApp::AdminModel::RSB'],
- [ResultSetC => 'MyApp::AdminModel::RSC', 'resultset_c_collection'],
- ],
- );
-
-=head1 DESCRIPTION
-
-Each item in reflect may be either a string or an arrayref. If a string, it should be
-the name of the ResultSet, ie what you would put inside
- $schema->resultset( 'rs_name' ); As an array it must contain the resultset name,
-and may optionally provide the proper InterfaceModel class and the name of the method
-used to obtain a collection.
-
-The example shown will generate reflects 3 resultsets from MyApp::Schema,
-a DBIC::Schema file which will be stored as attribute 'my_db_schema', which is
-an attribute of type Reaction::InterfaceModel::Object::DomainModelAttribute.
-
-ResultSetA will be reflected as an attribute named 'ResultSetA', will inflate to the
-IM Class 'MyApp::AdminModel::ResultSetA' and a collection can be obtained through
-MyApp::AdminModel->resultseta_collection
-
-ResultSetB will be reflected as an attribute named 'ResultSetB', will inflate to the
-IM Class 'MyApp::AdminModel::RSB' and a collection can be obtained through
-MyApp::AdminModel->resultsetb_collection
-
-ResultSetC will be reflected as an attribute named 'ResultSetC', will inflate to the
-IM Class 'MyApp::AdminModel::RSC' and a collection can be obtained through
-MyApp::AdminModel->resultset_c_collection
-
-=head1 METHODS
-
-=head2 default_base
-
-Specifies the superclass, the default being L<Reaction::InterfaceModel::Object>.
-
-=head2 exports_for_package
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
implements '_default_action_class_for' => as {
my ($self, $action) = @_;
-
+ confess("Wrong arguments") unless $action;
#little trick in case we call it in class context!
my $prefix = ref $self ?
$self->_default_action_class_prefix :
implements '_action_class_for' => as {
my ($self, $action) = @_;
+ confess("Wrong arguments") unless $action;
if (defined (my $class = $self->_action_class_map->{$action})) {
return $class;
}
implements 'action_for' => as {
my ($self, $action, %args) = @_;
+ confess("Wrong arguments") unless $action;
my $class = $self->_action_class_for($action);
%args = (
%{$self->_default_action_args_for($action)},
+++ /dev/null
-package Reaction::InterfaceModel::ObjectClass;
-
-use Reaction::ClassExporter;
-use Reaction::Class;
-use Class::MOP;
-
-#use Reaction::InterfaceModel::Object;
-use Moose::Util::TypeConstraints ();
-use Reaction::InterfaceModel::Object;
-
-class ObjectClass which {
-
- overrides default_base => sub { ('Reaction::InterfaceModel::Object') };
-
- overrides exports_for_package => sub {
- my ($self, $package) = @_;
- my %exports = $self->SUPER::exports_for_package($package);
-
- $exports{domain_model} = sub {
- my($dm_name, %opts)= @_;
-
- my $isa = $opts{isa};
- confess 'no isa declared!' unless defined $isa;
-
- unless( ref $isa || Moose::Util::TypeConstraints::find_type_constraint($isa) ){
- eval{ Class::MOP::load_class($isa) };
- warn "'${isa}' is not a valid Moose type constraint. Moose will treat it as ".
- "a class name and create an anonymous constraint for you. This class is ".
- "not currently load it and ObjectClass failed to load it. ($@)"
- if $@;
- }
-
- my $attrs = delete $opts{reflect};
- my $meta = $package->meta;
-
- #let opts override is and required as needed
- my $dm_attr = $meta->add_domain_model($dm_name, is => 'ro', required => 1, %opts);
-
- return unless ref $attrs && @$attrs;
- my $dm_meta = eval{ $isa->meta };
- confess "Reflection requires that the argument to isa ('${isa}') be a class ".
- " supporting introspection e.g a Moose-based class." if $@;
-
- foreach my $attr_name (@$attrs) {
- my $from_attr = $dm_meta->find_attribute_by_name($attr_name);
- my $reader = $from_attr->get_read_method;
-
- my %attr_opts = ( is => 'ro',
- lazy_build => 1,
- isa => $from_attr->_isa_metadata,
- clearer => "_clear_${attr_name}",
- domain_model => $dm_name,
- orig_attr_name => $attr_name,
- );
-
- $meta->add_attribute( $attr_name, %attr_opts);
- $meta->add_method( "build_${attr_name}", sub{ shift->$dm_name->$reader });
- }
-
- my $clearer = sub{ $_[0]->$_ for map { "_clear_${_}" } @$attrs };
-
- $package->can('_clear_reflected') ?
- $meta->add_before_method_modifier('_clear_reflected', $clearer) :
- $meta->add_method('_clear_reflected', $clearer);
-
- #i dont like this, this needs reworking, maybe pass
- # target_models => [$self->meta->domain_models?]
- # or maybe this should be done by reflect_actions ?
- # what about non-reflected actions then though?
- # maybe a has_action => ('Action_Name' => ActionClass) keyword?
- #it'd help in registering action_for ....
- #UPDATE: this is going away very very soon
- my $dm_reader = $dm_attr->get_read_method;
- if($package->can('_default_action_args_for')){
- my $act_args = sub {
- my $super = shift;
- my $self = shift;
- return { %{ $super->($self, @_) }, target_model => $self->$dm_reader };
- };
- $meta->add_around_method_modifier('_default_action_args_for', $act_args);
- } else {
- $meta->add_method('_default_action_args_for', sub {
- return {target_model => shift->$dm_reader};
- }
- );
- }
- };
-
- return %exports;
- };
-
-};
-
-1;
-
-__END__;
-
-=head1 NAME
-
-Reaction::Class::InterfaceModel::ObjectClass
-
-=head1 SYNOPSIS
-
- package MyApp::AdminModel::Foo;
- use Reaction::Class::InterfaceModel::ObjectClass;
-
- #will default to be a Reaction::InterfaceModel::Object unless otherwise specified
- class Foo, which{
- #create an attribute _user_store with type constraint MyApp::Data::User
- domain_model '_user_store' =>
- (isa => 'MyApp::Data::User',
- #mirror the following attributes from MyApp::Data::User
- reflect => [qw/id username password created_d/],
- ...
- };
-
-=head1 DESCRIPTION
-
-Extends C<Reaction::Class> to provide new sugar for InterfaceModel Objects.
-
-=head1 Extended methods / new functionality
-
-=head2 exports_for_package
-
-Overridden to add exported methods C<proxies> and C<_clear_proxied>
-
-=head2 domain_model $name => ( isa => 'Classname' reflect => [qw/attr names/] )
-
-Will create a read-only required attribute $name of type C<isa> which will
-reflect the attributes named in C<reflect>, to the local class as
-read-only attributes that will build lazily.
-
-It will also override C<_default_action_args_for> to pass the domain model
-as C<target_model>
-
-=head2 _clear_reflected
-
-Will clear all reflected attributes.
-
-=head2 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
use Reaction::Class;
use Class::MOP;
+use Catalyst::Utils;
+
class DBIC, which {
- has model_class => (isa => "Str", is => 'ro', required => 1);
- has debug_mode =>
- (isa => 'Bool', is => 'rw', required => 1, default => '0');
- has make_classes_immutable =>
- (isa => 'Bool', is => 'rw', required => 1, default => '0');
-
- has default_object_actions =>
- ( isa => "ArrayRef", is => "rw", required => 1,
- default => sub{
- [ { name => 'Update', base => Update },
- { name => 'Delete', base => Delete,
- attributes => [],
- },
- ];
- } );
-
- has default_collection_actions =>
- ( isa => "ArrayRef", is => "rw", required => 1,
- default => sub{
- [{name => 'Create', base => Create}],
- } );
-
- implements BUILD => as{
+ #user defined actions and prototypes
+ has object_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
+ has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
+
+ #which actions to create by default
+ has default_object_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1);
+ has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1);
+
+ #builtin actions and prototypes
+ has builtin_object_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
+ has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1);
+
+ implements build_object_actions => as { {} };
+ implements build_collection_actions => as { {} };
+
+ implements build_default_object_actions => as { [ qw/Update Delete/ ] };
+ implements build_default_collection_actions => as { [ 'Create' ] };
+
+ implements build_builtin_object_actions => as {
+ {
+ Update => { base => Update },
+ Delete => { base => Delete, attributes => [] },
+ };
+ };
+
+ implements build_builtin_collection_actions => as {
+ { Create => {base => Create } };
+ };
+
+ implements _all_object_actions => as {
my $self = shift;
- my $ok = eval {Class::MOP::load_class( $self->model_class ); };
+ return $self->merge_hashes
+ ($self->builtin_object_actions, $self->object_actions);
+ };
- unless ($ok){
- print STDERR "Creating target class ". $self->model_class . "\n"
- if $self->debug_mode;
- Object->meta->create($self->model_class, superclasses => [ Object ]);
- }
+ implements _all_collection_actions => as {
+ my $self = shift;
+ return $self->merge_hashes
+ ($self->builtin_collection_actions, $self->collection_actions);
+ };
+
+ implements dm_name_from_class_name => as {
+ my($self, $class) = @_;
+ confess("wrong arguments") unless $class;
+ $class =~ s/::/_/g;
+ $class = "_" . lc($class) . "_store";
+ return $class;
};
- implements submodel_classname_from_source_name => as {
- my ($self, $moniker) = @_;
- return join "::", $self->model_class, $moniker;
+ implements dm_name_from_source_name => as {
+ my($self, $source) = @_;
+ confess("wrong arguments") unless $source;
+ $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
+ $source = "_" . lc($source) . "_store";
+ return $source;
};
- implements classname_for_collection_of => as {
+ implements class_name_from_source_name => as {
+ my ($self, $model_class, $source_name) = @_;
+ confess("wrong arguments") unless $model_class && $source_name;
+ return join "::", $model_class, $source_name;
+ };
+
+ implements class_name_for_collection_of => as {
my ($self, $object_class) = @_;
+ confess("wrong arguments") unless $object_class;
return "${object_class}::Collection";
};
- #requires domain_model everything else optional
- implements reflect_model => as {
+ implements merge_hashes => as {
+ my($self, $left, $right) = @_;
+ return Catalyst::Utils::merge_hashes($left, $right);
+ };
+
+ implements parse_reflect_rules => as {
+ my ($self, $rules, $haystack) = @_;
+ confess('$rules must be an array reference') unless ref $rules eq 'ARRAY';
+ confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY';
+
+ my $needles = {};
+ my (@exclude, @include, $global_opts);
+ if(@$rules == 2 && $rules->[0] eq '-exclude'){
+ push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1]));
+ } else {
+ for my $rule ( @$rules ){
+ if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){
+ push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1]));
+ } elsif( ref $rule eq 'HASH' ){
+ $global_opts = ref $global_opts eq 'HASH' ?
+ $self->merge_hashes($global_opts, $rule) : $rule;
+ } else {
+ push(@include, $rule);
+ }
+ }
+ }
+ my $check_exclude = sub{
+ for my $rule (@exclude){
+ return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule);
+ }
+ return;
+ };
+
+ @$haystack = grep { !$check_exclude->($_) } @$haystack;
+ $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts);
+ return $needles;
+ };
+
+ implements merge_reflect_rules => as {
+ my ($self, $rules, $needles, $haystack, $local_opts) = @_;
+ for my $rule ( @$rules ){
+ if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){
+ $needles->{$rule} = defined $needles->{$rule} ?
+ $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts;
+ } elsif( ref $rule eq 'Regexp' ){
+ for my $match ( grep { /$rule/ } @$haystack ){
+ $needles->{$match} = defined $needles->{$match} ?
+ $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts;
+ }
+ } elsif( ref $rule eq 'ARRAY' ){
+ my $opts;
+ $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH';
+ $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts;
+ $self->merge_reflect_rules($rule, $needles, $haystack, $opts);
+ }
+ }
+ };
+
+ implements reflect_schema => as {
my ($self, %opts) = @_;
- my $meta = $self->model_class->meta;
- my $source = delete $opts{domain_model_class};
+ my $base = delete $opts{base} || Object;
+ my $model = delete $opts{model_class};
+ my $schema = delete $opts{schema_class};
my $dm_name = delete $opts{domain_model_name};
my $dm_args = delete $opts{domain_model_args} || {};
+ $dm_name ||= $self->dm_name_from_class_name($schema);
+
+ #load all necessary classes
+ confess("model_class and schema_class are required parameters")
+ unless($model && $schema);
+ Class::MOP::load_class( $base );
+ Class::MOP::load_class( $schema );
+ my $meta = eval {Class::MOP::load_class($model); } ?
+ $model->meta : $base->meta->create($model, superclasses => [ $base ]);
+
+ # sources => undef, #default to qr/./
+ # sources => [], #default to nothing
+ # sources => qr//, #DWIM, treated as [qr//]
+ # sources => [{...}] #DWIM, treat as [qr/./, {...} ]
+ # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
+ my $haystack = [ $schema->sources ];
+
+ my $rules = delete $opts{sources};
+ if(!defined $rules){
+ $rules = [qr/./];
+ } elsif( ref $rules eq 'Regexp'){
+ $rules = [ $rules ];
+ } elsif( ref $rules eq 'ARRAY' && @$rules){
+ #don't add a qr/./ rule if we have at least one match rule
+ push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
+ || !ref $_ || ref $_ eq 'Regexp'} @$rules;
+ }
- my $reflect_submodels = delete $opts{reflect_submodels};
- my %exclude_submodels = map {$_ => 1}
- ref $opts{exclude_submodels} ? @{$opts{exclude_submodels}} : ();
+ my $sources = $self->parse_reflect_rules($rules, $haystack);
- Class::MOP::load_class($source);
- my $make_immutable = $self->make_classes_immutable || $meta->is_immutable;
+ my $make_immutable = $meta->is_immutable;
$meta->make_mutable if $meta->is_immutable;
- unless( $dm_name ){
- $dm_name = "_".$source;
- $dm_name =~ s/::/_/g;
- }
-
- print STDERR "Reflecting model '$source' with domain model '$dm_name'\n"
- if $self->debug_mode;
- $meta->add_domain_model($dm_name, is => 'rw', required => 1, %$dm_args);
-
- #reflect all applicable submodels on undef
- @$reflect_submodels = $source->sources unless ref $reflect_submodels;
- @$reflect_submodels = grep { !$exclude_submodels{$_} } @$reflect_submodels;
-
- for my $moniker (@$reflect_submodels){
- my $source_class = $source->class($moniker);
- print STDERR "... and submodel '$source_class'\n" if $self->debug_mode;
- my $sub_meta = $self->reflect_submodel(domain_model_class => $source_class);
- my $col_meta = $self->reflect_collection_for(object_class => $sub_meta->name);
-
- $self->add_submodel_to_model(
- source_name => $moniker,
- domain_model_name => $dm_name,
- collection_class => $col_meta->name,
- );
+ $meta->add_domain_model
+ ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args);
+
+ for my $source_name (keys %$sources){
+ my $source_opts = $sources->{$source_name} || {};
+ $self->reflect_source(
+ source_name => $source_name,
+ parent_class => $model,
+ schema_class => $schema,
+ source_class => $schema->class($source_name),
+ parent_domain_model_name => $dm_name,
+ %$source_opts
+ );
}
$meta->make_immutable if $make_immutable;
return $meta;
};
- #XXX I could make domain_model_name by exploiting the metadata in the
- #DomainModelAttribute, I'm just waiting to properly redesign DMAttr,
- #it'll be good, I promise.
+ implements _compute_source_options => as {
+ my ($self, %opts) = @_;
+ my $schema = delete $opts{schema_class};
+ my $source_name = delete $opts{source_name};
+ my $source_class = delete $opts{source_class};
+ my $parent = delete $opts{parent_class};
+ my $parent_dm = delete $opts{parent_domain_model_name};
+
+ #this is the part where I hate my life for promissing all sorts of DWIMery
+ confess("parent_class and source_name or source_class are required parameters")
+ unless($parent && ($source_name || $source_class));
+
+ OUTER: until( $schema && $source_name && $source_class && $parent_dm ){
+ if( $schema && !$source_name){
+ next OUTER if $source_name = $source_class->result_source_instance->source_name;
+ } elsif( $schema && !$source_class){
+ next OUTER if $source_class = eval { $schema->class($source_name) };
+ }
- implements add_submodel_to_model => as {
- my($self, %opts) = @_;
- my $reader = $opts{reader};
- my $moniker = $opts{source_name};
- my $dm_name = $opts{domain_model_name};
- my $c_class = $opts{collection_class};
- my $name = $opts{attribute_name} || $moniker;
- my $meta = $self->model_class->meta;
+ if($source_class && (!$schema || !$source_name)){
+ if(!$schema){
+ $schema = $source_class->result_source_instance->schema;
+ next OUTER if $schema && Class::MOP::load_class($schema);
+ }
+ if(!$source_name){
+ $source_name = $source_class->result_source_instance->source_name;
+ next OUTER if $source_name;
+ }
+ }
+ my @haystack = $parent_dm ?
+ $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models;
+
+ #there's a lot of guessing going on, but it should work fine on most cases
+ INNER: for my $needle (@haystack){
+ my $isa = $needle->_isa_metadata;
+ next INNER unless Class::MOP::load_class( $isa->_isa_metadata );
+ next INNER unless $isa->isa('DBIx::Class::Schema');
+ if(!$parent_dm && $schema && $isa eq $schema){
+ $parent_dm = $needle->name;
+ next OUTER;
+ }
+
+ if( $source_name ){
+ my $src_class = eval{ $isa->class($source_name) };
+ next INNER unless $src_class;
+ next INNER if($source_class && $source_class ne $src_class);
+ $schema = $isa;
+ $parent_dm = $needle->name;
+ $source_class = $src_class;
+ next OUTER;
+ }
+ }
+
+ #do we even need to go this far?
+ if( !$parent_dm && $schema ){
+ my $tentative = $self->dm_name_from_class_name($schema);
+ $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack;
+ }
+
+ confess("Could not determine options automatically from: schema " .
+ "'${schema}', source_name '${source_name}', source_class " .
+ "'${source_class}', parent_domain_model_name '${parent_dm}'");
+ }
+
+ return {
+ source_name => $source_name,
+ schema_class => $schema,
+ source_class => $source_class,
+ parent_class => $parent,
+ parent_domain_model_name => $parent_dm,
+ };
+ };
- my $make_immutable = $meta->is_immutable;
- $meta->make_mutable if $meta->is_immutable;
- unless ($reader){
- $reader = $moniker;
+ implements add_source => as {
+ my ($self, %opts) = @_;
+
+ my $model = delete $opts{model_class};
+ my $reader = delete $opts{reader};
+ my $source = delete $opts{source_name};
+ my $dm_name = delete $opts{domain_model_name};
+ my $collection = delete $opts{collection_class};
+ my $name = delete $opts{attribute_name} || $source;
+
+ confess("model_class and source_name are required parameters")
+ unless $model && $source;
+ my $meta = $model->meta;
+
+ unless( $collection ){
+ my $object = $self->class_name_from_source_name($model, $source);
+ $collection = $self->class_name_for_collection_of($object);
+ }
+ unless( $reader ){
+ $reader = $source;
$reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
$reader = lc($reader) . "_collection";
}
+ unless( $dm_name ){
+ my @haystack = $meta->domain_models;
+ if( @haystack > 1 ){
+ @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack;
+ }
+ if(@haystack == 1){
+ $dm_name = $haystack[0]->name;
+ } elsif(@haystack > 1){
+ confess("Failed to automatically determine domain_model_name. More than one " .
+ "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")");
+ } else {
+ confess("Failed to automatically determine domain_model_name. No matches.");
+ }
+ }
my %attr_opts =
(
lazy => 1,
- isa => $c_class,
required => 1,
+ isa => $collection,
reader => $reader,
- predicate => "has_${moniker}",
+ predicate => "has_${name}",
domain_model => $dm_name,
- orig_attr_name => $moniker,
+ orig_attr_name => $source,
default => sub {
- $c_class->new(_source_resultset => shift->$dm_name->resultset($moniker) );
+ $collection->new(_source_resultset => shift->$dm_name->resultset($source));
},
);
- print STDERR "... linking submodel '$c_class' through method '$reader'\n"
- if $self->debug_mode;
- my $attr = $meta->add_attribute($moniker, %attr_opts);
+ my $make_immutable = $meta->is_immutable;
+ $meta->make_mutable if $make_immutable;
+ my $attr = $meta->add_attribute($name, %attr_opts);
$meta->make_immutable if $make_immutable;
+
return $attr;
};
- # requires #object_class, everything else optional
- implements reflect_collection_for => as {
+ implements reflect_source => as {
+ my ($self, %opts) = @_;
+ my $collection = delete $opts{collection} || {};
+ %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
+
+ my $obj_meta = $self->reflect_source_object(%opts);
+ my $col_meta = $self->reflect_source_collection
+ (
+ object_class => $obj_meta->name,
+ source_class => $opts{source_class},
+ %$collection
+ );
+
+ $self->add_source(
+ model_class => $opts{parent_class},
+ source_name => $opts{source_name},
+ domain_model_name => $opts{parent_domain_model_name},
+ collection_class => $col_meta->name,
+ );
+ };
+
+ implements reflect_source_collection => as {
my ($self, %opts) = @_;
- my $object = delete $opts{object_class};
my $base = delete $opts{base} || ResultSet;
- my $actions = delete $opts{reflect_actions} || $self->default_collection_actions;
- my $class = $opts{class} || $self->classname_for_collection_of($object);
+ my $class = delete $opts{class};
+ my $object = delete $opts{object_class};
+ my $source = delete $opts{source_class};
+ my $action_rules = delete $opts{actions};
+
+ confess('object_class and source_class are required parameters')
+ unless $object && $source;
+ $class ||= $self->class_name_for_collection_of($object);
- Class::MOP::load_class($base);
+ Class::MOP::load_class( $base );
+ Class::MOP::load_class( $object );
my $meta = eval { Class::MOP::load_class($class) } ?
- $class->meta : $base->meta->create($class, superclasses =>[ $base ]);
- my $make_immutable = $self->make_classes_immutable || $meta->is_immutable;
- $meta->make_mutable if $meta->is_immutable;
+ $class->meta : $base->meta->create( $class, superclasses => [ $base ]);
+ my $make_immutable = $meta->is_immutable;
+ $meta->make_mutable if $meta->is_immutable;
$meta->add_method(_build_im_class => sub{ $object } );
- print STDERR "... Reflecting collection of $object as $class\n"
- if $self->debug_mode;
-
- for my $action (@$actions){
- unless (ref $action){
- my $default = grep {$_->{name} eq $action} @{ $self->default_collection_actions };
- confess("unable to reflect action $action") unless $default;
- $action = $default;
+ #XXX as a default pass the domain model as a target_model until i come up with something
+ #better through the coercion method
+ my $def_act_args = sub {
+ my $super = shift;
+ return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } };
+ };
+ $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
+
+
+ {
+ my $all_actions = $self->_all_collection_actions;
+ my $action_haystack = [keys %$all_actions];
+ if(!defined $action_rules){
+ $action_rules = $self->default_collection_actions;
+ } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
+ $action_rules = [ $action_rules ];
+ } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
+ #don't add a qr/./ rule if we have at least one match rule
+ push(@$action_rules, qr/./)
+ unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
+ || !ref $_ || ref $_ eq 'Regexp'} @$action_rules;
}
- $self->reflect_submodel_action(submodel_class => $object, %$action);
- my $act_args = sub { #override target model for this action
- my $super = shift;
- return { %{$super->(@_)},($_[1] eq $action->{name} ?
- (target_model => $_[0]->_source_resultset) : () )};
- };
- $meta->add_around_method_modifier('_default_action_args_for', $act_args);
- }
+ # XXX this is kind of a dirty hack to support custom actions that are not
+ # previously defined and still be able to use the parse_reflect_rules mechanism
+ my @custom_actions = grep {!exists $all_actions->{$_}}
+ map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
+ push(@$action_haystack, @custom_actions);
+ my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
+ for my $action (keys %$actions){
+ my $action_opts = $self->merge_hashes
+ ($all_actions->{$action} || {}, $actions->{$action} || {});
+ $self->reflect_source_action(
+ name => $action,
+ object_class => $object,
+ source_class => $source,
+ %$action_opts,
+ );
+
+ # XXX i will move this to use the coercion method soon. this will be
+ # GoodEnough until then. I still need to think a little about the type coercion
+ # thing so i don't make a mess of it
+ my $act_args = sub { #override target model for this action
+ my $super = shift;
+ return { %{ $super->(@_) },
+ ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) };
+ };
+ $meta->add_around_method_modifier('_default_action_args_for', $act_args);
+ }
+ }
$meta->make_immutable if $make_immutable;
return $meta;
};
- #requires domain_model_class everything else optional
- implements reflect_submodel => as {
- my ($self, %opts) = @_;
- my $source = delete $opts{domain_model_class};
- my $base = delete $opts{base} || Object;
- my $dm_name = delete $opts{domain_model_name};
- my $dm_opts = delete $opts{domain_model_args} || {};
- my $inflate = exists $opts{inflate} ? delete $opts{inflate} : 1;
- my $class = delete $opts{class} ||
- $self->submodel_classname_from_source_name($source->source_name);
- my $actions = delete $opts{reflect_actions} || $self->default_object_actions;
-
- #create the custom class
- Class::MOP::load_class($base);
+ implements reflect_source_object => as {
+ my($self, %opts) = @_;
+ %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) };
+
+ my $base = delete $opts{base} || Object;
+ my $class = delete $opts{class};
+ my $dm_name = delete $opts{domain_model_name};
+ my $dm_opts = delete $opts{domain_model_args} || {};
+
+ my $source_name = delete $opts{source_name};
+ my $schema = delete $opts{schema_class};
+ my $source_class = delete $opts{source_class};
+ my $parent = delete $opts{parent_class};
+ my $parent_dm = delete $opts{parent_domain_model_name};
+
+ my $action_rules = delete $opts{actions};
+ my $attr_rules = delete $opts{attributes};
+
+ $class ||= $self->class_name_from_source_name($parent, $source_name);
+
+ Class::MOP::load_class($parent);
+ Class::MOP::load_class($schema) if $schema;
+ Class::MOP::load_class($source_class);
+
my $meta = eval { Class::MOP::load_class($class) } ?
- $class->meta : $base->meta->create($class, superclasses =>[ $base ]);
- my $make_immutable = $self->make_classes_immutable || $meta->is_immutable;
- $meta->make_mutable if $meta->is_immutable;
+ $class->meta : $base->meta->create($class, superclasses => [ $base ]);
#create the domain model
- unless( $dm_name ){
- ($dm_name) = ($source =~ /::([\w_\-]+)$/); #XXX be smarter at some point
- $dm_name =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
- $dm_name = "_" . lc($dm_name) . "_store";
- }
+ $dm_name ||= $self->dm_name_from_source_name($source_name);
- $dm_opts->{isa} = $source;
+ $dm_opts->{isa} = $source_class;
$dm_opts->{is} ||= 'rw';
$dm_opts->{required} ||= 1;
- my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts);
- #Inflate the row into an IM object directly from DBIC
- if( $inflate ){
+ my $make_immutable = $meta->is_immutable;
+ $meta->make_mutable if $meta->is_immutable;
+
+ my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts);
+ my $dm_reader = $dm_attr->get_read_method;
+
+ unless( $class->can('inflate_result') ){
my $inflate_method = sub {
my $class = shift; my ($src) = @_;
$src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle');
$meta->add_method('inflate_result', $inflate_method);
}
- #attribute reflection
- my $reflect_attrs = delete $opts{reflect_attributes};
- my %exclude_attrs =
- map {$_ => 1} ref $opts{exclude_attributes} ? @{$opts{exclude_attributes}} : ();
-
- #reflect all applicable attributes on undef
- $reflect_attrs = [map {$_->name} $source->meta->compute_all_applicable_attributes]
- unless ref $reflect_attrs;
- @$reflect_attrs = grep { !$exclude_attrs{$_} } @$reflect_attrs;
-
- for my $attr_name (@$reflect_attrs){
- $self->reflect_submodel_attribute(
- class => $class,
- attribute_name => $attr_name,
- domain_model_name => $dm_name
- );
+ #XXX this is here to allow action prototypes to work with ListView
+ # maybe Collections hsould have this kind of thing too to allow you to reconstruct them?
+ #i like the possibility to be honest... as aset of key/value pairs they could be URId
+ #XXX move to using 'handles' for this?
+ $meta->add_method('__id', sub {shift->$dm_reader->id} )
+ unless $class->can('__id');
+ #XXX this one is for ActionForm, ChooseOne and ChooseMany need this shit
+ $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} )
+ unless $class->can('__ident_condition');
+
+ #XXX this is just a disaster
+ $meta->add_method('display_name', sub {shift->$dm_reader->display_name} )
+ if( $source_class->can('display_name') && !$class->can('display_name'));
+
+ #XXX as a default pass the domain model as a target_model until i come up with something
+ #better through the coercion method
+ my $def_act_args = sub {
+ my $super = shift;
+ confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
+ return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } };
+ };
+ $meta->add_around_method_modifier('_default_action_args_for', $def_act_args);
+
+ {
+ # attributes => undef, #default to qr/./
+ # attributes => [], #default to nothing
+ # attributes => qr//, #DWIM, treated as [qr//]
+ # attributes => [{...}] #DWIM, treat as [qr/./, {...} ]
+ # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
+ my $attr_haystack =
+ [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ];
+
+ if(!defined $attr_rules){
+ $attr_rules = [qr/./];
+ } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
+ $attr_rules = [ $attr_rules ];
+ } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
+ #don't add a qr/./ rule if we have at least one match rule
+ push(@$attr_rules, qr/./) unless
+ grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
+ || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules;
+ }
+
+ my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
+ for my $attr_name (keys %$attributes){
+ $self->reflect_source_object_attribute(
+ class => $class,
+ source_class => $source_class,
+ parent_class => $parent,
+ attribute_name => $attr_name,
+ domain_model_name => $dm_name,
+ %{ $attributes->{$attr_name} || {}},
+ );
+ }
}
- for my $action (@$actions){
- unless (ref $action){
- my $default = grep {$_->{name} eq $action} @{ $self->default_object_actions };
- confess("unable to reflect action $action") unless $default;
- $action = $default;
+ {
+ my $all_actions = $self->_all_object_actions;
+ my $action_haystack = [keys %$all_actions];
+ if(!defined $action_rules){
+ $action_rules = $self->default_object_actions;
+ } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){
+ $action_rules = [ $action_rules ];
+ } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){
+ #don't add a qr/./ rule if we have at least one match rule
+ push(@$action_rules, qr/./)
+ unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
+ || !ref $_ || ref $_ eq 'Regexp'} @$action_rules;
+ }
+
+ # XXX this is kind of a dirty hack to support custom actions that are not
+ # previously defined and still be able to use the parse_reflect_rules mechanism
+ my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] }
+ grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules;
+ push(@$action_haystack, @custom_actions);
+ my $actions = $self->parse_reflect_rules($action_rules, $action_haystack);
+ for my $action (keys %$actions){
+ my $action_opts = $self->merge_hashes
+ ($all_actions->{$action} || {}, $actions->{$action} || {});
+ $self->reflect_source_action(
+ name => $action,
+ object_class => $class,
+ source_class => $source_class,
+ %$action_opts,
+ );
+
+ # XXX i will move this to use the coercion method soon. this will be
+ # GoodEnough until then. I still need to think a little about the type coercion
+ # thing so i don't make a mess of it
+ my $act_args = sub { #override target model for this action
+ my $super = shift;
+ confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader);
+ return { %{ $super->(@_) },
+ ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) };
+ };
+ $meta->add_around_method_modifier('_default_action_args_for', $act_args);
}
- $self->reflect_submodel_action(submodel_class => $class, %$action);
- my $dm = $dm_attr->get_read_method;
- my $act_args = sub { #override target model for this action
- my $super = shift;
- return { %{ $super->(@_) },
- ($_[1] eq $action->{name} ? (target_model => $_[0]->$dm) : () ) };
- };
- $meta->add_around_method_modifier('_default_action_args_for', $act_args);
}
$meta->make_immutable if $make_immutable;
};
# needs class, attribute_name domain_model_name
- implements reflect_submodel_attribute => as {
+ implements reflect_source_object_attribute => as {
my ($self, %opts) = @_;
+ unless( $opts{attribute_name} && $opts{class} && $opts{parent_class}
+ && ( $opts{source_class} || $opts{domain_model_name} ) ){
+ confess( "Error: class, parent_class, attribute_name, and either " .
+ "domain_model_name or source_class are required parameters" );
+ }
+
my $meta = $opts{class}->meta;
- my $attr_opts = $self->parameters_for_submodel_attr(%opts);
+ my $attr_opts = $self->parameters_for_source_object_attribute(%opts);
my $make_immutable = $meta->is_immutable;
$meta->make_mutable if $meta->is_immutable;
+
my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts);
- $meta->make_immutable if $make_immutable;
+ $meta->make_immutable if $make_immutable;
return $attr;
};
# needs class, attribute_name domain_model_name
- implements parameters_for_submodel_attr => as {
+ implements parameters_for_source_object_attribute => as {
my ($self, %opts) = @_;
- my $attr_name = $opts{attribute_name};
- my $dm_name = $opts{domain_model_name};
- my $domain = $opts{domain_model_class};
- $domain ||= $opts{class}->meta->find_attribute_by_name($dm_name)->_isa_metadata;
- my $from_attr = $domain->meta->find_attribute_by_name($attr_name);
- my $source = $domain->result_source_instance;
+ my $class = delete $opts{class};
+ my $attr_name = delete $opts{attribute_name};
+ my $dm_name = delete $opts{domain_model_name};
+ my $source_class = delete $opts{source_class};
+ my $parent_class = delete $opts{parent_class};
+ confess("parent_class is a required argument") unless $parent_class;
+ confess("You must supply at least one of domain_model_name and source_class")
+ unless $dm_name || $source_class;
+
+ my $source;
+ $source = $source_class->result_source_instance if $source_class;
+ #puke! dwimery
+ if( !$source_class ){
+ my $dm = $class->meta->find_attribute_by_name($dm_name);
+ $source_class = $dm->_isa_metadata;
+ $source = $source_class->result_source_instance;
+ } elsif( !$dm_name ){
+ ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class}
+ $class->meta->domain_models;
+ if( !$dm_name ){ #last resort guess
+ my $tentative = $self->dm_name_from_source_name($source->source_name);
+ ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models;
+ }
+ }
+
+ my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
#default options. lazy build but no outsider method
my %attr_opts = ( is => 'ro', lazy => 1, required => 1,
if( my $rel_info = $source->relationship_info($attr_name) ){
my $rel_accessor = $rel_info->{attrs}->{accessor};
- my $rel_moniker = $rel_info->{class}->source_name;
+ my $rel_moniker = $rel_info->{class}->result_source_instance->source_name;
if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) {
#has_many
- my $sm = $self->submodel_classname_from_source_name($rel_moniker);
+ my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
#type constraint is a collection, and default builds it
- $attr_opts{isa} = $self->classname_for_collection_of($sm);
+ $attr_opts{isa} = $self->class_name_for_collection_of($sm);
$attr_opts{default} = sub {
my $rs = shift->$dm_name->related_resultset($attr_name);
return $attr_opts{isa}->new(_source_resultset => $rs);
} elsif( $rel_accessor eq 'single') {
#belongs_to
#type constraint is the foreign IM object, default inflates it
- $attr_opts{isa} = $self->submodel_classname_from_source_name($rel_moniker);
+ $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
$attr_opts{default} = sub {
shift->$dm_name
->find_related($attr_name, {},{result_class => $attr_opts{isa}});
};
}
- } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
+ } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
#m2m magic
my $mm_name = $1;
my $link_table = "links_to_${mm_name}_list";
|| confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
." traversing many-many for ${mm_name}_list";
- my $sm = $self->submodel_classname_from_source_name($far_side->source_name);
- $attr_opts{isa} = $self->classname_for_collection_of($sm);
+ my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
+ $attr_opts{isa} = $self->class_name_for_collection_of($sm);
#proper collections will remove the result_class uglyness.
$attr_opts{default} = sub {
};
- #XXX change superclasses to "base" ?
- implements reflect_submodel_action => as{
+ implements reflect_source_action => as{
my($self, %opts) = @_;
- my $im_class = delete $opts{submodel_class};
- my $base = delete $opts{base} || Action;
- my $attrs = delete $opts{attributes};
- my $name = delete $opts{name};
- my $class = delete $opts{class} || $im_class->_default_action_class_for($name);
+ my $name = delete $opts{name};
+ my $class = delete $opts{class};
+ my $base = delete $opts{base} || Action;
+ my $object = delete $opts{object_class};
+ my $source = delete $opts{source_class};
+
+ confess("name, object_class and source_class are required arguments")
+ unless $source && $name && $object;
+
+ my $attr_rules = delete $opts{attributes};
+ $class ||= $object->_default_action_class_for($name);
+
+ Class::MOP::load_class( $base );
+ Class::MOP::load_class( $object );
+ Class::MOP::load_class( $source );
+
+ #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n";
+ # attributes => undef, #default to qr/./
+ # attributes => [], #default to nothing
+ # attributes => qr//, #DWIM, treated as [qr//]
+ # attributes => [{...}] #DWIM, treat as [qr/./, {...} ]
+ # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]]
+ my $attr_haystack = [ map {$_->name} $object->meta->parameter_attributes ];
+ if(!defined $attr_rules){
+ $attr_rules = [qr/./];
+ } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){
+ $attr_rules = [ $attr_rules ];
+ } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){
+ #don't add a qr/./ rule if we have at least one match rule
+ push(@$attr_rules, qr/./) unless
+ grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude')
+ || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules;
+ }
- print STDERR "... Reflecting action $name for $im_class as $class\n"
- if $self->debug_mode;
+ #print STDERR "${name}\t${class}\t${base}\n";
+ #print STDERR "\t${object}\t${source}\n";
+ #print STDERR "\t",@$attr_rules,"\n";
- Class::MOP::load_class($_) for($base, $im_class);
- $attrs = [ map{$_->name} $im_class->parameter_attributes] unless ref $attrs;
- my $im_meta = $im_class->meta;
+ my $o_meta = $object->meta;
+ my $s_meta = $source->meta;
+ my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack);
#create the class
my $meta = eval { Class::MOP::load_class($class) } ?
$class->meta : $base->meta->create($class, superclasses => [$base]);
- my $make_immutable = $self->make_classes_immutable || $meta->is_immutable;
+ my $make_immutable = $meta->is_immutable;
$meta->make_mutable if $meta->is_immutable;
- foreach my $attr_name (@$attrs){
- my $im_attr = $im_meta->find_attribute_by_name($attr_name);
- my $dm_attr = $im_meta->find_attribute_by_name($im_attr->domain_model);
- my $dm_meta = $dm_attr->_isa_metadata->meta;
- my $from_attr = $dm_meta->find_attribute_by_name($im_attr->orig_attr_name);
-
- #Don't reflect read-only attributes to actions
- unless( $from_attr->get_write_method ) {
- print STDERR "..... not relecting read-only attribute ${attr_name} to ${class}"
- if $self->debug_mode;
- next;
- }
-
- my $attr_params = $self->parameters_for_submodel_action_attribute
- ( submodel_class => $im_class, attribute_name => $attr_name );
-
- #add the attribute to the class
+ for my $attr_name (keys %$attributes){
+ my $attr_opts = $attributes->{$attr_name} || {};
+ my $o_attr = $o_meta->find_attribute_by_name($attr_name);
+ my $s_attr_name = $o_attr->orig_attr_name || $attr_name;
+ my $s_attr = $s_meta->find_attribute_by_name($s_attr_name);
+ next unless $s_attr->get_write_method; #only rw attributes!
+
+ my $attr_params = $self->parameters_for_source_object_action_attribute
+ (
+ object_class => $object,
+ source_class => $source,
+ attribute_name => $attr_name
+ );
$meta->add_attribute( $attr_name => %$attr_params);
}
return $meta;
};
-
- implements parameters_for_submodel_action_attribute => as {
+ implements parameters_for_source_object_action_attribute => as {
my ($self, %opts) = @_;
- #XXX we need the domain model name so we can do valid_values correcty....
- #otherwise we could do away with submodel_class and use domain_model_class instead
- #we need for domain_model to be set on the attr which we may not be sure of
- my $submodel = delete $opts{submodel_class};
- my $sm_meta = $submodel->meta;
- my $attr_name = delete $opts{attribute_name};
- my $dm_name = $sm_meta->find_attribute_by_name($attr_name)->domain_model;
- my $domain = $sm_meta->find_attribute_by_name($dm_name)->_isa_metadata;
- my $from_attr = $domain->meta->find_attribute_by_name($attr_name);
- my $source = $domain->result_source_instance;
+ my $object = delete $opts{object_class};
+ my $attr_name = delete $opts{attribute_name};
+ my $source_class = delete $opts{source_class};
+ confess("object_class and attribute_name are required parameters")
+ unless $attr_name && $object;
+
+ my $o_meta = $object->meta;
+ my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model;
+ $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata;
+ my $from_attr = $source_class->meta->find_attribute_by_name($attr_name);
confess("${attr_name} is not writeable and can not be reflected")
unless $from_attr->get_write_method;
$from_attr->type_constraint->name eq 'ArrayRef' ||
$from_attr->type_constraint->is_subtype_of('ArrayRef');
+ my $source = $source_class->result_source_instance;
if (my $rel_info = $source->relationship_info($attr_name)) {
my $rel_accessor = $rel_info->{attrs}->{accessor};
$attr_opts{default} = sub { [] };
$attr_opts{valid_values} = sub {
- shift->$dm_name->result_source->related_source($link_table)
+ shift->target_model->result_source->related_source($link_table)
->related_source($mm_name)->resultset;
};
}
+ #use Data::Dumper;
+ #print STDERR Dumper(\%attr_opts);
return \%attr_opts;
};
};
1;
-
-
-=head1 NAME
-
-Reaction::InterfaceModel::Reflector::DBIC - Autogenerate an Interface Model from
-a DBIx::Class Schema.
-
-=head1 DESCRIPTION
-
-This class will reflect a L<DBIx::Class::Schema> to a C<Reaction::InterfaceModel::Object>.
-It can aid you in creating interface models, collections, and associated actions rooted
-in DBIC storage.
-
-=head1 SYNOPSYS
-
- #model_class is the namespace where our reflected interface model will be created
- my $reflector = Reaction::InterfaceModel::Reflector::DBIC
- ->new(model_class => 'RTest::TestIM');
-
- #Example 1: Reflect all submodels (result sources / tables)
- #domain_model_class ISA DBIx::Class::Schema
- $reflector->reflect_model(domain_model_class => 'RTest::TestDB');
- #the '_RTest_TestDB' attribute is created automatically to store the domain model
- RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) );
-
- #Example 2: Don't reflect the FooBaz submodel
- $reflector->reflect_model(
- domain_model_class => 'RTest::TestDB',
- exclude_submodels => ['FooBaz'],
- );
- RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) );
-
- #Example 3: Only reflect Foo, Bar, and Baz
- $reflector->reflect_model(
- domain_model_class => 'RTest::TestDB',
- reflect_submodels => [qw/Foo Bar Baz/],
- );
- RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) );
-
- #Example 4: Explicit domain_model_name
- $reflector->reflect_model(
- domain_model_class => 'RTest::TestDB',
- domain_model_name => '_rtest_testdb',
- );
- RTest::TestIM->new(_rtest_testdb => RTest::TestDB->connect(...) );
-
-=head1 A NOTE ABOUT REFLECTION
-
-This class is meant as an aid in rapid prototyping and CRUD functionality creation.
-While parts of it should be useful for projects of any size, any non-trivial
-application will likely require some hand-coding or tweaking to get the most out of
-this tool. Reflection, like CRUD, is not a magic bullet. It's just a way to help you
-eliminate repetitive and unnecessary coding.
-
-=head1 OVERVIEW & DEFAULT NAMING CONVENTIONS
-
-By default (you can override this behavior later), The top-level model (the one
-corresponding to your schema) will be reflected to the class name you provide at
-instantiation, submodels to the model name plus the name of the source, and collections
-to the name of the submodel plus "Collection". Action names, if not specified directly
-will be determined by using the submodel's "_action_name_for" method.
-
-=head2 A Note about Immutable
-
-The methods that modify classes will check for class immutability and unlock classes
-for modification if they are immutable. Classes will be locked again after they are
-modified if they were locked at the start.
-
-=head1 ATTRIBUTES
-
-=head2 model_class
-
-Required, Read-only. This is the name of the class where your top model will be created
-and the namespace under which all your submodels, actions, collections will be
-created.
-
-=head2 make_classes_immutable
-
-Read-Write boolean, defaults to false. If this is set to true, after classes are
-created they will be made immutable.
-
-=head2 default_object_actions
-
-=head2 default_collection_actions
-
-These hold an ArrayRef of action prototypes. An Action prototype is a hashref
-with at least 2 keys, "name" and "base" the latter which is an otional superclass
-for this action. By default a "Create" action is reflected for Collections and
-"Update" and "Delete" actions for IM Objects. You may add here any
-attribute that reflect_submodel_action takes, i.e. for an action that doesn't need
-any reflected attributes, like Delete, use C<attributes =E<gt> []>.
-
-=head2 debug_mode
-
-Read-Write boolean, defaults to false. In the future this will provide valuable
-information at runtime, however that has not yet been implemented.
-
-=head1 METHODS
-
-=head2 submodel_classname_from_source_name $source_name
-
-Generate the classname for a submodel from the result source's name.
-
-=head2 classname_for_collection_for $object_class
-
-Returns the classname for a collection of a certain submodel. Currently it just appends
-"::Collection"
-
-=head2 reflect_model %args
-
-=over 4
-
-=item C<domain_model_class> - Required, this is the classname of your Schema
-
-=item C<domain_model_name> - The name to use when creating the domain model attribute
-If you don't supply this one will automatically be generated by prefacing the domain_model_class
-with an underscore and replacing all instances of "::", with "_"
-
-=item C<domain_model_args> - Any other optional arguments suitable for passing to C<add_attribute>
-
-=item C<reflect_submodels> - An ArrayRef of the source names of the submodels to reflect.
-If the value is not a reference it will attempt to reflect all sources. In the future
-there may be regex support
-
-=item C<exclude_submodels> - ArrayRef of submodels to exclude from reflection. In the
-future there may be regex support
-
-=back
-
-This method will query the schema given to it and reflect all appropriate submodels as
-well as calling C<add_submodel_to_model> to create an attribute in the reflected model
-which returns an appropriate collection.
-
-=head2 add_submodel_to_model %args
-
-=over 4
-
-=item C<source_name> - The DBIC source name for this submodel
-
-=item C<collection_class> - The classname for the collection type for this submodel.
-
-=item C<attribute_name> - The name of the attribute to create in the model to represent
-this submodel. If one is not supplied the source name will be used.
-
-=item C<domain_model_name> - The attribute name of the domain model where the schema is
-located. In the future this may be optional since it can be detected, but it needs to
-wait until some changes are made to the attribute metaclasses.
-
-=item C<reader> - The read method for the submodel attribute. If one is not provided,
-a lower case version of the source name with underscores separating previous cases
-of a camel-case word change and "_collection" appended will be used. Examples:
-"FooBar" becomes C<foo_bar_collection> and "Foo" becomes C<foo_collection>.
-
-=back
-
-This will create a read-only attribute in your main model that will return a
-collection of the submodel type when the reader is called. This will return the same
-collection every time, not a fresh one. This may change in the future, but I really
-see no need for it right now.
-
-=head2 reflect_collection_for \%args
-
-=over 4
-
-=item C<object_class> - Required. The class ob objects this collection will be representing
-
-=item C<base> - Optional, if you'd like to use a different base for the Collection other
-than L<Reaction::InterfaceModel::Collection::Virtual::ResultSet> you can set it here
-
-=item C<reflect_actions> - Action prototypes for the actions you wish to reflect for
-this collection. If nothing is specified then C<default_collection_actions> is used.
-An Action prototype is a hashref with at least 2 keys, "name" and "base" the latter
-is the superclass for this action. Using an empty array reference would reflect nothing.
-
-=item C<class> - The desired classname for this collection. If none is provided, then
-the value returned by C<classname_for_collection_of> is used.
-
-=back
-
-This method will create a new collection class that inherits from C<base> and overrides
-C<_build_im_class> to return C<object_class>. Additionally it will automatically
-override C<_default_action_args_for> as needed for reflected actions.
-
-=head2 reflect_submodel \%args
-
-=over 4
-
-=item C<domain_model_class> - The class from which the submodel will be created, or your
-source class, e.g. MyApp::Schema::Foo
-
-=item C<base> - Optional, if you'd like to use a different base other than
-L<Reaction::InterfaceModel::Object>
-
-=item C<domain_model_name> - the name to use for your domain model attribute. If one
-is not provided, a lower case version of the source name begining with an underscore
-and with underscores separating previous cases of a camel-case word change and
-"_store" appended will be used.
-Examples: "FooBar" becomes C<_foo_bar_store> and "Foo" becomes C<_foo_store>.
-
-=item C<domain_model_args> - Any additional arguments you may want to pass to the domain
-model when it is created e.g. C<handles>
-
-=item C<inflate> - unless this is set to zero an inflate_result method will be created.
-
-=item C<class> - the name of the submodel class created, if you don't specify it the
-value returned by C<submodel_classname_from_source_name> will be used
-
-=item C<reflect_actions> - Action prototypes for the actions you wish to reflect for
-this collection. If nothing is specified then C<default_object_actions> is used.
-An Action prototype is a hashref with at least 2 keys, "name" and "base" the latter
-is the superclass for this action. Using an empty array reference would reflect nothing.
-
-=item C<reflect_attributes> - an arrayref of the names of the attributes you want to
-reflect, if this is not an arrayref it will attempt to reflect all attributes,
-if you wish to not reflect anything pass it an empty arrayref
-
-=item C<exclude_attributes> - an arrayref of the names of the attributes to exclude.
-
-=back
-
-This method will create the submodel class, copy the applicable attributes and create
-the appropriate domain model attribute as well as create the necessary actions and
-perform the necessary overrides to C<_default_action_args_for>
-
-=head2 reflect_submodel_attribute \%args
-
-Takes the same arguments as C<parameters_for_submodel_attribute>.
-
-Reflect this attribute and add it to the submodel class.
-
-=head2 parameters_for_submodel_attribute \%args
-
-=over 4
-
-=item C<class> - the submodel class
-
-=item C<attribute_name> - the name of the attribute you want to reflect
-
-=item C<domain_model_class> - the class where we are copying the attribute from.
-If not specified, the type constraint on the domain model attribute will be used
-
-=item C<domain_model_name> - the name of the domain model attribute.
-
-=back
-
-This method determines the parameters necessary for reflecting the argument. Most
-of the magic here is so that relations can be accurately reflected so that many-to-one
-relationships can return submodel objects and one-to-many and many-to-many
-relationships can return collections. By default all reflected attributes will be built
-lazily from their parent domain model.
-
-=head2 reflect_submodel_action \%args
-
-=over 4
-
-=item C<submodel_class> - the submodel class this action will be associated with
-
-=item C<base> - superclass for the action class created
-
-=item C<attributes> - a list of the names of attributes to mirror from the submodel.
-A blank list signifies nothing, and a non list value will cause it to reflect all
-writeable parameter attributes from the submodel.
-
-=item C<name> - the name of the action, required.
-
-=item C<class> - optional, the name of the action class. By default it will query the
-submodel class through the method C<_default_action_class_for>
-
-=back
-
-Create an action class that acts on the submodel from a base class. This is most useful
-for CRUD and similar actions.
-
-=head2 parameters_for_submodel_action_attribute \ %args
-
-=over 4
-
-=item C<attribute_name> - name of the attribute being reflected
-
-=item C<submodel_class> - the submodel where this attribute is located
-
-=back
-
-Create the correct parameters for the attribute being created in the action, including
-valid_values, and correct handling of relationships and defaults.
-
-=head1 PRIVATE METHODS
-
-=head2 BUILD
-
-Load the C<model_class> if it exists or create one if it does not.
-
-=head1 TODO
-
-Allow reflect_* and exclude_* methods to take compiled regular expressions, tidy up
-argument names and method names, mace docs decent, make more tests, try to figure out
-more through introspection to require less arguments, proper checking of values passed
-and throwing of errors when garbage is passed in.
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual - The Index of The Manual
-
-=head1 DESCRIPTON
-
-Reaction is basically an extended MVC framework built upon L<Catalyst>.
-
-=head1 SECTIONS
-
-=head2 L<Reaction::Manual::Intro>
-
-=head2 L<Reaction::Manual::Example>
-
-=head2 L<Reaction::Manual::Cookbook>
-
-=head2 L<Reaction::Manual::Internals>
-
-=head2 L<Reaction::Manual::FAQ>
-
-=head1 SEE ALSO
-
-=over
-
-=item * L<Catalyst::Manual>
-
-=item * L<DBIx::Class::Manual>
-
-=item * L<Moose>
-
-=item * L<Template::Toolkit>
-
-=back
-
-=head1 SUPPORT
-
-IRC: Join #reaction on irc.perl.org
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual::Cookbook - Miscellaneous recipes
-
-=head1 RECIPES
-
-These should include some hopefully useful tips and tricks!
-
-=head2 Display
-
-These would typically go in your /root directory along with your other
-templates.
-
-=head3 Alternating listview row styles with CSS
-
-Filename: listview
-
- [%
-
- PROCESS base/listview;
-
- row_block = 'listview_row_fancy';
-
- BLOCK listview_row_fancy;
-
- IF loop.count % 2 == 1;
- attrs.class = 'dark';
- ELSE;
- attrs.class = 'light';
- END;
-
- INCLUDE listview_row;
-
- END;
-
- %]
-
-=head3 Displaying heading on action forms
-
-Filename: form_base
-
- [%
-
- PROCESS base/form_base;
-
- main_block = 'form_base_control_fancy';
-
- BLOCK form_base_control_fancy;
-
- action_class = self.action.meta.name.split('::').pop;
- '<h3>'; action_class.split('(?=[A-Z])').join(' '); '</h3>';
- INCLUDE form_base_control;
-
- END;
-
- %]
-
-=head2 Controllers
-
-Things
-
-=head2 Models
-
-Stuff
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual::Example - Simple Reaction example
-
-=head1 DESCRIPTION
-
-This tutorial will guide you through the process of setting up and testing a
-very basic CRUD application based on the database from
-L<DBIx::Class::Manual::Example>.
-
-You need at least a fairly basic understanding of L<DBIx::Class::Schema> for
-this example to have value for you.
-
-=head2 Installation
-
-Install L<DBIx::Class> via CPAN.
-
-Install Reaction from http://code2.0beta.co.uk/reaction/svn via SVN or SVK.
-
-Set up the database as mentioned in L<DBIx::Class::Manual::Example>. Don't do
-any of the DBIx::Class related stuff, only the SQLite database.
-
-=head2 Create the application
-
- catalyst.pl Test::Reaction
- cd Test-Reaction
- script/test_reaction_create.pl Model Test::Reaction DBIC::Schema Test::Reaction::DB
-
-Also, remember to include Catalyst::Plugin::I18N in your plugin list, like
-this:
-
- use Catalyst qw/-Debug ConfigLoader Static::Simple I18N/;
-
-=head2 Set up DBIx::Class::Schema
-
-In addition to the normal DBIC stuff, you need to moosify your DBIC classes.
-
-Change directory back from db to the directory app:
-
- cd lib/Test/Reaction
- mkdir DB
-
-Then, create the following DBIx::Class::Schema classes:
-
-DB.pm:
-
- package Test::Reaction::DB;
-
- use base 'DBIx::Class::Schema';
-
- __PACKAGE__->load_classes;
-
- 1;
-
-DB/Artist.pm:
-
- package Test::Reaction::DB::Artist;
-
- use base 'DBIx::Class';
- use Reaction::Class;
-
- has 'artistid' => ( isa => 'Int', is => 'ro', required => 1 );
- has 'name' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 );
-
- sub display_name {
- my $self = shift;
- return $self->name;
- }
-
- __PACKAGE__->load_components(qw/PK::Auto Core/);
- __PACKAGE__->table('artist');
- __PACKAGE__->add_columns(qw/ artistid name /);
- __PACKAGE__->set_primary_key('artistid');
- __PACKAGE__->has_many( 'cds' => 'Test::Reaction::DB::Cd' );
-
- 1;
-
-DB/Cd.pm:
-
- package Test::Reaction::DB::Cd;
-
- use base 'DBIx::Class';
- use Reaction::Class;
-
- has 'cdid' => ( isa => 'Int', is => 'ro', required => 1 );
- has 'artist' =>
- ( isa => 'Test::Reaction::DB::Artist', is => 'rw', required => 1 );
- has 'title' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 );
-
- sub display_name {
- my $self = shift;
- return $self->title;
- }
-
- __PACKAGE__->load_components(qw/PK::Auto Core/);
- __PACKAGE__->table('cd');
- __PACKAGE__->add_columns(qw/ cdid artist title/);
- __PACKAGE__->set_primary_key('cdid');
- __PACKAGE__->belongs_to( 'artist' => 'Test::Reaction::DB::Artist' );
- __PACKAGE__->has_many( 'tracks' => 'Test::Reaction::DB::Track' );
-
- 1;
-
-DB/Track.pm:
-
- package Test::Reaction::DB::Track;
-
- use base 'DBIx::Class';
- use Reaction::Class;
-
- has 'trackid' => ( isa => 'Int', is => 'ro', required => 1 );
- has 'cd' => ( isa => 'Test::Reaction::DB::Cd', is => 'rw', required => 1 );
- has 'title' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 );
-
- __PACKAGE__->load_components(qw/PK::Auto Core/);
- __PACKAGE__->table('track');
- __PACKAGE__->add_columns(qw/ trackid cd title/);
- __PACKAGE__->set_primary_key('trackid');
- __PACKAGE__->belongs_to( 'cd' => 'Test::Reaction::DB::Cd' );
-
- 1;
-
-=head3 Reaction attributes
-
-See L<Reaction::Types::Core>
-
-=head3 The rest
-
-Reaction will use I<sub display_name> for displaying when there is a 1:Many or
-Many:Many relation. It will return a suitable text representation.
-
-=head2 Models
-
-=head3 Create Test::Reaction::Model::Action
-
-Still in lib/Test/Reaction, create
-
-Model/Action.pm:
-
- package Test::Reaction::Model::Action;
-
- use Reaction::Class;
-
- use Test::Reaction::DB;
-
- use aliased 'Reaction::InterfaceModel::Action::DBIC::ActionReflector';
-
- my $r = ActionReflector->new;
-
- $r->reflect_actions_for( 'Test::Reaction::DB::Artist' => __PACKAGE__ );
- $r->reflect_actions_for( 'Test::Reaction::DB::Cd' => __PACKAGE__ );
- $r->reflect_actions_for( 'Test::Reaction::DB::Track' => __PACKAGE__ );
-
- 1;
-
-=head2 Controllers
-
-Reaction controllers inherit from Reaction::UI::CRUDController, like this:
-
-Controller/Artist.pm
-
- package Test::Reaction::Controller::Artist;
-
- use strict;
- use warnings;
- use base 'Reaction::UI::CRUDController';
- use Reaction::Class;
-
- __PACKAGE__->config(
- model_base => 'Test::Reaction',
- model_name => 'Artist',
- action => { base => { Chained => '/base', PathPart => 'artist' } }
- );
-
- 1;
-
-Controller/Cd.pm
-
- package Test::Reaction::Controller::Cd;
-
- use strict;
- use warnings;
- use base 'Reaction::UI::CRUDController';
- use Reaction::Class;
-
- __PACKAGE__->config(
- model_base => 'Test::Reaction',
- model_name => 'Cd',
- action => { base => { Chained => '/base', PathPart => 'cd' } }
- );
-
- 1;
-
-Controller/Track.pm
-
- package Test::Reaction::Controller::Track;
-
- use strict;
- use warnings;
- use base 'Reaction::UI::CRUDController';
- use Reaction::Class;
-
- __PACKAGE__->config(
- model_base => 'Test::Reaction',
- model_name => 'Track',
- action => { base => { Chained => '/base', PathPart => 'track' } }
- );
-
- 1;
-
-Finally, change Controller/Root.pm to
-
- package Test::Reaction::Controller::Root;
-
- use strict;
- use warnings;
- use base 'Reaction::UI::RootController';
- use Reaction::Class;
-
- use aliased 'Reaction::UI::ViewPort';
- use aliased 'Reaction::UI::ViewPort::ListView';
- use aliased 'Reaction::UI::ViewPort::ActionForm';
-
- __PACKAGE__->config->{namespace} = '';
-
- sub base :Chained('/') :PathPart('') :CaptureArgs(0) {
- my ($self, $c) = @_;
-
- $self->push_viewport(ViewPort, layout => 'xhtml');
- }
-
- sub root :Chained('base') :PathPart('') :Args(0) {
- my ($self, $c) = @_;
-
- $self->push_viewport(ViewPort, layout => 'index');
- }
-
- 1;
-
-=head2 View
-
-View/XHTML.pm looks like this
-
- package Test::Reaction::View::XHTML;
-
- use Reaction::Class;
-
- extends 'Reaction::UI::Renderer::XHTML';
-
- 1;
-
-This is all the perly stuff. Now return to the base Test-Reaction directory and
-create root/index:
-
- [%
-
- main_block = 'index';
-
- BLOCK index;
-
- %]<p><a href="[% ctx.uri_for('/artist') %]">artist</a></p>
- <p><a href="[% ctx.uri_for('/cd') %]">cd</a></p>
- <p><a href="[% ctx.uri_for('/track') %]">track</a></p>[%
-
- END;
-
- %]
-
-=head2 Running
-
-Now all that remains is to tell catalyst about the root and the model. Let
-test_reaction.yml look like this:
-
- ---
- name: Test::Reaction
- Controller::Root:
- view_name: 'XHTML'
- window_title: 'Reaction Test App'
- Model::Test::Reaction:
- schema_class: 'Test::Reaction::DB'
- connect_info:
- - 'dbi:SQLite:dbname=database/example.db'
-
-The finals step for this example is to link to Reaction's templates:
-
- ln -s <path to reaction install directory>/root/base/ root/base
-
-At last you're now ready to run the server
-
- script/test_reaction_server.pl
-
-=head1 Notes
-
-=head1 TODO
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual::FAQ
-
-=head2 INTRODUCTION
-
-=head3 What is Reaction?
-
-Reaction is an MVCish framework that is designed with two goals in mind:
-"don't repeat yourself" and "components rule."
-
-=head3 How is it different from other MVC frameworks?
-
-Reaction is more flexible and abstract. Web development is only a specialized
-set of what Reaction is designed to provide - the inner classes are general
-enough to be used in many different environments and for solving non-web
-problems.
-
-It is planned to go a lot further than just the web - we want to develop GUIs
-and CLIs as easily and painlessly as possible, using Reaction. How about
-writing your web application and instantly getting a CLI to go with it? That's
-only part of the flexibility we have in mind.
-
-=head3 How is it different from Catalyst?
-
-Catalyst is MVC-based whereas Reaction splits the Model into 2 parts: The
-"Domain Model" and the "Interface Model." Web development is only a sample of
-what Reaction can do - but it already comes bundled with the basic components
-that you would have to program in Catalyst. At the moment, Reaction runs on
-Catalyst for web development.
-
-=head3 What's a Domain?
-
-A domain is the field where an abstraction makes sense. For example, to build
-a web site a programmer may come up with an abstraction of a User, Products,
-User roles, etc. These concepts are just one particular implementation of all
-the possible abstractions for that web site -- the set of all these possible
-abstractions make up the Domain.
-
-=head3 What's a Domain Model?
-
-A Domain Model is an actual computational model of an abstraction. In most
-cases these models are business-based, as in the set of objects that make up
-the representation for a particular domain, such as Users, Products, User
-Roles, etc.
-
-=head3 What's an Interface Model?
-
-A well defined model for the common operations involved in a particular mode
-of interaction with the domain. In other words, it's a layer around the Domain
-Model that provides interaction with it. One example would be an authorization
-procedure for different views of the same data, based on user's credentials.
-
-=head3 I'm lost! What does "Model" mean?
-
-The term "model" can mean two things: "model as in Computer Model" and "Model
-as in MVC". For this document, the former will be written as just "Model"
-whereas the latter will be referred to as "Model as in MVC."
-
-=head3 Haven't I seen these definitions elsewhere?
-Yes, similar terms have been used in Java-land and Smalltalk-ville. Note that
-for the sake of simplicity we are not giving rigorous (and more complex)
-definitions.
-
-=head3 What's a View?
-
-=head3 What's a Viewport?
-
-ListView and ActionForm are subclasses of ViewPort.
-
-=head3 What's a Focus Stack?
-
-=head3 What are Tangents?
-
-=head3 Can I have a pony?
-
-=head2 USING REACTION
-
-=head3 Where do I put my HTML?
-
-Packages involved
- ComponentUI
- ComponentUI::Controller::Bar
- ComponentUI::Controller::Baz
- ComponentUI::Controller::Foo
- ComponentUI::Controller::Root
- ComponentUI::Model::TestDB
- ComponentUI::Model::Action
- ComponentUI::View::XHTML
-
-CRUD
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual::Internals
-
-=head2 Hacking on Reaction
-
-=head3 What is a component?
-
-=head3 What component types are there?
-
-=head3 How do I create a new component?
-
-=head3 How does it work with a database?
-
-=head3 What about Moose?
-
-L<Moose>
-
-=head3 Type system
-
-=head3 What Perl modules should I be familiar with, in order to hack on Reaction's
-internals?
-
-=over
-
-=item L<Moose>
-
-A complete modern object system for Perl 5.
-
-=item L<aliased>
-
-Use shorter package names, i.e., "X::Y::Z" as "Z".
-
-=item L<Catalyst>
-
-The MVC application framework Reaction uses.
-
-=over
-
-=item * L<Catalyst::Controller::BindLex>
-
-=item * L<Catalyst::Model::DBIC::Schema>
-
-=item * L<Catalyst::Plugin::ConfigLoader>
-
-=item * L<Catalyst::Plugin::I18N>
-
-=item * L<Catalyst::Plugin::Static::Simple>
-
-=item * L<Catalyst::View::TT>
-
-=back
-
-=item TT
-
-Template Toolkit
-
-=item L<Config::General>
-
-Generic config file module.
-
-=item L<DBIx::Class>
-
-Object/Relational mapper.
-
-=item L<DateTime>
-
-=item L<DateTime::Format::MySQL>
-
-=item L<Digest::MD5>
-
-=item L<Email::MIME>
-
-=item L<Email::MIME::Creator>
-
-=item L<Email::Send>
-
-=item L<Email::Valid>
-
-=item L<SQL::Translator>
-
-=item L<Test::Class>
-
-=item L<Test::Memory::Cycle>
-
-=item L<Time::ParseDate>
-
-=back
-
-=head3 Packages involved
-
-=over
-
-=item L<Reaction::Class>
-
-Utility class, sets up to export a few methods that return parameters for use
-within Moose's C<has> (as new parameters) in other packages. It also C<use>s
-Moose itself.
-
-The methods it injects are:
-
-=over
-
-=item set_or_lazy_build($field_name)
-
-The attribute is required, if not provided beforehand the build_${name} method
-will be called on the object when the attribute's getter is first called. If
-the method does not exist, or returns undef, an error will be thrown.
-
-=item set_or_lazy_fail()
-
-The attribute is required, if not provided beforehand the 'lazy' parameter of
-Moose will make it fail.
-
-=item trigger_adopt()
-
-Calls adopt_${type} after the attribute value is set to $type.
-
-=item register_inc_entry()
-
-Will mark the calling package as already included, using %INC.
-
-=back
-
-=item Reaction::InterfaceModel::Action
-
-=item Reaction::InterfaceModel::Action::DBIC::ResultSet::Create;
-
-=item Reaction::InterfaceModel::Action::DBIC::ActionReflector;
-
-A method "adaptor" that creates the needed objects to support CRUD DBIC
-actions. In the future the code could be moved to a class higher in the
-hierarchy and only contain the operations to adapt.
-
-Sample run:
-
-Reaction::InterfaceModel::Action::DBIC::ActionReflector->reflect_actions_for(
-Reaction::InterfaceModel::Action::DBIC::ActionReflector=HASH(0x93cb2f0)
-RTest::TestDB::Foo
-ComponentUI::Model::Action
-)
-
-Generates and evaluates:
-
-package ComponentUI::Model::Action::DeleteFoo;
-use Reaction::Class;
-extends 'Reaction::InterfaceModel::Action::DBIC::Result::Delete';
-package ComponentUI::Model::Action::UpdateFoo;
-use Reaction::Class;
-extends 'Reaction::InterfaceModel::Action::DBIC::Result::Update';
-has 'baz_list' => (isa => 'ArrayRef', is => 'rw', set_or_lazy_fail('baz_list'), default => sub { [] }, valid_values => sub {
-$_[0]->target_model
-->result_source
-->related_source('links_to_baz_list')
-->related_source('baz')
-->resultset;
-});
-has 'last_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('last_name'));
-has 'first_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('first_name'));
-package ComponentUI::Model::Action::CreateFoo;
-use Reaction::Class;
-extends 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create';
-has 'baz_list' => (isa => 'ArrayRef', is => 'rw', set_or_lazy_fail('baz_list'), default => sub { [] }, valid_values => sub {
-$_[0]->target_model
-->result_source
-->related_source('links_to_baz_list')
-->related_source('baz')
-->resultset;
-});
-has 'last_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('last_name'));
-has 'first_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('first_name'));
-
-=item Reaction::InterfaceModel::Action::DBIC::Result::Delete
-
-=item Reaction::InterfaceModel::Action::DBIC::Result::Update
-
-=item Reaction::InterfaceModel::Action::DBIC::User::ResetPassword
-
-=item Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword
-
-=item Reaction::InterfaceModel::Action::DBIC::User::ChangePassword
-
-=item Reaction::InterfaceModel::Action::User::ResetPassword
-
-=item Reaction::InterfaceModel::Action::User::ChangePassword
-
-=item Reaction::InterfaceModel::Action::User::SetPassword
-
-=item Reaction::Meta::InterfaceModel::Action::ParameterAttribute
-
-=item Reaction::Meta::InterfaceModel::Action::Class
-
-=item Reaction::Types::Email
-
-=item Reaction::Types::Core
-
-=item Reaction::Types::DateTime
-
-=item Reaction::Types::File
-
-=item Reaction::Types::DBIC
-
-=item Reaction::UI::ViewPort::ListView
-
-=item Reaction::UI::ViewPort::Field::Text
-
-=item Reaction::UI::ViewPort::Field::ChooseMany
-
-=item Reaction::UI::ViewPort::Field::String
-
-=item Reaction::UI::ViewPort::Field::Number
-
-=item Reaction::UI::ViewPort::Field::HiddenArray
-
-=item Reaction::UI::ViewPort::Field::DateTime
-
-=item Reaction::UI::ViewPort::Field::File
-
-=item Reaction::UI::ViewPort::Field::ChooseOne
-
-=item Reaction::UI::ViewPort::Field::Password
-
-=item Reaction::UI::ViewPort::ActionForm
-
-=item Reaction::UI::ViewPort::Field
-
-=item Reaction::UI::FocusStack
-
-=item Reaction::UI::RootController
-
-=item Reaction::UI::Window
-
-=item Reaction::UI::Renderer::XHTML
-
-=item Reaction::UI::ViewPort
-
-=item Reaction::UI::CRUDController
-
-=item Reaction::UI::Controller
-
-=back
-
-=head3 Remarks about POD
-
-Don't use C<=over N>. POD assumes that the indent level is 4 if you leave
-it out. Most POD renderers ignore your indent level anyway.
-
-=head2 UNSORTED
-
-Packages involved
-
-t/lib/Rtest/TestDB*: TestDB DBIC declarations.
-t/lib/RTest/TestDB.pm: does DBIC populate for t/.
-t/lib/RTest/UI/ XXX
-
-Reaction::Test::WithDB;
-Reaction::Test;
-Reaction::Test::Mock::Context;
-Reaction::Test::Mock::Request;
-Reaction::Test::Mock::Response;
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
+++ /dev/null
-=head1 NAME
-
-Reaction::Manual::Intro - Introduction to Reaction
-
-=head1 INTRODUCTION
-
-Reaction is basically an extended MVC:
-
-=over
-
-=item Domain Model
-
-DBIC schema, etc.
-
-=item Interface Model
-
-Model::DBIC::Schema and Action classes.
-
-=item Controller
-
-Mediation and navigation.
-
-=item ViewPort
-
-View logic and event handling encapsulation.
-
-=item Renderer
-
-View:: classes, handed viewports.
-
-=back
-
-=head1 THE REACTION WAY
-
-The idea is you separate your domain model, which encapsulates the domain
-itself from your interface model, which is a model of how a particular app or
-class of apps interact with that domain and provides objects/methods to
-encapsulate the common operations it does.
-
-=head2 Basic usage
-
-XXX TODO
-
-=head1 SEE ALSO
-
-=over
-
-=item * L<Reaction::Manual::Cookbook>
-
-=item * L<Reaction::Manual::FAQ>
-
-=back
-
-=head1 AUTHORS
-
-See L<Reaction::Class> for authors.
-
-=head1 LICENSE
-
-See L<Reaction::Class> for the license.
-
-=cut
=head1 DESCRIPTION
-=over
+=over
=item * DBIx::Class::ResultSet
sub get_collection {
my ($self, $c) = @_;
+ #this sucks and should be fixed
return $c->model(join('::', $self->model_base, $self->model_name));
}
return $target->action_for($name, ctx => $c);
}
+ #can we please kill this already?
my $model_name = "Action::${name}".$self->model_name;
my $model = $c->model($model_name);
confess "no such Model $model_name" unless $model;
sub object :Chained('base') :PathPart('id') :CaptureArgs(1) {
my ($self, $c, $key) = @_;
- my $object :Stashed = $self->get_collection($c)
- ->find($key);
+ my $object :Stashed = $self->get_collection($c)->find($key);
confess "Object? what object?" unless $object; # should be a 404.
}
has action => (
isa => 'Reaction::InterfaceModel::Action', is => 'ro', required => 1
);
-
+
has field_names => (isa => 'ArrayRef', is => 'rw', lazy_build => 1);
-
+
has _field_map => (
isa => 'HashRef', is => 'rw', init_arg => 'fields',
predicate => '_has_field_map', set_or_lazy_build('field_map'),
);
-
+
has changed => (
isa => 'Int', is => 'rw', reader => 'is_changed', default => sub { 0 }
);
has next_action => (
isa => 'ArrayRef', is => 'rw', required => 0, predicate => 'has_next_action'
);
-
+
has on_apply_callback => (
isa => 'CodeRef', is => 'rw', required => 0,
predicate => 'has_on_apply_callback'
);
-
+
has ok_label => (
isa => 'Str', is => 'rw', required => 1, default => sub { 'ok' }
);
-
+
has apply_label => (
isa => 'Str', is => 'rw', required => 1, default => sub { 'apply' }
);
-
+
has close_label => (isa => 'Str', is => 'rw', lazy_fail => 1);
-
+
has close_label_close => (
isa => 'Str', is => 'rw', required => 1, default => sub { 'close' }
);
-
+
has close_label_cancel => (
isa => 'Str', is => 'rw', required => 1, default => sub { 'cancel' }
);
-
+
sub fields { shift->_field_map }
-
+
implements BUILD => as {
my ($self, $args) = @_;
unless ($self->_has_field_map) {
foreach my $attr ($action->parameter_attributes) {
push(@field_map, $self->build_fields_for($attr => $args));
}
-
+
my %field_map = @field_map;
my @field_names = @{ $self->sort_by_spec(
$args->{column_order}, [keys %field_map] )};
-
+
$self->_field_map(\%field_map);
$self->field_names(\@field_names);
}
$self->close_label($self->close_label_close);
};
-
+
implements build_fields_for => as {
my ($self, $attr, $args) = @_;
my $attr_name = $attr->name;
}
return @fields;
};
-
+
implements build_field_map => as {
confess "Lazy field map building not supported by default";
};
-
+
implements can_apply => as {
my ($self) = @_;
foreach my $field (values %{$self->_field_map}) {
}
return $self->action->can_apply;
};
-
+
implements do_apply => as {
my $self = shift;
return $self->action->do_apply;
};
-
+
implements ok => as {
my $self = shift;
if ($self->apply(@_)) {
$self->close(@_);
}
};
-
+
implements apply => as {
my $self = shift;
if ($self->can_apply && (my $result = $self->do_apply)) {
$self->changed(0);
$self->close_label($self->close_label_close);
- if ($self->has_on_apply_callback) {
- $self->on_apply_callback->($self => $result);
- }
+ $self->on_apply_callback->($self => $result) if $self->has_on_apply_callback;
return 1;
} else {
$self->changed(1);
return 0;
}
};
-
+
implements close => as {
my $self = shift;
my ($controller, $name, @args) = @{$self->next_action};
$controller->pop_viewport;
$controller->$name($self->action->ctx, @args);
};
-
+
sub can_close { 1 }
-
+
override accept_events => sub {
(($_[0]->has_next_action ? ('ok', 'close') : ()), 'apply', super());
}; # can't do a close-type operation if there's nowhere to go afterwards
-
+
override child_event_sinks => sub {
my ($self) = @_;
return ((grep { ref($_) =~ 'Hidden' } values %{$self->_field_map}),
(grep { ref($_) !~ 'Hidden' } values %{$self->_field_map}),
super());
};
-
+
after apply_child_events => sub {
# interrupt here because fields will have been updated
my ($self) = @_;
$self->sync_action_from_fields;
};
-
+
implements sync_action_from_fields => as {
my ($self) = @_;
my $field_map = $self->_field_map;
$field->sync_from_action; # get errors from $action if applicable
}
};
-
+
implements build_simple_field => as {
my ($self, $class, $attr, $args) = @_;
my $attr_name = $attr->name;
action => $self->action,
attribute => $attr,
name => $attr->name,
- location => join('-', $self->location, 'field', $attr->name),
+ location => join('-', $self->location, 'field', $attr->name),
ctx => $self->ctx,
%extra
);
return ($attr_name => $field);
};
-
+
implements build_fields_for_type_Num => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(Number, $attr, $args);
};
-
+
implements build_fields_for_type_Int => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(Number, $attr, $args);
};
-
+
implements build_fields_for_type_Bool => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(Boolean, $attr, $args);
};
-
+
implements build_fields_for_type_File => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(File, $attr, $args);
};
-
+
implements build_fields_for_type_Str => as {
my ($self, $attr, $args) = @_;
if ($attr->has_valid_values) { # There's probably a better way to do this
}
return $self->build_simple_field(Text, $attr, $args);
};
-
+
implements build_fields_for_type_SimpleStr => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(String, $attr, $args);
};
-
+
implements build_fields_for_type_Password => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(Password, $attr, $args);
};
-
+
implements build_fields_for_type_DateTime => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(DateTime, $attr, $args);
};
-
+
implements build_fields_for_type_Enum => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(ChooseOne, $attr, $args);
};
-
+
+ #implements build_fields_for_type_Reaction_InterfaceModel_Object => as {
implements build_fields_for_type_DBIx_Class_Row => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(ChooseOne, $attr, $args);
};
-
+
implements build_fields_for_type_ArrayRef => as {
my ($self, $attr, $args) = @_;
if ($attr->has_valid_values) {
return $self->build_simple_field(HiddenArray, $attr, $args)
}
};
-
+
implements build_fields_for_type_DateTime_Spanset => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(TimeRange, $attr, $args);
};
-
+
no Moose;
-
+
no strict 'refs';
delete ${__PACKAGE__ . '::'}{inner};
);
override build_value => sub {
- return [super()->all];
+ return [super()->members];
};
implements build_value_names => as {
class ChooseMany is 'Reaction::UI::ViewPort::Field::ChooseOne', which {
has '+layout' => (default => 'dual_select_group');
-
+
has '+value' => (isa => 'ArrayRef');
-
- has available_value_names =>
+
+ has available_value_names =>
(isa => 'ArrayRef', is => 'ro', lazy_build => 1);
-
+
has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1);
-
+
my $listify = sub { # quick utility function, $listify->($arg)
return (defined($_[0])
? (ref($_[0]) eq 'ARRAY'
: [$_[0]]) # $scalar => [$scalar]
: []); # undef => []
};
-
+
around value => sub {
my $orig = shift;
my $self = shift;
if (@_) {
my $value = $listify->(shift);
if (defined $value) {
- $_ = $self->str_to_ident($_) for @$value;
+ $_ = $self->str_to_ident($_) for @$value;
my $checked = $self->attribute->check_valid_value($self->action, $value);
# i.e. fail if any of the values fail
- confess "Not a valid set of values"
- if (@$checked < @$value || grep { !defined($_) } @$checked);
+ confess "Not a valid set of values"
+ if (@$checked < @$value || grep { !defined($_) } @$checked);
$value = $checked;
}
$orig->($self);
}
};
-
+
override build_value => sub {
return super() || [];
};
-
+
implements is_current_value => as {
my ($self, $check_value) = @_;
my @our_values = @{$self->value||[]};
$check_value = $self->obj_to_str($check_value) if ref($check_value);
return grep { $self->obj_to_str($_) eq $check_value } @our_values;
};
-
+
implements current_values => as {
my $self = shift;
my @all = grep { $self->is_current_value($_) } @{$self->valid_values};
return [ @all ];
};
-
+
implements available_values => as {
my $self = shift;
my @all = grep { !$self->is_current_value($_) } @{$self->valid_values};
return [ @all ];
};
-
+
implements build_available_value_names => as {
my $self = shift;
my @all = @{$self->available_values};
my @names = map { $_->$meth } @all;
return [ sort @names ];
};
-
+
implements build_value_names => as {
my $self = shift;
my @all = @{$self->value||[]};
my @names = map { $_->$meth } @all;
return [ sort @names ];
};
-
+
around handle_events => sub {
my $orig = shift;
my ($self, $events) = @_;
my $ev_value = $listify->($events->{value});
if (delete $events->{add_all_values}) {
- $events->{value} = $self->valid_values;
- }
+ delete $events->{add_values};
+ delete $events->{remove_values};
+ $events->{value} = [map {$self->obj_to_str($_)} @{$self->valid_values}];
+ }
if (delete $events->{do_add_values} && exists $events->{add_values}) {
my $add = $listify->(delete $events->{add_values});
$events->{value} = [ @{$ev_value}, @$add ];
}
if (delete $events->{remove_all_values}) {
+ delete $events->{add_values};
+ delete $events->{remove_values};
$events->{value} = [];
- }
+ }
if (delete $events->{do_remove_values} && exists $events->{remove_values}) {
my $remove = $listify->(delete $events->{remove_values});
my %r = map { ($_ => 1) } @$remove;
class ChooseOne is 'Reaction::UI::ViewPort::Field', which {
has '+layout' => (default => 'select');
-
+
has valid_value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1);
-
+
has valid_values => (isa => 'ArrayRef', is => 'ro', lazy_build => 1);
-
+
has name_to_value_map => (isa => 'HashRef', is => 'ro', lazy_build => 1);
-
+
has value_to_name_map => (isa => 'HashRef', is => 'ro', lazy_build => 1);
-
+
has value_map_method => (
isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' },
);
-
+
around value => sub {
my $orig = shift;
my $self = shift;
$orig->($self);
}
};
-
+
implements build_valid_values => as {
my $self = shift;
return [ $self->attribute->all_valid_values($self->action) ];
};
-
+
implements build_valid_value_names => as {
my $self = shift;
my $all = $self->valid_values;
my @names = map { $_->$meth } @$all;
return [ sort @names ];
};
-
+
implements build_name_to_value_map => as {
my $self = shift;
my $all = $self->valid_values;
$map{$_->$meth} = $self->obj_to_str($_) for @$all;
return \%map;
};
-
+
implements build_value_to_name_map => as {
my $self = shift;
my $all = $self->valid_values;
$map{$self->obj_to_str($_)} = $_->$meth for @$all;
return \%map;
};
-
+
implements is_current_value => as {
my ($self, $check_value) = @_;
my $our_value = $self->value;
use Scalar::Util qw/blessed/;
class ListView is 'Reaction::UI::ViewPort', which {
- has collection => (isa => 'DBIx::Class::ResultSet',
+ has collection => (isa => 'Reaction::InterfaceModel::Collection',
is => 'rw', required => 1);
has current_collection => (
- isa => 'DBIx::Class::ResultSet', is => 'rw',
+ isa => 'Reaction::InterfaceModel::Collection', is => 'rw',
lazy_build => 1, clearer => 'clear_current_collection',
);
has current_page_collection => (
- isa => 'DBIx::Class::ResultSet', is => 'rw',
+ isa => 'Reaction::InterfaceModel::Collection', is => 'rw',
lazy_build => 1, clearer => 'clear_current_page_collection',
);
implements build_current_collection => as {
my ($self) = @_;
my %attrs;
+
+ #XXX DBICism that needs to be fixed
if ($self->has_order_by) {
$attrs{order_by} = $self->order_by;
if ($self->order_by_desc) {
$attrs{order_by} .= ' DESC';
}
}
- return $self->collection
- ->search(undef, \%attrs);
+ return $self->collection->where(undef, \%attrs);
};
implements build_current_page_collection => as {
my %attrs;
return $self->current_collection unless $self->has_per_page;
$attrs{rows} = $self->per_page;
- return $self->current_collection
- ->search(undef, \%attrs)
- ->page($self->page);
+ return $self->current_collection->where(undef, \%attrs)->page($self->page);
};
implements all_current_rows => as {
- return shift->current_collection->all;
+ return shift->current_collection->members;
};
implements current_rows => as {
- return shift->current_page_collection->all;
+ return shift->current_page_collection->members;
};
implements build_field_names => as {
my ($self) = @_;
- #candidate for future optimization
+ #XXX candidate for future optimization
my %excluded = map { $_ => undef } @{ $self->exclude_columns };
- return
- $self->sort_by_spec( $self->column_order,
- [ map { (($_->get_read_method) || ()) }
- grep { !($_->has_type_constraint
- && ($_->type_constraint->is_a_type_of('ArrayRef')
- || eval { $_->type_constraint->name->isa(
- 'DBIx::Class::ResultSet') })) }
- grep { !exists $excluded{$_->name} }
- grep { $_->name !~ /^_/ }
- $self->current_collection
- ->result_class
- ->meta
- ->compute_all_applicable_attributes
- ] );
+ #XXX this abuse of '_im_class' needs to be fixed ASAP
+ my $object_class = $self->current_collection->_im_class;
+ my @fields = $object_class->meta->compute_all_applicable_attributes;
+ #eliminate excluded fields & treat names that start with an underscore as private
+ @fields = grep {$_->name !~ /^_/ && !exists $excluded{$_->name} } @fields;
+ #eliminate fields marked as collections, or fields that are arrayrefs
+ @fields = grep {
+ !($_->has_type_constraint &&
+ ($_->type_constraint->is_a_type_of('ArrayRef') ||
+ eval {$_->type_constraint->name->isa('Reaction::InterfaceModel::Collection')} ||
+ eval { $_->_isa_metadata->isa('Reaction::InterfaceModel::Collection') }
+ )
+ ) } @fields;
+
+ #for(grep { $_->has_type_constraint } @fields){
+ #my $tcname = $_->type_constraint->name;
+ #print STDERR $_->name, "\t", $tcname, "\n";
+ #use Data::Dumper;
+ #print STDERR Dumper($_->type_constraint);
+ #}
+
+ #order the columns all nice and pretty, and only get fields with readers, duh
+ return $self->sort_by_spec
+ ( $self->column_order, [ map { (($_->get_read_method) || ()) } @fields] );
};
implements build_field_label_map => as {
return \%labels;
};
+ #XXX this has to go soon, I recommend that Objects hold a registry of their actions
+ #and that they can be queried about it somehow
implements build_row_action_prototypes => as {
my $self = shift;
my $ctx = $self->ctx;
return [
{ label => 'View', action => sub {
- [ '', 'view', [ @{$ctx->req->captures}, $_[0]->id ] ] } },
+ [ '', 'view', [ @{$ctx->req->captures}, $_[0]->__id ] ] } },
{ label => 'Edit', action => sub {
- [ '', 'update', [ @{$ctx->req->captures}, $_[0]->id ] ] } },
+ [ '', 'update', [ @{$ctx->req->captures}, $_[0]->__id ] ] } },
{ label => 'Delete', action => sub {
- [ '', 'delete', [ @{$ctx->req->captures}, $_[0]->id ] ] } },
+ [ '', 'delete', [ @{$ctx->req->captures}, $_[0]->__id ] ] } },
];
};
return $self->build_simple_field(List, $attr, $args)
};
- #todo dirty hack need generic collection object
- #if a collection wasnt a resultset that'd be good.
- implements build_fields_for_type_Reaction_InterfaceModel_DBIC_Collection => as {
+ implements build_fields_for_type_Reaction_InterfaceModel_Collection => as {
my ($self, $attr, $args) = @_;
return $self->build_simple_field(Collection, $attr, $args)
};
%]
-<h2>Using ActionReflector and DBIC (View doesn't work)</h2>
-<p><a href="[% ctx.uri_for('/foo') %]">foo</a></p>
-<p><a href="[% ctx.uri_for('/bar') %]">bar</a></p>
-<p><a href="[% ctx.uri_for('/baz') %]">baz</a></p>
-
-<h2>Using InterfaceModel, ObjectClass, SchemaClass, and ModelBase</h2>
+<h2>Using InterfaceModel, Reflector</h2>
<p><a href="[% ctx.uri_for('/testmodel/foo') %]">foo</a></p>
<p><a href="[% ctx.uri_for('/testmodel/bar') %]">bar</a></p>
<p><a href="[% ctx.uri_for('/testmodel/baz') %]">baz</a></p>
use warnings;
use Test::Class;
-use RTest::InterfaceModel::DBIC;
use RTest::InterfaceModel::Reflector::DBIC;
Test::Class->runtests(
- RTest::InterfaceModel::DBIC->new(),
-);
-
-Test::Class->runtests(
RTest::InterfaceModel::Reflector::DBIC->new(),
);
+++ /dev/null
-package RTest::InterfaceModel::DBIC;
-
-use base qw/Reaction::Test::WithDB Reaction::Object/;
-use Reaction::Class;
-use ComponentUI::TestModel;
-use Test::More ();
-
-has '+schema_class' => (default => sub { 'RTest::TestDB' });
-
-has im_schema => (is =>'ro', isa => 'ComponentUI::TestModel', lazy_build => 1);
-sub build_im_schema{
- my $self = shift;
-
- my (@dm) = ComponentUI::TestModel->domain_models;
- Test::More::ok(@dm == 1, 'Correct number of Domain Models');
- my $dm = shift @dm;
- Test::More::ok($dm->name eq '_testdb_schema', 'Domain Model created correctly');
-
- ComponentUI::TestModel->new($dm->name => $self->schema);
-}
-
-sub test_SchemaClass :Tests {
- my $self = shift;
- my $s = $self->im_schema;
-
- #just make sure here...
- Test::More::isa_ok( $s, 'Reaction::InterfaceModel::Object',
- 'Correctly override default base object' );
-
- my %pa = map{$_->name => $_ } $s->parameter_attributes;
- Test::More::ok(keys %pa == 3, 'Correct number of Parameter Attributes');
-
- Test::More::ok($pa{Foo} && $pa{'Bar'} && $pa{'Baz'},
- 'Parameter Attributes named correctly');
-
- #for now since we have no generic collection object
- Test::More::ok
- ( $pa{Foo}->_isa_metadata eq 'Reaction::InterfaceModel::DBIC::Collection',
- 'Parameter Attributes typed correctly' );
-
- Test::More::is($pa{Baz}->reader, 'bazes', 'Correct Baz reader created');
- Test::More::is($pa{Foo}->reader, 'foo_collection', 'Correct Foo reader created');
- Test::More::is($pa{Bar}->reader, 'bar_collection', 'Correct Bar reader created');
-
- #is this check good enough? Moose will take care of checking the type constraints,
- # so i dont need tocheck that Moose++ !!
- my $foo1 = $s->foo_collection;
- my $foo2 = $s->foo_collection;
- Test::More::ok
- (Scalar::Util::refaddr($foo1) ne Scalar::Util::refaddr($foo2),
- 'Fresh Collections work');
-}
-
-sub test_ObjectClass :Tests {
- my $self = shift;
-
- my $collection = $self->im_schema->foo_collection;
- Test::More::ok( my $im = $collection->find({ id => 1}), 'Find call successful');
-
- Test::More::isa_ok( $im, 'ComponentUI::TestModel::Foo',
- 'Correct result class set' );
-
- my %pa = map{$_->name => $_ } $im->parameter_attributes;
- Test::More::ok(keys %pa == 4, 'Correct number of Parameter Attributes');
-
- Test::More::is( $pa{first_name}->_isa_metadata, 'NonEmptySimpleStr'
- ,'Column ParameterAttribute typed correctly');
-
- Test::More::is
- ($pa{baz_list}->_isa_metadata, 'Reaction::InterfaceModel::DBIC::Collection',
- "Relationship detected successfully");
-
- my (@dm) = $im->domain_models;
- Test::More::ok(@dm == 1, 'Correct number of Domain Models');
- my $dm = shift @dm;
- Test::More::is($dm->name, '_foo_store', 'Domain Model created correctly');
-
- my $rs = $collection->_override_action_args_for->{target_model};
- Test::More::isa_ok( $rs, 'DBIx::Class::ResultSet',
- 'Collection target_type ISA ResultSet' );
-
- my $row = $im->_default_action_args_for->{target_model};
- Test::More::isa_ok( $row, 'DBIx::Class::Row', 'Collection target_type ISA Row' );
-
- my $ctx = $self->simple_mock_context;
-
- my $create = $collection->action_for('Create', ctx => $ctx);
- Test::More::isa_ok( $create, 'Reaction::InterfaceModel::Action',
- 'Create action isa Action' );
-
- Test::More::isa_ok( $create, 'ComponentUI::TestModel::Foo::Action::Create',
- 'Create action has correct name' );
-
- Test::More::isa_ok
- ( $create, 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create',
- 'Create action isa Action::DBIC::ResultSet::Create' );
-
-
- my $update = $im->action_for('Update', ctx => $ctx);
- Test::More::isa_ok( $update, 'Reaction::InterfaceModel::Action',
- 'Update action isa Action' );
-
- Test::More::isa_ok( $update, 'ComponentUI::TestModel::Foo::Action::Update',
- 'Update action has correct name' );
-
- Test::More::isa_ok
- ( $update, 'Reaction::InterfaceModel::Action::DBIC::Result::Update',
- 'Update action isa Action::DBIC::ResultSet::Update' );
-
- my $delete = $im->action_for('Delete', ctx => $ctx);
- Test::More::isa_ok( $delete, 'Reaction::InterfaceModel::Action',
- 'Delete action isa Action' );
-
- Test::More::isa_ok( $delete, 'ComponentUI::TestModel::Foo::Action::Delete',
- 'Delete action has correct name' );
-
- Test::More::isa_ok
- ( $delete, 'Reaction::InterfaceModel::Action::DBIC::Result::Delete',
- 'Delete action isa Action::DBIC::ResultSet::Delete' );
-
-
- my $custom = $im->action_for('CustomAction', ctx => $ctx);
- Test::More::isa_ok( $custom, 'Reaction::InterfaceModel::Action',
- 'CustomAction isa Action' );
-
- Test::More::isa_ok( $custom, 'ComponentUI::TestModel::Foo::Action::CustomAction',
- 'CustomAction has correct name' );
-
- my %params = map {$_->name => $_ } $custom->parameter_attributes;
- Test::More::ok(exists $params{$_}, "Field ${_} reflected")
- for qw(first_name last_name baz_list);
-
- #TODO -- will I need a mock $c object or what? I dont really know much about
- # testingcat apps, who wants to volunteer?
- # main things needing testing is attribute reflection
- # and correct action class creation (superclasses)
-}
-
-
-1;
sub build_im_schema{
my $self = shift;
- my $reflector = Reaction::InterfaceModel::Reflector::DBIC
- ->new(model_class => 'RTest::TestIM');
+ my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
- $reflector->reflect_model(
- domain_model_class => 'RTest::TestDB',
- #exclude_submodels => ['FooBaz'],
- reflect_submodels => [qw/Foo Bar Baz/]
+ $reflector->reflect_schema(
+ model_class => 'RTest::TestIM',
+ schema_class => 'RTest::TestDB',
+ sources => [qw/Foo Bar Baz/]
);
my (@dm) = RTest::TestIM->domain_models;
Test::More::ok(@dm == 1, 'Correct number of Domain Models');
my $dm = shift @dm;
-
- print STDERR "instantiating with domain name of " . $dm->name . "\n";
RTest::TestIM->new($dm->name => $self->schema);
}
sub test_classnames : Tests{
my $self = shift;
- my $reflector = Reaction::InterfaceModel::Reflector::DBIC
- ->new(model_class => 'RTest::__TestIM');
+ my $reflector = Reaction::InterfaceModel::Reflector::DBIC->new;
- Test::More::ok(
- Class::MOP::is_class_loaded( 'RTest::__TestIM'),
- "Successfully created IM class"
- );
Test::More::is(
- $reflector->submodel_classname_from_source_name('Foo'),
+ $reflector->class_name_from_source_name('RTest::__TestIM','Foo'),
'RTest::__TestIM::Foo',
'Correct naming scheme for submodels'
);
-
Test::More::is(
- $reflector->classname_for_collection_of('RTest::__TestIM::Foo'),
+ $reflector->class_name_for_collection_of('RTest::__TestIM::Foo'),
'RTest::__TestIM::Foo::Collection',
'Correct naming scheme for submodel collections'
);
}
-sub test_reflect_model :Tests {
+sub test_reflect_schema :Tests {
my $self = shift;
my $s = $self->im_schema;
- Test::More::isa_ok( $s, 'Reaction::InterfaceModel::Object',
- 'Correct base' );
+ Test::More::isa_ok( $s, 'Reaction::InterfaceModel::Object', 'Correct base' );
my %pa = map{$_->name => $_ } $s->parameter_attributes;
Test::More::ok(keys %pa == 3, 'Correct number of Parameter Attributes');
}
-sub test_add_submodel_to_model :Tests {
+sub test_add_source_to_model :Tests {
my $self = shift;
my $s = $self->im_schema;
Test::More::ok( $attr->has_default, "${_} has a default");
Test::More::ok( $attr->is_default_a_coderef, "${_}'s defaultis a coderef");
Test::More::is( $attr->reader, $reader, "Correct ${_} reader");
- Test::More::is( $attr->domain_model, "_RTest_TestDB", "Correct ${_} domain_model");
+ Test::More::is( $attr->domain_model, "_rtest_testdb_store", "Correct ${_} domain_model");
Test::More::isa_ok(
$s->$reader,
Test::More::ok(@dm == 1, 'Correct number of Domain Models');
my $dm = shift @dm;
- my $dm_name = $sm;
- $dm_name =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ;
- $dm_name = "_" . lc($dm_name) . "_store";
+ my $dm_name = Reaction::InterfaceModel::Reflector::DBIC
+ ->dm_name_from_source_name($sm);
Test::More::is($dm->_is_metadata, "rw", "Correct is metadata");
Test::More::ok($dm->is_required, "DM is_required");
projects / catagits/Reaction.git / commitdiff