diff options
25 files changed, 357 insertions, 998 deletions
diff --git a/Makefile.PL b/Makefile.PL index 32017ca..7e299b3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -15,7 +15,7 @@ requires 'Test::Class' => 0; requires 'Test::Memory::Cycle' => 0; requires 'DBIx::Class' => '0.07001'; requires 'SQL::Translator' => '0.08'; -requires 'Moose' => '0.43'; +requires 'Moose' => '0.54'; requires 'aliased' => 0; requires 'DateTime'; requires 'DateTime::Span'; diff --git a/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm b/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm index 6b59e29..4c6534f 100644 --- a/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm +++ b/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm @@ -11,7 +11,8 @@ use Class::MOP; class DBIC, is 'Reaction::Object', is 'Catalyst::Component', which { - has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1); + has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1); + has '_im_class' => (is => 'ro', required => 1); implements 'COMPONENT' => as { my ($class, $app, $args) = @_; @@ -33,8 +34,7 @@ class DBIC, is 'Reaction::Object', is 'Catalyst::Component', which { my $params = $cfg{db_params} || {}; my $schema = $schema_class ->connect($cfg{db_dsn}, $cfg{db_user}, $cfg{db_password}, $params); - - return $class->new(_schema => $schema); + return $class->new(_schema => $schema, _im_class => $im_class); }; implements 'ACCEPT_CONTEXT' => as { @@ -48,7 +48,7 @@ class DBIC, is 'Reaction::Object', is 'Catalyst::Component', which { my ($self, $ctx) = @_; my $schema = $self->_schema->clone; - my $im_class = $self->config->{im_class}; + my $im_class = $self->_im_class; #XXXthis could be cut out later for a more elegant method my @domain_models = $im_class->domain_models; diff --git a/lib/DBIx/Class/IntrospectableM2M.pm b/lib/DBIx/Class/IntrospectableM2M.pm new file mode 100644 index 0000000..e3a921e --- /dev/null +++ b/lib/DBIx/Class/IntrospectableM2M.pm @@ -0,0 +1,35 @@ +package DBIx::Class::IntrospectableM2M; + +use strict; +use warnings; +use base 'DBIx::Class'; + +#namespace pollution. sadface. +__PACKAGE__->mk_classdata( _m2m_metadata => {} ); + +sub many_to_many { + my $class = shift; + my ($meth_name, $link, $far_side) = @_; + my $store = $class->_m2m_metadata; + die("You are overwritting another relationship's metadata") + if exists $store->{$meth_name}; + + my $attrs = + { + accessor => $meth_name, + relation => $link, #"link" table or imediate relation + foreign_relation => $far_side, #'far' table or foreign relation + (@_ > 3 ? (attrs => $_[3]) : ()), #only store if exist + rs_method => "${meth_name}_rs", #for completeness.. + add_method => "add_to_${meth_name}", + set_method => "set_${meth_name}", + remove_method => "remove_from_${meth_name}", + }; + + #inheritable data workaround/ + $class->_m2m_metadata({ $meth_name => $attrs, %$store}); + + $class->next::method(@_); +} + +1; diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm index 21887b5..cde8c79 100644 --- a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm +++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm @@ -340,26 +340,6 @@ class DBIC, which { }, ); -# my %debug_attr_opts = -# ( -# lazy => 1, -# required => 1, -# isa => $collection, -# reader => $reader, -# predicate => "has_" . $self->_class_to_attribute_name($name) , -# domain_model => $dm_name, -# orig_attr_name => $source, -# default => qq^sub { -# my \$self = \$_[0]; -# return $collection->new( -# _source_resultset => \$self->$dm_name->resultset("$source"), -# _parent => \$self, -# ); -# }, ^, -# ); - - - my $make_immutable = $meta->is_immutable; $meta->make_mutable if $make_immutable; my $attr = $meta->add_attribute($name, %attr_opts); @@ -686,6 +666,11 @@ class DBIC, which { ); #m2m / has_many + my $m2m_meta; + if(my $coderef = $source->result_class->can('_m2m_metadata')){ + $m2m_meta = $source->result_class->$coderef; + } + my $constraint_is_ArrayRef = $from_attr->type_constraint->name eq 'ArrayRef' || $from_attr->type_constraint->is_subtype_of('ArrayRef'); @@ -698,22 +683,21 @@ class DBIC, which { #has_many 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->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') { + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + $attr_opts{default} = eval "sub { + my \$rs = shift->${dm_name}->related_resultset('${attr_name}'); + return ${isa}->new(_source_resultset => \$rs); + }"; + } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter' ) { #belongs_to #type constraint is the foreign IM object, default inflates it - $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker); - $attr_opts{default} = sub { - if (defined(my $o = shift->$dm_name->$reader)) { - return $attr_opts{isa}->inflate_result($o->result_source, { $o->get_columns }); + my $isa = $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker); + $attr_opts{default} = eval "sub { + if (defined(my \$o = shift->${dm_name}->${reader})) { + return ${isa}->inflate_result(\$o->result_source, { \$o->get_columns }); } return undef; - #->find_related($attr_name, {},{result_class => $attr_opts{isa}}); - }; + }"; } } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) { #m2m magic @@ -727,25 +711,29 @@ class DBIC, which { ." traversing many-many for ${mm_name}_list"; my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name); - $attr_opts{isa} = $self->class_name_for_collection_of($sm); + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); #proper collections will remove the result_class uglyness. - $attr_opts{default} = sub { - my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name); - return $attr_opts{isa}->new(_source_resultset => $rs); - }; - #} elsif( $constraint_is_ArrayRef ){ - #test these to see if rel is m2m - #my $meth = $attr_name; - #if( $source->can("set_${meth}") && $source->can("add_to_${meth}") && - # $source->can("${meth}_rs") && $source->can("remove_from_${meth}") ){ - - - #} + $attr_opts{default} = eval "sub { + my \$rs = shift->${dm_name}->related_resultset('${link_table}')->related_resultset('${mm_name}'); + return ${isa}->new(_source_resultset => \$rs); + }"; + } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ + #m2m if using introspectable m2m component + my $rel = $m2m_meta->{$attr_name}->{relation}; + my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; + my $far_source = $source->related_source($rel)->related_source($far_rel); + my $sm = $self->class_name_from_source_name($parent_class, $far_source->source_name); + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + + my $rs_meth = $m2m_meta->{$attr_name}->{rs_method}; + $attr_opts{default} = eval "sub { + return ${isa}->new(_source_resultset => shift->${dm_name}->${rs_meth}); + }"; } else { #no rel $attr_opts{isa} = $from_attr->_isa_metadata; - $attr_opts{default} = sub{ shift->$dm_name->$reader }; + $attr_opts{default} = eval "sub{ shift->${dm_name}->${reader} }"; } return \%attr_opts; }; @@ -775,7 +763,7 @@ class DBIC, which { # 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 ]; + my $attr_haystack = [ map { $_->name } $object->parameter_attributes ]; if(!defined $attr_rules){ $attr_rules = [qr/./]; } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ @@ -860,6 +848,11 @@ class DBIC, which { } } + + my $m2m_meta; + if(my $coderef = $source_class->result_class->can('_m2m_metadata')){ + $m2m_meta = $source_class->result_class->$coderef; + } #test for relationships my $constraint_is_ArrayRef = $from_attr->type_constraint->name eq 'ArrayRef' || @@ -871,7 +864,7 @@ class DBIC, which { if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { confess "${attr_name} is a rw has_many, this won't work."; - } elsif( $rel_accessor eq 'single') { + } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter') { $attr_opts{valid_values} = sub { shift->target_model->result_source->related_source($attr_name)->resultset; }; @@ -879,18 +872,20 @@ class DBIC, which { } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { my $mm_name = $1; my $link_table = "links_to_${mm_name}_list"; - my ($hm_source, $far_side); - eval { $hm_source = $source->related_source($link_table); } - || confess "Can't find ${link_table} 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"; - $attr_opts{default} = sub { [] }; $attr_opts{valid_values} = sub { shift->target_model->result_source->related_source($link_table) ->related_source($mm_name)->resultset; }; + } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ + #m2m if using introspectable m2m component + my $rel = $m2m_meta->{$attr_name}->{relation}; + my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; + $attr_opts{default} = sub { [] }; + $attr_opts{valid_values} = sub { + shift->target_model->result_source->related_source($rel) + ->related_source($far_rel)->resultset; + }; } #use Data::Dumper; #print STDERR "\n" .$attr_name ." - ". $object . "\n"; diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC/Loader.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC/Loader.pm deleted file mode 100644 index 02363dd..0000000 --- a/lib/Reaction/InterfaceModel/Reflector/DBIC/Loader.pm +++ /dev/null @@ -1,877 +0,0 @@ -package Reaction::InterfaceModel::Reflector::DBIC::Loader; - -use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; -use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::DeleteAll'; -use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; -use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; - -use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet'; -use aliased 'Reaction::InterfaceModel::Object'; -use aliased 'Reaction::InterfaceModel::Action'; -use Reaction::Class; -use Class::MOP; - -use Catalyst::Utils; - -class Loader, which { - - #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 { [ qw/Create DeleteAll/ ] }; - - implements _build_builtin_object_actions => as { - { - Update => { name => 'Update', base => Update }, - Delete => { name => 'Delete', base => Delete, attributes => [] }, - }; - }; - - implements _build_builtin_collection_actions => as { - { - Create => {name => 'Create', base => Create }, - DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] } - }; - }; - - implements _all_object_actions => as { - my $self = shift; - return $self->merge_hashes - ($self->builtin_object_actions, $self->object_actions); - }; - - 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 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 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"; - }; - - 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); - } - } - }; - - - - has packages => ( - isa => 'HashRef', - required => 1, - is => 'ro', - default => sub{ {} }, - ); - - implements add_to_package => as { - my ($self, $package, $args) = @_; - my $orig = $self->packages->{$package} || {}; - my $merged = $self->merge_hashes($orig,$args || {}); - %$orig = %$merged; #don't break other refs that may be laying around - return $orig; - }; - - implements reflect_schema => as { - my ($self, %opts) = @_; - 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( $schema ); - - my $package_opts = {name => $model, superclasses => $base }; - my $package = $self->add_to_package($model, $package_opts); - - # 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 $sources = $self->parse_reflect_rules($rules, $haystack); - - - my $domain_model = {is => 'rw', isa => $schema, required => 1, %$dm_args}; - $self->add_to_package($model, {domain_models => {$dm_name => $domain_model}}); - - #push these to packages - 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 - ); - } - }; - - 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) }; - } - - 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 $dms = $self->packages->{$parent}->{domain_models}; - my @haystack = $parent_dm ? $dms->{$parent_dm} : keys %$dms; - - #there's a lot of guessing going on, but it should work fine on most cases - INNER: for my $needle (@haystack){ - my $isa = $dms->{$needle}->{isa}; - #we really have to clean up this nastiness and find a way to bring TCs - #into the mix here. To do: ( &constraint_is_dbix_class_schema ) - next INNER unless Class::MOP::load_class( $isa ); - 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{$_ 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, - }; - }; - - implements _class_to_attribute_name => as { - my ( $self, $str ) = @_; - confess("wrong arguments passed for _class_to_attribute_name") unless $str; - return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str)) - }; - - 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; - - 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 = $self->_class_to_attribute_name($reader) . "_collection"; - } - unless( $dm_name ){ - my $dms = $self->packages->{$model}->{domain_models}; - my @haystack = keys %$dms; - #again, here i could use that constraint_is_dbix_class_schema thing - if( @haystack > 1 ){ - @haystack = - grep { $dms->{$_}{isa}->isa('DBIx::Class::Schema') } - @haystack; - } - if(@haystack == 1){ - $dm_name = $haystack[0]; - } elsif(@haystack > 1){ - confess("Failed to automatically determine domain_model_name. More than one " . - "possible match (".(join ", ", map{"'${_}'"} @haystack).")"); - } else { - confess("Failed to automatically determine domain_model_name. No matches."); - } - } - - my $default_sub = qq^ sub { - my \$self = \$_[0]; - return $collection->new - ( - _source_resultset => \$self->$dm_name->resultset('${source}'), - _parent => \$self, - ); - };^ ; - my %attr_opts = - ( - lazy => 1, - required => 1, - isa => $collection, - reader => $reader, - predicate => "has_" . $self->_class_to_attribute_name($name) , - domain_model => $dm_name, - orig_attr_name => $source, - default => \$default_sub, #scalar ref means it's code - ); - - $self->add_to_package - ($model, {parameter_attributes => {$name => \%attr_opts}}); - }; - - implements reflect_source => as { - my ($self, %opts) = @_; - my $collection = delete $opts{collection} || {}; - %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; - - my $object_name = $self->reflect_source_object(%opts); - my $collection_name = $self->reflect_source_collection - ( - object_class => $object_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 => $collection_name, - ); - }; - - implements reflect_source_collection => as { - my ($self, %opts) = @_; - my $base = delete $opts{base} || ResultSet; - 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); - - - my $package = { - name => $class, - base => $base, - methods => {}, - method_modifiers => [], - }; - { - my $code = qq^sub { '${object}' }^; - $package->{methods}->{_build_member_type} = \ $code; - } - - my %model_action_map; - { - 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; - } - - # 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} || {}); - - #NOTE: If the name of the action is not specified in the prototype then use it's - #hash key as the name. I think this is sane beahvior, but I've actually been thinking - #of making Action prototypes their own separate objects - $self->reflect_source_action( - class => join('::', $object, 'Action', $action), - name => $action, - object_class => $object, - source_class => $source, - %$action_opts, - ); - - $model_action_map{$action} = '_source_resultset'; - } - } - { - my $code = q^ sub { - my $orig = shift; - my $tm = $_[0]->_source_resultset; - ^; - - while(my($act_name, $tm_meth) = each %model_action_map){ - $code .= qq^ \$tm = \$_[0]->$tm_meth if \$_[1] eq '${act_name}';\n^; - } - $code .= q^ return { %{ $orig->(@_) }, target_model => $tm }; ^; - $code .= "\n }"; - push( - @{ $package->{method_modifiers} }, - { - type => 'around', - name => '_default_action_args_for', - code => \$code, - } - ); - } - $self->add_to_package($class, $package); - return $class; - }; - - 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 $package = { - name => $class, - base => $base, - methods => {}, - method_modifiers => [], - domain_models => {}, - }; - - #create the domain model - $dm_name ||= $self->dm_name_from_source_name($source_name); - - $dm_opts->{isa} = $source_class; - $dm_opts->{is} ||= 'rw'; - $dm_opts->{required} ||= 1; - $dm_opts->{handles} = { - __id => 'id', - __ident_condition => 'ident_condition', - }; - $dm_opts->{handles}->{display_name} = 'display_name' - if $source_class->can('display_name'); - - $package->{domain_models}{$dm_name} = {%$dm_opts}; - my $dm_reader = $dm_opts->{reader} || $dm_opts->{accessor} || $dm_name; - - { - my $code = 'sub { - my $class = shift; - my ($src) = @_; - $src = $src->resolve if $src->isa("DBIx::Class::ResultSourceHandle"); - $class->new("'.$dm_name.'", $src->result_class->inflate_result(@_)); - }; '; - $package->{methods}->{inflate_result} = \$code; - } - - { - # 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} || {}}, - ); - } - } - - my %model_action_map; - { - 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} || {}); - - #NOTE: If the name of the action is not specified in the prototype then use it's - #hash key as the name. I think this is sane beahvior, but I've actually been thinking - #of making Action prototypes their own separate objects - $self->reflect_source_action( - class => join('::', $class, 'Action', $action), - name => $action, - object_class => $class, - source_class => $source_class, - %$action_opts, - ); - $model_action_map{$action} = $dm_reader; - } - } - { - my $code = qq^ sub { - my \$orig = shift; - my \$tm = \$_[0]->${dm_reader}; - ^; - - while(my($act_name, $tm_meth) = each %model_action_map){ - $code .= qq^ \$tm = \$_[0]->${tm_meth} if \$_[1] eq '${act_name}';\n^; - } - $code .= q^ return { %{ $orig->(@_) }, target_model => $tm }; ^; - $code .= "\n }"; - push( - @{ $package->{method_modifiers} }, - { - type => 'around', - name => '_default_action_args_for', - code => \$code, - } - ); - } - $self->add_to_package($class, $package); - return $class; - }; - - # needs class, attribute_name domain_model_name - 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 $attr_opts = $self->parameters_for_source_object_attribute(%opts); - $self->add_to_package - ( - $opts{class}, - { parameter_attributes => { $opts{attribute_name} => {%$attr_opts} } } - ); - }; - - # needs class, attribute_name domain_model_name - implements parameters_for_source_object_attribute => as { - my ($self, %opts) = @_; - - 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("source_class is a required argument") unless $source_class; - confess("domain_model_name is a required argument") unless $dm_name; - - my $source = $source_class->result_source_instance; - 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, - clearer => "_clear_${attr_name}", - predicate => "has_${attr_name}", - domain_model => $dm_name, - orig_attr_name => $attr_name, - ); - - #m2m / has_many - my $constraint_is_ArrayRef = - $from_attr->type_constraint->name eq 'ArrayRef' || - $from_attr->type_constraint->is_subtype_of('ArrayRef'); - - if( my $rel_info = $source->relationship_info($attr_name) ){ - my $rel_accessor = $rel_info->{attrs}->{accessor}; - my $rel_moniker = $rel_info->{class}->result_source_instance->source_name; - - if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { - #has_many - my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker); - #type constraint is a collection, and default builds it - my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); - my $code = qq^ sub { - my \$rs = shift->${dm_name}->related_resultset('${attr_name}'); - return ${isa}->new(_source_resultset => \$rs); - }^; - $attr_opts{default} = \$code; - } elsif( $rel_accessor eq 'single') { - #belongs_to - #type constraint is the foreign IM object, default inflates it - my $isa = $attr_opts{isa} = - $self->class_name_from_source_name($parent_class, $rel_moniker); - my $code = qq^ sub { - shift->${dm_name}->find_related - ( - '${attr_name}', - {}, - { result_class => '${isa}' } - ); - }^; - $attr_opts{default} = \$code; - } - } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) { - #m2m magic - my $mm_name = $1; - my $link_table = "links_to_${mm_name}_list"; - my ($hm_source, $far_side); - eval { $hm_source = $source->related_source($link_table); } - || confess "Can't find ${link_table} 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"; - - my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name); - my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); - - #proper collections will remove the result_class uglyness. - my $code = qq^ sub { - my \$rs = shift->${dm_name}->related_resultset('${link_table}') - ->related_resultset('${mm_name}'); - return ${isa}->new(_source_resultset => \$rs); - }^; - $attr_opts{default} = \$code; - - } else { - #no rel - my $reader = $from_attr->get_read_method; - $attr_opts{isa} = $from_attr->_isa_metadata; - $attr_opts{default} = \ "sub{ shift->${dm_name}->${reader} }"; - } - return \%attr_opts; - }; - - - implements reflect_source_action => as{ - my($self, %opts) = @_; - 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, class, object_class and source_class are required arguments") - unless $class && $source && $name && $object; - - my $attr_rules = delete $opts{attributes}; - 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 { $_ } keys %{ $self->packages->{$object}->{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 "${name}\t${class}\t${base}\n"; - #print STDERR "\t${object}\t${source}\n"; - #print STDERR "\t",@$attr_rules,"\n"; - - my $s_meta = $source->meta; - my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); - - #create the class - my $package = { - name => $class, - superclasses => $base, - parameter_attributes => {}, - }; - - my $parent_package = $self->packages->{$object}; - - for my $attr_name (keys %$attributes){ - my $attr_opts = $attributes->{$attr_name} || {}; - my $s_attr_name = $parent_package->{parameter_attributes} - ->{$attr_name}->{orig_attribute_name} || $attr_name; - my $s_attr = $s_meta->find_attribute_by_name($s_attr_name); - confess("Unable to find attribute for '${s_attr_name}' via '${source}'") - unless defined $s_attr; - next unless $s_attr->get_write_method - && $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 - ); - $package->{parameter_attributes}->{$attr_name} = { %$attr_params }; - } - }; - - implements parameters_for_source_object_action_attribute => as { - my ($self, %opts) = @_; - - my $object = delete $opts{object_class}; - my $attr_name = delete $opts{attribute_name}; - my $source_class = delete $opts{source_class}; - confess("object_class, $source_class and attribute_name are required parameters") - unless $attr_name && $object && $source_class; - - 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; - - my %attr_opts = ( - is => 'rw', - isa => $from_attr->_isa_metadata, - required => $from_attr->is_required, - ($from_attr->is_required - ? () : (clearer => "clear_${attr_name}")), - predicate => "has_${attr_name}", - ); - - if ($attr_opts{required}) { - if($from_attr->has_default) { - $attr_opts{lazy} = 1; - $attr_opts{default} = $from_attr->default; - } else { - $attr_opts{lazy_fail} = 1; - } - } - - #test for relationships - my $constraint_is_ArrayRef = - $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}; - - if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { - confess "${attr_name} is a rw has_many, this won't work."; - } elsif( $rel_accessor eq 'single') { - my $code = qq^ sub { - shift->target_model->result_source - ->related_source('${attr_name}')->resultset; - } ^; - $attr_opts{valid_values} = \ $code; - } - } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { - my $mm_name = $1; - my $link_table = "links_to_${mm_name}_list"; - my ($hm_source, $far_side); - eval { $hm_source = $source->related_source($link_table); } - || confess "Can't find ${link_table} 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"; - - $attr_opts{default} = \ "sub { [] }"; - my $code = qq^sub { - shift->target_model->result_source->related_source('${link_table}') - ->related_source('${mm_name}')->resultset; - } ^; - } - - return \%attr_opts; - }; - -}; - -1; diff --git a/lib/Reaction/Manual/Intro.pod b/lib/Reaction/Manual/Intro.pod index 523e5e8..9ea0974 100644 --- a/lib/Reaction/Manual/Intro.pod +++ b/lib/Reaction/Manual/Intro.pod @@ -66,6 +66,31 @@ by Reaction to build the interface components. If you're not familiar with L<DBIx::Class> or don't have a schema handy, now is a good time to go through L<DBIx::Class::Manual::Intro> to get a schema set up. +It is important that your Result-objects implement the meta-protocol of Moose +One way to achive that is to do the following: + + package MyApp::Schema::Result::Bar; + use base 'DBIx::Class'; + use Moose; + + has 'name' => (isa => 'Str', required => 1, rw => 1); + + use namespace::clean -except => [ 'meta' ]; + + __PACKAGE__->load_components(qw(Core)); + __PACKAGE__->table('bar'); + __PACKAGE__->add_columns( + name => { + data_type => 'varchar', + size => 255, + is_nullable => 0, + } + ); + __PACKAGE__->primary_key('name'); + 1; + +Once you have your schema set up like that, you can create the InferfaceModel: + package MyApp::InterfaceModel::DBIC; use base 'Reaction::InterfaceModel::Object'; @@ -81,8 +106,23 @@ L<DBIx::Class::Manual::Intro> to get a schema set up. 1; +Then you create a MyApp::Model that uses this InferfaceModel: + + package Myapp::Model::IM; + + + use Reaction::Class; + + class IM is 'Catalyst::Model::Reaction::InterfaceModel::DBIC', which { + + }; + + 1; + =head2 Controllers +=head3 Root controller + Your Reaction application must have a Root controller which inherits from C<Reaction::UI::Controller::Root>. @@ -100,10 +140,42 @@ C<Reaction::UI::Controller::Root>. 1; +=head3 Individual controllers + +For each Collection(table?) in your DB, you need to create a controller + + package MyApp::Controller::Foo; + + use base 'Reaction::UI::Controller::Collection::CRUD'; + use Reaction::Class; + + __PACKAGE__->config( + model_name => 'IM', # This corresponds to the name of the MyApp::Model you created earlier + collection_name => 'Foo', # Name of one of the sources in your InterfaceModel + action => { base => { Chained => '/base', PathPart => 'foo' } }, + ); + + 1; + XX TODO =head2 View +One of the views in your application should look something like this: + + package MyApp::View::TT; + + use Reaction::Class; + + class TT is 'Reaction::UI::View::TT', which { + + }; + + 1; + + __END__; + + XX TODO =head1 SEE ALSO diff --git a/lib/Reaction/Meta/Attribute.pm b/lib/Reaction/Meta/Attribute.pm index a925982..b6ea1a0 100644 --- a/lib/Reaction/Meta/Attribute.pm +++ b/lib/Reaction/Meta/Attribute.pm @@ -8,6 +8,10 @@ extends 'Moose::Meta::Attribute'; has lazy_fail => (is => 'ro', reader => 'is_lazy_fail', required => 1, default => 0); +around legal_options_for_inheritance => sub { + return (shift->(@_), qw/valid_values/); +}; + around _process_options => sub { my $super = shift; my ($class, $name, $options) = @_; diff --git a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm index b838444..6c2a651 100644 --- a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm +++ b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm @@ -6,7 +6,7 @@ use Scalar::Util 'blessed'; class ParameterAttribute is 'Reaction::Meta::Attribute', which { has valid_values => ( isa => 'CodeRef', - is => 'rw', # hack since clone_and_inherit hates me. + is => 'rw', # doesnt need of it anymore, maybe we should warn before change it predicate => 'has_valid_values' ); diff --git a/lib/Reaction/UI/Controller.pm b/lib/Reaction/UI/Controller.pm index a6ff6ef..0ccba8f 100644 --- a/lib/Reaction/UI/Controller.pm +++ b/lib/Reaction/UI/Controller.pm @@ -55,7 +55,7 @@ sub redirect_to { my $action; if(!ref $to){ $action = $self->action_for($to); - confess("Failed to locate action ${to} in " . $self->blessed) unless $action; + confess("Failed to locate action ${to} in " . blessed($self)) unless $action; } elsif( blessed $to && $to->isa('Catalyst::Action') ){ $action = $to; diff --git a/lib/Reaction/UI/Skin.pm b/lib/Reaction/UI/Skin.pm index a875366..7ecece8 100644 --- a/lib/Reaction/UI/Skin.pm +++ b/lib/Reaction/UI/Skin.pm @@ -6,6 +6,7 @@ use Reaction::Class; use Reaction::UI::LayoutSet; use Reaction::UI::RenderingContext; use File::ShareDir; +use File::Basename; use aliased 'Path::Class::Dir'; @@ -41,9 +42,26 @@ class Skin which { my $skin_name = $self->name; if ($skin_name =~ s!^/(.*?)/!!) { my $dist = $1; - $args->{skin_base_dir} = - Dir->new(File::ShareDir::dist_dir($dist)) - ->subdir('skin'); + $args->{skin_base_dir} = eval { + Dir->new(File::ShareDir::dist_dir($dist)) + ->subdir('skin'); + }; + if ($@) { + # No installed Reaction + my $file = __FILE__; + my $dir = Dir->new(dirname($file)); + my $skin_base; + while ($dir->parent) { + if (-d $dir->subdir('share') && -d $dir->subdir('share')->subdir('skin')) { + $skin_base = $dir->subdir('share')->subdir('skin'); + last; + } + $dir = $dir->parent; + } + confess "could not find skinbase by recursion. ended up at $dir, from $file" + unless $skin_base; + $args->{skin_base_dir} = $skin_base; + } } my $base = $args->{skin_base_dir}->subdir($skin_name); confess "No such skin base directory ${base}" @@ -150,7 +168,7 @@ class Skin which { implements 'widget_class_for' => as { my ($self, $layout_set) = @_; - my $base = $self->blessed; + my $base = blessed($self); my $widget_type = $layout_set->widget_type; return $self->_widget_class_cache->{$widget_type} ||= do { diff --git a/lib/Reaction/UI/ViewPort.pm b/lib/Reaction/UI/ViewPort.pm index 1c2b755..02a1390 100644 --- a/lib/Reaction/UI/ViewPort.pm +++ b/lib/Reaction/UI/ViewPort.pm @@ -3,10 +3,10 @@ package Reaction::UI::ViewPort; use Reaction::Class; use Scalar::Util qw/blessed/; -sub DEBUG_EVENTS () { $ENV{REACTION_UI_VIEWPORT_DEBUG_EVENTS} } - class ViewPort which { + sub DEBUG_EVENTS () { $ENV{REACTION_UI_VIEWPORT_DEBUG_EVENTS} } + has location => (isa => 'Str', is => 'rw', required => 1); has layout => (isa => 'Str', is => 'rw', lazy_build => 1); has layout_args => (isa => 'HashRef', is => 'ro', default => sub { {} }); diff --git a/lib/Reaction/UI/ViewPort/Collection/Grid.pm b/lib/Reaction/UI/ViewPort/Collection/Grid.pm index 3719aa7..66ce8d3 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Grid.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Grid.pm @@ -41,7 +41,7 @@ class Grid is 'Reaction::UI::ViewPort::Collection', which { ) ) } grep { defined $_->get_read_method } - $self->current_collection->member_type->meta->parameter_attributes; + $self->current_collection->member_type->parameter_attributes; return $self->sort_by_spec($self->field_order, \@names); }; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm index 3b38d26..654f0d8 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm @@ -17,7 +17,7 @@ class 'Reaction::UI::ViewPort::Field::Mutable::DateTime', my $dt = 'DateTime'->from_epoch( epoch => $epoch ); $self->value($dt); } else { - $self->message("Could not parse date or time"); + $self->value($self->value_string); } }; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm index 03cb922..6d9d8aa 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm @@ -6,14 +6,21 @@ use aliased 'Reaction::UI::ViewPort::Field::Mutable::Password'; class MatchingPasswords is Password, which { has check_value => (is => 'rw', isa => 'Str', ); + has check_label => (is => 'rw', isa => 'Str', lazy_build => 1); + + implements _build_check_label => as { + my $orig_label = shift->label; + return "Confirm ${orig_label}"; + }; #maybe both check_value and value_string should have triggers ? #that way if one even happens before the other it would still work? - around _adopt_value_string => sub { + around adopt_value_string => sub { my $orig = shift; my ($self) = @_; return $orig->(@_) if $self->check_value eq $self->value_string; $self->message("Passwords do not match"); + return; }; #order is important check_value should happen before value here ... diff --git a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm index 010ea07..e2304ef 100644 --- a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm +++ b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm @@ -81,7 +81,11 @@ role Mutable, which { implements sync_from_action => as { my ($self) = @_; return unless !$self->needs_sync; # && $self->has_attribute; - $self->message($self->model->error_for($self->attribute) || ''); + if( !$self->has_message ){ + if(my $error = $self->model->error_for($self->attribute) ){ + $self->message( $error ); + } + } }; around accept_events => sub { ('value', shift->(@_)) }; diff --git a/lib/Reaction/UI/ViewPort/Object.pm b/lib/Reaction/UI/ViewPort/Object.pm index 5c56e90..7efbe15 100644 --- a/lib/Reaction/UI/ViewPort/Object.pm +++ b/lib/Reaction/UI/ViewPort/Object.pm @@ -58,7 +58,7 @@ class Object is 'Reaction::UI::ViewPort', which { my %excluded = map { $_ => undef } @{ $self->excluded_fields }; #treat _$field_name as private and exclude fields with no reader my @names = grep { $_ !~ /^_/ && !exists($excluded{$_})} map { $_->name } - grep { defined $_->get_read_method } $self->model->meta->parameter_attributes; + grep { defined $_->get_read_method } $self->model->parameter_attributes; return $self->sort_by_spec($self->field_order || [], \@names); }; diff --git a/lib/Reaction/UI/Widget.pm b/lib/Reaction/UI/Widget.pm index 57f3cab..3a9bc5c 100644 --- a/lib/Reaction/UI/Widget.pm +++ b/lib/Reaction/UI/Widget.pm @@ -5,11 +5,11 @@ use aliased 'Reaction::UI::ViewPort'; use aliased 'Reaction::UI::View'; use aliased 'Reaction::UI::LayoutSet'; -sub DEBUG_FRAGMENTS () { $ENV{REACTION_UI_WIDGET_DEBUG_FRAGMENTS} } -sub DEBUG_LAYOUTS () { $ENV{REACTION_UI_WIDGET_DEBUG_LAYOUTS} } - class Widget which { + sub DEBUG_FRAGMENTS () { $ENV{REACTION_UI_WIDGET_DEBUG_FRAGMENTS} } + sub DEBUG_LAYOUTS () { $ENV{REACTION_UI_WIDGET_DEBUG_LAYOUTS} } + has 'view' => (isa => View, is => 'ro', required => 1); has 'layout_set' => (isa => LayoutSet, is => 'ro', required => 1); has 'fragment_names' => (is => 'ro', lazy_build => 1); diff --git a/lib/Reaction/UI/Widget/Field/Mutable/MatchingPasswords.pm b/lib/Reaction/UI/Widget/Field/Mutable/MatchingPasswords.pm index 44c7103..02ec220 100644 --- a/lib/Reaction/UI/Widget/Field/Mutable/MatchingPasswords.pm +++ b/lib/Reaction/UI/Widget/Field/Mutable/MatchingPasswords.pm @@ -5,12 +5,21 @@ use aliased 'Reaction::UI::Widget::Field::Mutable::Password'; class MatchingPasswords is Password, which { - implements fragment check_value { + implements fragment check_field { arg 'field_id' => event_id 'check_value'; arg 'field_name' => event_id 'check_value'; + arg 'label' => 'Confirm:'; render 'field'; #piggyback! }; + implements fragment check_label { + if (my $label = $_{viewport}->check_label) { + arg label => $label; + render 'label'; + } + }; + + }; 1; diff --git a/script/rclass_back_to_moose.pl b/script/rclass_back_to_moose.pl new file mode 100644 index 0000000..d22700d --- /dev/null +++ b/script/rclass_back_to_moose.pl @@ -0,0 +1,70 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use IO::All; + +sub with_file (&) { + my ($code) = @_; + my $fname = $_; + my $data < io($fname); + { + local $_ = $data; + $code->(); + $data = $_; + } + $data > io($fname); +} + +sub with_class_or_role_block (&) { + my ($code) = @_; + $_ =~ s{^(class|role)\s*(.*?)which\s*{(.*?)^};} + { + local *_ = { type => $1, header => $2, body => $3 }; + $code->(); + }sme; +} + +sub parse_header { + my $h = $_{header}; + $h =~ s/^\s*\S+\s+// || die; + my @base; + while ($h =~ /is\s*([^ ,]+),?/g) { + push(@base, $1); + } + return @base; +} + +sub build_extends { + my $base = join(', ', parse_header); + ($base ? "extends ${base};\n\n" : ''); +} + +sub sq { # short for 'strip quotes' + my $copy = $_[0]; + $copy =~ s/^'(.*)'$/$1/; + $copy =~ s/^"(.*)"$/$1/; + $copy; +} + +sub filtered_body { + local $_ = $_{body}; + s/^ //g; + s/^\s*implements *(\S+).*?{/"sub ${\sq $1} {"/ge; + s/^\s*does/with/g; + s/^\s*overrides/override/g; + $_; +} + +sub top { "use namespace::clean -except => [ qw(meta) ];\n" } +sub tail { $_{type} eq 'class' ? "__PACKAGE__->meta->make_immutable;\n" : ""; } + +for (@ARGV) { + with_file { + with_class_or_role_block { + return top.build_extends.filtered_body.tail; + }; + }; +} + +1; diff --git a/share/skin/default/layout/field/mutable/matching_passwords.tt b/share/skin/default/layout/field/mutable/matching_passwords.tt index d07b784..450e5b4 100644 --- a/share/skin/default/layout/field/mutable/matching_passwords.tt +++ b/share/skin/default/layout/field/mutable/matching_passwords.tt @@ -2,7 +2,10 @@ =for layout widget -[% call_next %] -[% check_value %] +[% label_fragment %] +[% field %] +[% check_label %] +[% check_field %] +[% message_fragment %] =cut diff --git a/t/04load_all.t b/t/04load_all.t index a7923fc..54c1bb0 100644 --- a/t/04load_all.t +++ b/t/04load_all.t @@ -10,6 +10,7 @@ my $finder = Module::Pluggable::Object->new( search_path => [ 'Reaction' ], ); -foreach my $class (sort $finder->plugins) { +foreach my $class (grep !/\.ToDo/, + sort do { local @INC = ('lib'); $finder->plugins }) { Test::More::use_ok($class); } diff --git a/t/lib/RTest/TestDB/Bar.pm b/t/lib/RTest/TestDB/Bar.pm index ab36958..4359d87 100644 --- a/t/lib/RTest/TestDB/Bar.pm +++ b/t/lib/RTest/TestDB/Bar.pm @@ -1,19 +1,21 @@ package # hide from PAUSE RTest::TestDB::Bar; -use DBIx::Class 0.07; +use base qw/DBIx::Class/; +use metaclass 'Reaction::Meta::Class'; +use Moose; -use base qw/DBIx::Class Reaction::Object/; -use Reaction::Class; -use Reaction::Types::Core 'NonEmptySimpleStr'; -use Reaction::Types::DateTime 'DateTime'; +use Reaction::Types::Core qw/NonEmptySimpleStr/; +use Reaction::Types::DateTime qw//; use Reaction::Types::File 'File'; has 'name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1); has 'foo' => (isa => 'RTest::TestDB::Foo', is => 'rw', required => 1); -has 'published_at' => (isa => DateTime, is => 'rw'); +has 'published_at' => (isa => Reaction::Types::DateTime::DateTime, is => 'rw'); has 'avatar' => (isa => File, is => 'rw'); +use namespace::clean -except => [ 'meta' ]; + __PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); __PACKAGE__->table('bar'); @@ -32,7 +34,8 @@ __PACKAGE__->belongs_to( { 'foreign.id' => 'self.foo_id' } ); -#__PACKAGE__->meta->make_immutable; +sub display_name{ shift->name } + __PACKAGE__->meta->make_immutable(inline_constructor => 0); 1; diff --git a/t/lib/RTest/TestDB/Baz.pm b/t/lib/RTest/TestDB/Baz.pm index ebb0e32..ad4c61e 100644 --- a/t/lib/RTest/TestDB/Baz.pm +++ b/t/lib/RTest/TestDB/Baz.pm @@ -1,17 +1,26 @@ package # hide from PAUSE RTest::TestDB::Baz; -use DBIx::Class 0.07; +use base qw/DBIx::Class::Core/; +use metaclass 'Reaction::Meta::Class'; +use Moose; -use base qw/DBIx::Class Reaction::Object/; -use Reaction::Class; -use Reaction::Types::Core 'NonEmptySimpleStr'; +use MooseX::Types::Moose qw/ArrayRef Int/; +use Reaction::Types::Core qw/NonEmptySimpleStr/; -has 'id' => (isa => 'Int', is => 'ro', required => 1); +has 'id' => (isa => Int, is => 'ro', required => 1); has 'name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1); -has 'foo_list' => (isa => 'ArrayRef', is => 'ro', required => 1); +has 'foo_list' => ( + isa => ArrayRef, + is => 'rw', + required => 1, + writer => 'set_foo_list', + reader => 'get_foo_list', + ); -__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); +around get_foo_list => sub { [ $_[1]->foo_list->all ] }; + +use namespace::clean -except => [ 'meta' ]; __PACKAGE__->table('baz'); @@ -20,14 +29,13 @@ __PACKAGE__->add_columns( name => { data_type => 'varchar', size => 255 }, ); -sub display_name { shift->name; } - __PACKAGE__->set_primary_key('id'); __PACKAGE__->has_many('links_to_foo_list' => 'RTest::TestDB::FooBaz', 'baz'); __PACKAGE__->many_to_many('foo_list' => 'links_to_foo_list' => 'foo'); -#__PACKAGE__->meta->make_immutable; +sub display_name { shift->name; } + __PACKAGE__->meta->make_immutable(inline_constructor => 0); 1; diff --git a/t/lib/RTest/TestDB/Foo.pm b/t/lib/RTest/TestDB/Foo.pm index e580af8..a7e669c 100644 --- a/t/lib/RTest/TestDB/Foo.pm +++ b/t/lib/RTest/TestDB/Foo.pm @@ -1,22 +1,28 @@ package # hide from PAUSE RTest::TestDB::Foo; -use DBIx::Class 0.07; +use base qw/DBIx::Class/; +use metaclass 'Reaction::Meta::Class'; +use Moose; -use base qw/DBIx::Class Reaction::Object/; -use Reaction::Class; -use Reaction::Types::Core 'NonEmptySimpleStr'; +use MooseX::Types::Moose qw/ArrayRef Int/; +use Reaction::Types::Core qw/NonEmptySimpleStr/; -has 'id' => (isa => 'Int', is => 'ro', required => 1); +has 'id' => (isa => Int, is => 'ro', required => 1); has 'first_name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1); has 'last_name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1); -has 'baz_list' => ( - isa => 'ArrayRef', is => 'rw', required => 1, - reader => 'get_baz_list', writer => 'set_baz_list' +has 'bars' => (isa => ArrayRef ); +has 'bazes' => + ( + isa => ArrayRef, + required => 1, + reader => 'get_bazes', + writer => 'set_bazes' ); -__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); +use namespace::clean -except => [ 'meta' ]; +__PACKAGE__->load_components(qw/IntrospectableM2M Core/); __PACKAGE__->table('foo'); __PACKAGE__->add_columns( @@ -25,21 +31,22 @@ __PACKAGE__->add_columns( last_name => { data_type => 'varchar', size => 255 }, ); -sub display_name { - my $self = shift; - return join(' ', $self->first_name, $self->last_name); -} - __PACKAGE__->set_primary_key('id'); -__PACKAGE__->has_many('links_to_baz_list' => 'RTest::TestDB::FooBaz', 'foo'); -__PACKAGE__->many_to_many('baz_list' => 'links_to_baz_list' => 'baz'); +__PACKAGE__->has_many( + 'bars' => 'RTest::TestDB::Bar', + { 'foreign.foo_id' => 'self.id' } + ); -{ - no warnings 'redefine'; - *get_baz_list = sub { [ shift->baz_list->all ] }; +__PACKAGE__->has_many('foo_baz' => 'RTest::TestDB::FooBaz', 'foo'); +__PACKAGE__->many_to_many('bazes' => 'foo_baz' => 'baz'); + +sub display_name { + my $self = shift; + return join(' ', $self->first_name, $self->last_name); } +around get_bazes => sub { [ $_[1]->bazes_rs->all ] }; __PACKAGE__->meta->make_immutable(inline_constructor => 0); diff --git a/t/lib/RTest/TestDB/FooBaz.pm b/t/lib/RTest/TestDB/FooBaz.pm index 695b141..66e38c2 100644 --- a/t/lib/RTest/TestDB/FooBaz.pm +++ b/t/lib/RTest/TestDB/FooBaz.pm @@ -1,11 +1,9 @@ package # hide from PAUSE RTest::TestDB::FooBaz; -use DBIx::Class 0.07; - -use base qw/DBIx::Class/; - -__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); +use base qw/DBIx::Class::Core/; +use metaclass 'Reaction::Meta::Class'; +use Moose; __PACKAGE__->table('foo_baz'); @@ -19,4 +17,6 @@ __PACKAGE__->set_primary_key(qw/foo baz/); __PACKAGE__->belongs_to('foo' => 'RTest::TestDB::Foo'); __PACKAGE__->belongs_to('baz' => 'RTest::TestDB::Baz'); +__PACKAGE__->meta->make_immutable(inline_constructor => 0); + 1; |