diff options
91 files changed, 3814 insertions, 3811 deletions
diff --git a/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm b/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm index 4c6534f..4ba28f4 100644 --- a/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm +++ b/lib/Catalyst/Model/Reaction/InterfaceModel/DBIC.pm @@ -9,60 +9,62 @@ use Class::MOP; #XXX so yeah, thisis kinda hacky. big whop though, i need it. #this may just all together go away in the future -class DBIC, is 'Reaction::Object', is 'Catalyst::Component', which { - - has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1); - has '_im_class' => (is => 'ro', required => 1); - - implements 'COMPONENT' => as { - my ($class, $app, $args) = @_; - my %cfg = %{ Catalyst::Utils::merge_hashes($class->config, $args) }; - - my $im_class = $cfg{im_class}; - Class::MOP::load_class($im_class); - - #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; - confess 'ModelBase does not yet support multiple domain models' - if @domain_models > 1; - my $domain_model = shift @domain_models; - my $schema_class = $domain_model->_isa_metadata; - Class::MOP::load_class($schema_class); - - 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, _im_class => $im_class); - }; - - implements 'ACCEPT_CONTEXT' => as { - my ($self, $ctx) = @_; - return $self->CONTEXTUAL_CLONE($ctx) unless ref $ctx; - return $ctx->stash->{ref($self)} ||= $self->CONTEXTUAL_CLONE($ctx); - }; - - #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->_im_class; - - #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; - confess 'ModelBase does not yet support multiple domain models' - if @domain_models > 1; - my $domain_model = shift @domain_models; - - return $im_class->new($domain_model->name => $schema); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Object', 'Catalyst::Component'; + + + +has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1); +has '_im_class' => (is => 'ro', required => 1); +sub COMPONENT { + my ($class, $app, $args) = @_; + my %cfg = %{ Catalyst::Utils::merge_hashes($class->config, $args) }; + + my $im_class = $cfg{im_class}; + Class::MOP::load_class($im_class); + + #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; + confess 'ModelBase does not yet support multiple domain models' + if @domain_models > 1; + my $domain_model = shift @domain_models; + my $schema_class = $domain_model->_isa_metadata; + Class::MOP::load_class($schema_class); + + 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, _im_class => $im_class); +}; +sub ACCEPT_CONTEXT { + my ($self, $ctx) = @_; + return $self->CONTEXTUAL_CLONE($ctx) unless ref $ctx; + return $ctx->stash->{ref($self)} ||= $self->CONTEXTUAL_CLONE($ctx); +}; + +#XXXto do build in support for RestrictByUser natively or by subclass +sub CONTEXTUAL_CLONE { + my ($self, $ctx) = @_; + my $schema = $self->_schema->clone; + + my $im_class = $self->_im_class; + #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; + confess 'ModelBase does not yet support multiple domain models' + if @domain_models > 1; + my $domain_model = shift @domain_models; + + return $im_class->new($domain_model->name => $schema); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/ComponentUI/Model/TestModel.pm b/lib/ComponentUI/Model/TestModel.pm index 3d633f3..42ef181 100644 --- a/lib/ComponentUI/Model/TestModel.pm +++ b/lib/ComponentUI/Model/TestModel.pm @@ -5,9 +5,13 @@ use aliased 'Catalyst::Model::Reaction::InterfaceModel::DBIC'; use Reaction::Class; -class TestModel is DBIC, which { +use namespace::clean -except => [ qw(meta) ]; +extends DBIC; + + + +__PACKAGE__->meta->make_immutable; -}; __PACKAGE__->config ( diff --git a/lib/ComponentUI/View/Site.pm b/lib/ComponentUI/View/Site.pm index 280b41e..32595dd 100644 --- a/lib/ComponentUI/View/Site.pm +++ b/lib/ComponentUI/View/Site.pm @@ -3,9 +3,13 @@ package ComponentUI::View::Site; use Reaction::Class; use aliased 'Reaction::UI::View::TT'; -class Site is TT, which { +use namespace::clean -except => [ qw(meta) ]; +extends TT; + + + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action.pm b/lib/Reaction/InterfaceModel/Action.pm index 55cdfbe..7a57d78 100644 --- a/lib/Reaction/InterfaceModel/Action.pm +++ b/lib/Reaction/InterfaceModel/Action.pm @@ -6,83 +6,79 @@ use metaclass 'Reaction::Meta::InterfaceModel::Action::Class'; use Reaction::Meta::Attribute; use Reaction::Class; -class Action which { - - has target_model => (is => 'ro', required => 1, - metaclass => 'Reaction::Meta::Attribute'); - - has ctx => (isa => 'Catalyst', is => 'ro', required => 1, - metaclass => 'Reaction::Meta::Attribute'); - - implements parameter_attributes => as { - shift->meta->parameter_attributes; - }; - - implements parameter_hashref => as { - my ($self) = @_; - my %params; - foreach my $attr ($self->parameter_attributes) { - my $reader = $attr->get_read_method; - my $predicate = $attr->get_predicate_method; - next if defined($predicate) && !$self->$predicate; - $params{$attr->name} = $self->$reader; - } - return \%params; - }; - - implements can_apply => as { - my ($self) = @_; - foreach my $attr ($self->parameter_attributes) { - my $predicate = $attr->get_predicate_method; - if ($self->attribute_is_required($attr)) { - return 0 unless $self->$predicate; - } - if ($attr->has_valid_values) { - unless ($predicate && !($self->$predicate)) { - my $reader = $attr->get_read_method; - return 0 unless $attr->check_valid_value($self, $self->$reader); - } - } - } - return 1; - }; - - implements error_for => as { - my ($self, $attr) = @_; - confess "No attribute passed to error_for" unless defined($attr); - unless (ref($attr)) { - my $meta = $self->meta->find_attribute_by_name($attr); - confess "Can't find attribute ${attr} on $self" unless $meta; - $attr = $meta; - } - return $self->error_for_attribute($attr); - }; +use namespace::clean -except => [ qw(meta) ]; - implements error_for_attribute => as { - my ($self, $attr) = @_; + +has target_model => (is => 'ro', required => 1, + metaclass => 'Reaction::Meta::Attribute'); + +has ctx => (isa => 'Catalyst', is => 'ro', required => 1, + metaclass => 'Reaction::Meta::Attribute'); +sub parameter_attributes { + shift->meta->parameter_attributes; +}; +sub parameter_hashref { + my ($self) = @_; + my %params; + foreach my $attr ($self->parameter_attributes) { my $reader = $attr->get_read_method; my $predicate = $attr->get_predicate_method; + next if defined($predicate) && !$self->$predicate; + $params{$attr->name} = $self->$reader; + } + return \%params; +}; +sub can_apply { + my ($self) = @_; + foreach my $attr ($self->parameter_attributes) { + my $predicate = $attr->get_predicate_method; if ($self->attribute_is_required($attr)) { - unless ($self->$predicate) { - return $attr->name." is required"; - } + return 0 unless $self->$predicate; } - if ($self->$predicate && $attr->has_valid_values) { - unless ($attr->check_valid_value($self, $self->$reader)) { - return "Not a valid value for ".$attr->name; + if ($attr->has_valid_values) { + unless ($predicate && !($self->$predicate)) { + my $reader = $attr->get_read_method; + return 0 unless $attr->check_valid_value($self, $self->$reader); } } - return; # ok - }; + } + return 1; +}; +sub error_for { + my ($self, $attr) = @_; + confess "No attribute passed to error_for" unless defined($attr); + unless (ref($attr)) { + my $meta = $self->meta->find_attribute_by_name($attr); + confess "Can't find attribute ${attr} on $self" unless $meta; + $attr = $meta; + } + return $self->error_for_attribute($attr); +}; +sub error_for_attribute { + my ($self, $attr) = @_; + my $reader = $attr->get_read_method; + my $predicate = $attr->get_predicate_method; + if ($self->attribute_is_required($attr)) { + unless ($self->$predicate) { + return $attr->name." is required"; + } + } + if ($self->$predicate && $attr->has_valid_values) { + unless ($attr->check_valid_value($self, $self->$reader)) { + return "Not a valid value for ".$attr->name; + } + } + return; # ok +}; +sub attribute_is_required { + my ($self, $attr) = @_; + return $attr->is_required; +}; - implements attribute_is_required => as { - my ($self, $attr) = @_; - return $attr->is_required; - }; +sub sync_all { } - sub sync_all { } +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm index ad2f130..405209e 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm @@ -4,10 +4,14 @@ use Reaction::InterfaceModel::Action; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Result is 'Reaction::InterfaceModel::Action', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; - has '+target_model' => (isa => Row); -}; + +has '+target_model' => (isa => Row); + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm index c30b9f6..3f4e818 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm @@ -5,13 +5,14 @@ use aliased 'Reaction::InterfaceModel::Action::Role::SimpleMethodCall'; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Delete is Result, which { - - does SimpleMethodCall; +use namespace::clean -except => [ qw(meta) ]; +extends Result; - implements _target_model_method => as { 'delete' }; +with SimpleMethodCall; +sub _target_model_method { 'delete' }; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm index 3b4c776..78e3146 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm @@ -4,39 +4,39 @@ use aliased 'Reaction::InterfaceModel::Action::DBIC::Result'; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Update is Result, which { - - does 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; - - implements BUILD => as { - my ($self) = @_; - my $tm = $self->target_model; - foreach my $attr ($self->parameter_attributes) { - my $writer = $attr->get_write_method; - my $name = $attr->name; - my $tm_attr = $tm->meta->find_attribute_by_name($name); - next unless ref $tm_attr; - my $tm_reader = $tm_attr->get_read_method; - $self->$writer($tm->$tm_reader) if defined($tm->$tm_reader); - } - }; - - implements do_apply => as { - my $self = shift; - my $args = $self->parameter_hashref; - my $model = $self->target_model; - foreach my $name (keys %$args) { - my $tm_attr = $model->meta->find_attribute_by_name($name); - next unless ref $tm_attr; - my $tm_writer = $tm_attr->get_write_method; - $model->$tm_writer($args->{$name}); - } - $model->update; - return $model; - }; - +use namespace::clean -except => [ qw(meta) ]; +extends Result; + +with 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; +sub BUILD { + my ($self) = @_; + my $tm = $self->target_model; + foreach my $attr ($self->parameter_attributes) { + my $writer = $attr->get_write_method; + my $name = $attr->name; + my $tm_attr = $tm->meta->find_attribute_by_name($name); + next unless ref $tm_attr; + my $tm_reader = $tm_attr->get_read_method; + $self->$writer($tm->$tm_reader) if defined($tm->$tm_reader); + } +}; +sub do_apply { + my $self = shift; + my $args = $self->parameter_hashref; + my $model = $self->target_model; + foreach my $name (keys %$args) { + my $tm_attr = $model->meta->find_attribute_by_name($name); + next unless ref $tm_attr; + my $tm_writer = $tm_attr->get_write_method; + $model->$tm_writer($args->{$name}); + } + $model->update; + return $model; }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm index 3494f9b..eaaafec 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm @@ -5,45 +5,46 @@ use Reaction::Class; use Reaction::InterfaceModel::Action; use Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques; -class Create is 'Reaction::InterfaceModel::Action', which { - - does 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; - - has '+target_model' => (isa => ResultSet); - - implements do_apply => as { - my $self = shift; - my $args = $self->parameter_hashref; - my $new = $self->target_model->new({}); - my @delay; - foreach my $name (keys %$args) { - my $tm_attr = $new->meta->find_attribute_by_name($name); - unless ($tm_attr) { - warn "Unable to find attr for ${name}"; - next; - } - my $tm_writer = $tm_attr->get_write_method; - unless ($tm_writer) { - warn "Unable to find writer for ${name}"; - next; - } - if ($tm_attr->type_constraint->name eq 'ArrayRef' - || $tm_attr->type_constraint->is_subtype_of('ArrayRef')) { - push(@delay, [ $tm_writer, $args->{$name} ]); - } else { - $new->$tm_writer($args->{$name}); - } +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; + +with 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; + +has '+target_model' => (isa => ResultSet); +sub do_apply { + my $self = shift; + my $args = $self->parameter_hashref; + my $new = $self->target_model->new({}); + my @delay; + foreach my $name (keys %$args) { + my $tm_attr = $new->meta->find_attribute_by_name($name); + unless ($tm_attr) { + warn "Unable to find attr for ${name}"; + next; } - $new->insert; - foreach my $d (@delay) { - my ($meth, $val) = @$d; - $new->$meth($val); + my $tm_writer = $tm_attr->get_write_method; + unless ($tm_writer) { + warn "Unable to find writer for ${name}"; + next; } - return $new; - }; - + if ($tm_attr->type_constraint->name eq 'ArrayRef' + || $tm_attr->type_constraint->is_subtype_of('ArrayRef')) { + push(@delay, [ $tm_writer, $args->{$name} ]); + } else { + $new->$tm_writer($args->{$name}); + } + } + $new->insert; + foreach my $d (@delay) { + my ($meth, $val) = @$d; + $new->$meth($val); + } + return $new; }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm index c26e287..b30990b 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm @@ -4,19 +4,22 @@ use Reaction::Types::DBIC 'ResultSet'; use Reaction::Class; use Reaction::InterfaceModel::Action; -class DeleteAll is 'Reaction::InterfaceModel::Action', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; - has '+target_model' => (isa => ResultSet); - sub can_apply { 1 } - implements do_apply => as { - my $self = shift; - return $self->target_model->delete_all; - }; +has '+target_model' => (isa => ResultSet); +sub can_apply { 1 } +sub do_apply { + my $self = shift; + return $self->target_model->delete_all; }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm index e4756fd..1524f8c 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm @@ -2,93 +2,93 @@ package Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques; use Reaction::Role; -role CheckUniques which { - - # requires qw(target_model - # parameter_hashref - # parameter_attributes - # ); - - has _unique_constraint_results => - ( - isa => 'HashRef', - is => 'rw', - required => 1, - default => sub { {} }, - metaclass => 'Reaction::Meta::Attribute' - ); - - implements check_all_uniques => as { - my ($self) = @_; - my $source = $self->target_model->result_source; - my %uniques = $source->unique_constraints; - my $proto = ($self->target_model->isa('DBIx::Class::ResultSet') - ? $self->target_model->new_result({}) - : $self->target_model); - my $param_hr = $self->parameter_hashref; - my %proto_hash = ( - map { - my @ret; - my $attr = $proto->meta->get_attribute($_->name); - if ($attr) { - my $reader = $attr->get_read_method; - if ($reader) { - my $value = $proto->$reader; - if (defined($value)) { - @ret = ($_->name => $value); - } +use namespace::clean -except => [ qw(meta) ]; + + +# requires qw(target_model +# parameter_hashref +# parameter_attributes +# ); + +has _unique_constraint_results => + ( + isa => 'HashRef', + is => 'rw', + required => 1, + default => sub { {} }, + metaclass => 'Reaction::Meta::Attribute' + ); +sub check_all_uniques { + my ($self) = @_; + my $source = $self->target_model->result_source; + my %uniques = $source->unique_constraints; + my $proto = ($self->target_model->isa('DBIx::Class::ResultSet') + ? $self->target_model->new_result({}) + : $self->target_model); + my $param_hr = $self->parameter_hashref; + my %proto_hash = ( + map { + my @ret; + my $attr = $proto->meta->get_attribute($_->name); + if ($attr) { + my $reader = $attr->get_read_method; + if ($reader) { + my $value = $proto->$reader; + if (defined($value)) { + @ret = ($_->name => $value); } } - @ret; - } $self->parameter_attributes - ); - my %merged = ( - %proto_hash, - (map { - (defined $param_hr->{$_} ? ($_ => $param_hr->{$_}) : ()); - } keys %$param_hr), - ); - my %ident = %{$proto->ident_condition}; - my %clashes; - my $rs = $source->resultset; - foreach my $unique (keys %uniques) { - my %pass; - my @attrs = @{$uniques{$unique}}; - next if grep { !exists $merged{$_} } @attrs; - # skip PK before insertion if auto-inc etc. etc. - @pass{@attrs} = @merged{@attrs}; - if (my $obj = $rs->find(\%pass, { key => $unique })) { - my $found_ident = $obj->ident_condition; - #warn join(', ', %$found_ident, %ident); - if (!$proto->in_storage - || (grep { $found_ident->{$_} ne $ident{$_} } keys %ident)) { - # if in storage and no ident conditions are different the found - # obj is *us* :) - $clashes{$_} = 1 for @attrs; - } + } + @ret; + } $self->parameter_attributes + ); + my %merged = ( + %proto_hash, + (map { + (defined $param_hr->{$_} ? ($_ => $param_hr->{$_}) : ()); + } keys %$param_hr), + ); + my %ident = %{$proto->ident_condition}; + my %clashes; + my $rs = $source->resultset; + foreach my $unique (keys %uniques) { + my %pass; + my @attrs = @{$uniques{$unique}}; + next if grep { !exists $merged{$_} } @attrs; + # skip PK before insertion if auto-inc etc. etc. + @pass{@attrs} = @merged{@attrs}; + if (my $obj = $rs->find(\%pass, { key => $unique })) { + my $found_ident = $obj->ident_condition; +#warn join(', ', %$found_ident, %ident); + if (!$proto->in_storage + || (grep { $found_ident->{$_} ne $ident{$_} } keys %ident)) { + # if in storage and no ident conditions are different the found + # obj is *us* :) + $clashes{$_} = 1 for @attrs; } } - $self->_unique_constraint_results(\%clashes); - }; - - after sync_all => sub { shift->check_all_uniques; }; + } + $self->_unique_constraint_results(\%clashes); +}; - override error_for_attribute => sub { - my ($self, $attr) = @_; - if ($self->_unique_constraint_results->{$attr->name}) { - return "Already taken, please try an alternative"; - } - return super(); - }; +after sync_all => sub { shift->check_all_uniques; }; - override can_apply => sub { - my ($self) = @_; - return 0 if keys %{$self->_unique_constraint_results}; - return super(); - }; +override error_for_attribute => sub { + my ($self, $attr) = @_; + if ($self->_unique_constraint_results->{$attr->name}) { + return "Already taken, please try an alternative"; + } + return super(); +}; +override can_apply => sub { + my ($self) = @_; + return 0 if keys %{$self->_unique_constraint_results}; + return super(); }; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm index 3602f86..a18b5c5 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::ChangePassword; use Reaction::Class; -class ChangePassword - is 'Reaction::InterfaceModel::Action::User::ChangePassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::ChangePassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm index 6620d30..169f92c 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::ResetPassword; use Reaction::Class; -class ResetPassword - is 'Reaction::InterfaceModel::Action::User::ResetPassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::ResetPassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm index 0cd41a8..68c3895 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm @@ -2,20 +2,20 @@ package Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword; use Reaction::Role; -role SetPassword, which { +use namespace::clean -except => [ qw(meta) ]; - #requires qw/target_model/; - - implements do_apply => as { - my $self = shift; - my $user = $self->target_model; - $user->password($self->new_password); - $user->update; - return $user; - }; +#requires qw/target_model/; +sub do_apply { + my $self = shift; + my $user = $self->target_model; + $user->password($self->new_password); + $user->update; + return $user; }; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm index b15e218..bca939a 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::SetPassword; use Reaction::Class; -class SetPassword - is 'Reaction::InterfaceModel::Action::User::SetPassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::SetPassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm index 6546502..f637284 100644 --- a/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm @@ -4,38 +4,41 @@ use Reaction::Class; use Reaction::Types::Core qw(Password); -class ChangePassword is 'Reaction::InterfaceModel::Action::User::SetPassword', which { - has old_password => (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'old_password') { - return "Old password incorrect" - unless $self->verify_old_password; - } - #return $super->(@_); #commented out because the original didn't super() - }; - - around can_apply => sub { - my $super = shift; - my ($self) = @_; - return 0 unless $self->verify_old_password; - return $super->(@_); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::SetPassword'; + + +has old_password => (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'old_password') { + return "Old password incorrect" + unless $self->verify_old_password; + } + #return $super->(@_); #commented out because the original didn't super() +}; + +around can_apply => sub { + my $super = shift; + my ($self) = @_; + return 0 unless $self->verify_old_password; + return $super->(@_); +}; +sub verify_old_password { + my $self = shift; + return unless $self->has_old_password; - implements verify_old_password => as { - my $self = shift; - return unless $self->has_old_password; - - my $user = $self->target_model; - return $user->can("check_password") ? + my $user = $self->target_model; + return $user->can("check_password") ? $user->check_password($self->old_password) : $self->old_password eq $user->password; - }; - }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/User/Login.pm b/lib/Reaction/InterfaceModel/Action/User/Login.pm index 46dddea..31abd8b 100644 --- a/lib/Reaction/InterfaceModel/Action/User/Login.pm +++ b/lib/Reaction/InterfaceModel/Action/User/Login.pm @@ -4,28 +4,31 @@ use Reaction::Class; use aliased 'Reaction::InterfaceModel::Action'; use Reaction::Types::Core qw(SimpleStr Password); -class Login, is Action, which { - - has 'username' => (isa => SimpleStr, is => 'rw', lazy_fail => 1); - has 'password' => (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - my $result = $super->(@_); - my $predicate = $attr->get_predicate_method; - if (defined $result && $self->$predicate) { - return 'Invalid username or password'; - } - return; - }; - - implements do_apply => as { - my $self = shift; - my $target = $self->target_model; - return $target->login($self->username, $self->password); - }; +use namespace::clean -except => [ qw(meta) ]; +extends Action; + + + +has 'username' => (isa => SimpleStr, is => 'rw', lazy_fail => 1); +has 'password' => (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + my $result = $super->(@_); + my $predicate = $attr->get_predicate_method; + if (defined $result && $self->$predicate) { + return 'Invalid username or password'; + } + return; +}; +sub do_apply { + my $self = shift; + my $target = $self->target_model; + return $target->login($self->username, $self->password); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm index 2637dc0..3c5d8d6 100644 --- a/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm @@ -9,31 +9,32 @@ use aliased 'Reaction::InterfaceModel::Action::User::SetPassword'; use Reaction::Types::Core qw(NonEmptySimpleStr); -class ResetPassword is SetPassword, which { - - does ConfirmationCodeSupport; - - has confirmation_code => - (isa => NonEmptySimpleStr, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'confirmation_code') { - return "Confirmation code incorrect" - unless $self->verify_confirmation_code; - } - #return $super->(@_); #commented out because the original didn't super() - }; - - implements verify_confirmation_code => as { - my $self = shift; - return $self->has_confirmation_code - && ($self->confirmation_code eq $self->generate_confirmation_code); - }; - +use namespace::clean -except => [ qw(meta) ]; +extends SetPassword; + +with ConfirmationCodeSupport; + +has confirmation_code => + (isa => NonEmptySimpleStr, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'confirmation_code') { + return "Confirmation code incorrect" + unless $self->verify_confirmation_code; + } + #return $super->(@_); #commented out because the original didn't super() +}; +sub verify_confirmation_code { + my $self = shift; + return $self->has_confirmation_code + && ($self->confirmation_code eq $self->generate_confirmation_code); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm index 649f76a..1b85d26 100644 --- a/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm +++ b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm @@ -3,21 +3,21 @@ package Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport; use Reaction::Role; use Digest::MD5; -role ConfirmationCodeSupport, which{ - - #requires qw/target_model ctx/; +use namespace::clean -except => [ qw(meta) ]; + + +#requires qw/target_model ctx/; +sub generate_confirmation_code { + my $self = shift; + my $ident = $self->target_model->identity_string. + $self->target_model->password; + my $secret = $self->ctx->config->{confirmation_code_secret}; + die "Application config does not define confirmation_code_secret" + unless $secret; + return Digest::MD5::md5_hex($secret.$ident); +}; - implements generate_confirmation_code => as { - my $self = shift; - my $ident = $self->target_model->identity_string. - $self->target_model->password; - my $secret = $self->ctx->config->{confirmation_code_secret}; - die "Application config does not define confirmation_code_secret" - unless $secret; - return Digest::MD5::md5_hex($secret.$ident); - }; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm index 14a561a..b9aa5d5 100644 --- a/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm @@ -4,37 +4,40 @@ use Reaction::Class; use Reaction::InterfaceModel::Action; use Reaction::Types::Core qw(Password); -class SetPassword is 'Reaction::InterfaceModel::Action', which { - - has new_password => (isa => Password, is => 'rw', lazy_fail => 1); - has confirm_new_password => - (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'confirm_new_password') { - return "New password doesn't match" - unless $self->verify_confirm_new_password; - } - return $super->(@_); - }; - - around can_apply => sub { - my $super = shift; - my ($self) = @_; - return 0 unless $self->verify_confirm_new_password; - return $super->(@_); - }; - - implements verify_confirm_new_password => as { - my $self = shift; - return $self->has_new_password && $self->has_confirm_new_password - && ($self->new_password eq $self->confirm_new_password); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; + + +has new_password => (isa => Password, is => 'rw', lazy_fail => 1); +has confirm_new_password => + (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'confirm_new_password') { + return "New password doesn't match" + unless $self->verify_confirm_new_password; + } + return $super->(@_); +}; + +around can_apply => sub { + my $super = shift; + my ($self) = @_; + return 0 unless $self->verify_confirm_new_password; + return $super->(@_); +}; +sub verify_confirm_new_password { + my $self = shift; + return $self->has_new_password && $self->has_confirm_new_password + && ($self->new_password eq $self->confirm_new_password); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection.pm b/lib/Reaction/InterfaceModel/Collection.pm index 068e1c0..614e51b 100644 --- a/lib/Reaction/InterfaceModel/Collection.pm +++ b/lib/Reaction/InterfaceModel/Collection.pm @@ -6,73 +6,74 @@ use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute'; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class Collection is "Reaction::InterfaceModel::Object", which { - - # consider supporting slice, first, iterator, last etc. - # pager functionality should probably be a role - - # IM objects don't have write methods because those are handled through actions, - # no support for write actions either unless someone makes a good case for it - # many models may not even be writable, so we cant make that assumption... - - # I feel like we should hasa result_class or object_class ? - # having this here would remove a lot of PITA complexity from - # ObjectClass and SchemaClass when it comes to munging with internals - - #Answer: No, because collections should be able to hold more than one type of object - - # ALL IMPLEMENTATIONS ARE TO ILLUSTRATE POSSIBLE BEHAVIOR ONLY. DON'T CONSIDER - # THEM CORRECT, OR FINAL. JUST A ROUGH DRAFT. - - #domain_models are 'ro' unless otherwise specified - has _collection_store => ( - is => 'rw', - isa => 'ArrayRef', - lazy_build => 1, - clearer => "_clear_collection_store", - metaclass => DomainModelAttribute, - ); - - has 'member_type' => (is => 'ro', isa => 'ClassName'); - - implements _build__collection_store => as { [] }; - - implements members => as { - my $self = shift; - return @{ $self->_collection_store }; - }; - - #return new member or it's index # ? - implements add_member => as { - my $self = shift; - my $new = shift; - confess "Argument passed is not an object" unless blessed $new; - confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" - unless $new->isa('Reaction::InterfaceModel::Object'); - my $store = $self->_collection_store; - push @$store, $new; - return $#$store; #return index # of inserted item - }; - - implements remove_member => as { - my $self = shift; - my $rem = shift; - confess "Argument passed is not an object" unless blessed $rem; - confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" - unless $rem->isa('Reaction::InterfaceModel::Object'); - - my $addr = refaddr $rem; - @{ $self->_collection_store } = grep {$addr ne refaddr $_ } @{ $self->_store }; - }; - - #that was easy.. - implements count_members => sub{ - my $self = shift; - return scalar @{ $self->_collection_store }; - }; +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Object"; + + +# consider supporting slice, first, iterator, last etc. +# pager functionality should probably be a role + +# IM objects don't have write methods because those are handled through actions, +# no support for write actions either unless someone makes a good case for it +# many models may not even be writable, so we cant make that assumption... + +# I feel like we should hasa result_class or object_class ? +# having this here would remove a lot of PITA complexity from +# ObjectClass and SchemaClass when it comes to munging with internals + +#Answer: No, because collections should be able to hold more than one type of object + +# ALL IMPLEMENTATIONS ARE TO ILLUSTRATE POSSIBLE BEHAVIOR ONLY. DON'T CONSIDER +# THEM CORRECT, OR FINAL. JUST A ROUGH DRAFT. + +#domain_models are 'ro' unless otherwise specified +has _collection_store => ( + is => 'rw', + isa => 'ArrayRef', + lazy_build => 1, + clearer => "_clear_collection_store", + metaclass => DomainModelAttribute, + ); + +has 'member_type' => (is => 'ro', isa => 'ClassName'); +sub _build__collection_store { [] }; +sub members { + my $self = shift; + return @{ $self->_collection_store }; }; +#return new member or it's index # ? +sub add_member { + my $self = shift; + my $new = shift; + confess "Argument passed is not an object" unless blessed $new; + confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" + unless $new->isa('Reaction::InterfaceModel::Object'); + my $store = $self->_collection_store; + push @$store, $new; + return $#$store; #return index # of inserted item +}; +sub remove_member { + my $self = shift; + my $rem = shift; + confess "Argument passed is not an object" unless blessed $rem; + confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" + unless $rem->isa('Reaction::InterfaceModel::Object'); + + my $addr = refaddr $rem; + @{ $self->_collection_store } = grep {$addr ne refaddr $_ } @{ $self->_store }; +}; + +#that was easy.. +sub count_members { + my $self = shift; + return scalar @{ $self->_collection_store }; +}; + +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm index 7b82176..b9acae9 100644 --- a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm @@ -6,87 +6,80 @@ use Class::MOP; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -role Base, which { - - has '_source_resultset' => ( - is => 'ro', - required => 1, - isa => 'DBIx::Class::ResultSet', - ); - - has 'member_type' => ( - is => 'rw', - isa => 'ClassName', - required => 1, - builder => '_build_member_type', - clearer => 'clear_member_type', - predicate => 'has_member_type', - ); - - - #implements BUILD => as { - # my $self = shift; - # Class::MOP::load_class($self->_im_class); - # confess "_im_result_class must be a Reaction::InterfaceModel::Object" - # unless $self->_im_class->isa("Reaction::InterfaceModel::Object"); - # confess "_im_result_class must have an inflate_result method" - # unless $self->_im_class->can("inflate_result"); - #}; - - - - #Oh man. I have a bad feeling about this one. - implements _build_member_type => as { - my $self = shift; - my $class = blessed($self) || $self; - $class =~ s/::Collection$//; - return $class; - }; - - implements _build__collection_store => as { - my $self = shift; - [ $self->_source_resultset->search({}, {result_class => $self->member_type})->all ]; - }; - - implements clone => as { - my $self = shift; - my $rs = $self->_source_resultset; #->search_rs({}); - #should the clone include the arrayref of IM::Objects too? - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type, @_ - ); - }; - - implements count_members => as { - my $self = shift; - $self->_source_resultset->count; - }; - - implements add_member => as { - confess "Not yet implemented"; - }; - - implements remove_member => as { - confess "Not yet implemented"; - }; - - - implements page => as { - my $self = shift; - my $rs = $self->_source_resultset->page(@_); - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type, - ); - }; - - implements pager => as { - my $self = shift; - return $self->_source_resultset->pager(@_); - }; - +use namespace::clean -except => [ qw(meta) ]; + + +has '_source_resultset' => ( + is => 'ro', + required => 1, + isa => 'DBIx::Class::ResultSet', + ); + +has 'member_type' => ( + is => 'rw', + isa => 'ClassName', + required => 1, + builder => '_build_member_type', + clearer => 'clear_member_type', + predicate => 'has_member_type', + ); + + +#implements BUILD => as { +# my $self = shift; +# Class::MOP::load_class($self->_im_class); +# confess "_im_result_class must be a Reaction::InterfaceModel::Object" +# unless $self->_im_class->isa("Reaction::InterfaceModel::Object"); +# confess "_im_result_class must have an inflate_result method" +# unless $self->_im_class->can("inflate_result"); +#}; + + + +#Oh man. I have a bad feeling about this one. +sub _build_member_type { + my $self = shift; + my $class = blessed($self) || $self; + $class =~ s/::Collection$//; + return $class; +}; +sub _build__collection_store { + my $self = shift; + [ $self->_source_resultset->search({}, {result_class => $self->member_type})->all ]; +}; +sub clone { + my $self = shift; + my $rs = $self->_source_resultset; #->search_rs({}); + #should the clone include the arrayref of IM::Objects too? + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type, @_ + ); +}; +sub count_members { + my $self = shift; + $self->_source_resultset->count; +}; +sub add_member { + confess "Not yet implemented"; }; +sub remove_member { + confess "Not yet implemented"; +}; +sub page { + my $self = shift; + my $rs = $self->_source_resultset->page(@_); + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type, + ); +}; +sub pager { + my $self = shift; + return $self->_source_resultset->pager(@_); +}; + + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm index c5459ae..c612cb8 100644 --- a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm @@ -3,35 +3,35 @@ package Reaction::InterfaceModel::Collection::DBIC::Role::Where; use Reaction::Role; use Scalar::Util qw/blessed/; -role Where, which { - - #requires qw/_source_resultset _im_class/; - implements where => as { - my $self = shift; - my $rs = $self->_source_resultset->search_rs(@_); - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type - ); - }; - - implements add_where => as { - my $self = shift; - my $rs = $self->_source_resultset->search_rs(@_); - $self->_source_resultset($rs); - $self->_clear_collection_store if $self->_has_collection_store; - 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->member_type}) - ->find(@_); - }; +use namespace::clean -except => [ qw(meta) ]; + + +#requires qw/_source_resultset _im_class/; +sub where { + my $self = shift; + my $rs = $self->_source_resultset->search_rs(@_); + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type + ); +}; +sub add_where { + my $self = shift; + my $rs = $self->_source_resultset->search_rs(@_); + $self->_source_resultset($rs); + $self->_clear_collection_store if $self->_has_collection_store; + return $self; }; +#XXX may need a rename, but i needed this for ListView +sub find { + my $self = shift; + $self->_source_resultset + ->search({},{result_class => $self->member_type}) + ->find(@_); +}; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent.pm b/lib/Reaction/InterfaceModel/Collection/Persistent.pm index d023a6c..ebf1fc9 100644 --- a/lib/Reaction/InterfaceModel/Collection/Persistent.pm +++ b/lib/Reaction/InterfaceModel/Collection/Persistent.pm @@ -3,10 +3,14 @@ package Reaction::InterfaceModel::Collection::Persistent; use Reaction::Class; use aliased 'Reaction::InterfaceModel::Collection'; -class Persistent is Collection, which { +use namespace::clean -except => [ qw(meta) ]; +extends Collection; -}; + + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm index a73e5cc..6ca63fb 100644 --- a/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm +++ b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm @@ -4,11 +4,13 @@ use Reaction::Class; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class ResultSet is "Reaction::InterfaceModel::Collection::Persistent", which{ +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Collection::Persistent"; - does "Reaction::InterfaceModel::Collection::DBIC::Role::Base"; +with "Reaction::InterfaceModel::Collection::DBIC::Role::Base"; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual.pm b/lib/Reaction/InterfaceModel/Collection/Virtual.pm index df81496..6a958b6 100644 --- a/lib/Reaction/InterfaceModel/Collection/Virtual.pm +++ b/lib/Reaction/InterfaceModel/Collection/Virtual.pm @@ -3,10 +3,14 @@ package Reaction::InterfaceModel::Collection::Virtual; use Reaction::Class; use aliased 'Reaction::InterfaceModel::Collection'; -class Virtual is Collection, which { +use namespace::clean -except => [ qw(meta) ]; +extends Collection; -}; + + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm index 5c905d7..41a4b36 100644 --- a/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm +++ b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm @@ -3,17 +3,17 @@ package Reaction::InterfaceModel::Collection::Virtual::ResultSet; use Reaction::Class; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class ResultSet is "Reaction::InterfaceModel::Collection::Virtual", which { - - does "Reaction::InterfaceModel::Collection::DBIC::Role::Base", - "Reaction::InterfaceModel::Collection::DBIC::Role::Where"; +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Collection::Virtual"; +with "Reaction::InterfaceModel::Collection::DBIC::Role::Base", + "Reaction::InterfaceModel::Collection::DBIC::Role::Where"; +sub _build__default_action_class_prefix { + shift->member_type; +}; - implements _build__default_action_class_prefix => as { - shift->member_type; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Object.pm b/lib/Reaction/InterfaceModel/Object.pm index fce4fd2..cd3c3db 100644 --- a/lib/Reaction/InterfaceModel/Object.pm +++ b/lib/Reaction/InterfaceModel/Object.pm @@ -4,74 +4,73 @@ use metaclass 'Reaction::Meta::InterfaceModel::Object::Class'; use Reaction::Meta::Attribute; use Reaction::Class; -class Object which { - - has _action_class_map => - (is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, - metaclass => 'Reaction::Meta::Attribute'); - - has _default_action_class_prefix => - ( - is => 'ro', - isa => 'Str', - lazy_build => 1, - metaclass => 'Reaction::Meta::Attribute', - ); - - #DBIC::Collection would override this to use result_class for example - implements _build__default_action_class_prefix => as { - my $self = shift; - ref $self || $self; - }; - - #just a little convenience - implements parameter_attributes => as { - shift->meta->parameter_attributes; - }; - - #just a little convenience - implements domain_models => as { - shift->meta->domain_models; - }; - - 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 : - $self->_build__default_action_class_prefix; - - return join "::", $prefix, 'Action', $action; - }; - - implements '_action_class_for' => as { - my ($self, $action) = @_; - confess("Wrong arguments") unless $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) = @_; - confess("Wrong arguments") unless $action; - 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); - }; - - #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 { {} }; +use namespace::clean -except => [ qw(meta) ]; + +has _action_class_map => + (is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, + metaclass => 'Reaction::Meta::Attribute'); + +has _default_action_class_prefix => + ( + is => 'ro', + isa => 'Str', + lazy_build => 1, + metaclass => 'Reaction::Meta::Attribute', + ); + +#DBIC::Collection would override this to use result_class for example +sub _build__default_action_class_prefix { + my $self = shift; + ref $self || $self; +}; + +#just a little convenience +sub parameter_attributes { + shift->meta->parameter_attributes; +}; + +#just a little convenience +sub domain_models { + shift->meta->domain_models; }; +sub _default_action_class_for { + 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 : + $self->_build__default_action_class_prefix; + + return join "::", $prefix, 'Action', $action; +}; +sub _action_class_for { + my ($self, $action) = @_; + confess("Wrong arguments") unless $action; + if (defined (my $class = $self->_action_class_map->{$action})) { + return $class; + } + return $self->_default_action_class_for($action); +}; +sub action_for { + my ($self, $action, %args) = @_; + confess("Wrong arguments") unless $action; + 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); +}; + +#this really needs to be smarter, fine for CRUD, shit for anything else +# massive fucking reworking needed here, really +sub _default_action_args_for { {} }; +sub _override_action_args_for { {} }; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/ObjectClass.pm b/lib/Reaction/InterfaceModel/ObjectClass.pm index 2ea5fb6..b2f70fb 100644 --- a/lib/Reaction/InterfaceModel/ObjectClass.pm +++ b/lib/Reaction/InterfaceModel/ObjectClass.pm @@ -5,18 +5,17 @@ use Reaction::Class; use Reaction::InterfaceModel::Object; -class ObjectClass which { - - overrides default_base => sub { ('Reaction::InterfaceModel::Object') }; - - overrides exports_for_package => sub { - my ($self, $package) = @_; - return (super(), - domain_model => sub { - $package->meta->add_domain_model(@_); - }, - ); - }; +use namespace::clean -except => [ qw(meta) ]; +override default_base => sub { ('Reaction::InterfaceModel::Object') }; +override exports_for_package => sub { + my ($self, $package) = @_; + return (super(), + domain_model => sub { + $package->meta->add_domain_model(@_); + }, + ); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm index cde8c79..4d14edd 100644 --- a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm +++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm @@ -13,757 +13,500 @@ use Class::MOP; use Catalyst::Utils; -class DBIC, which { - - has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 }); - - #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 = "_" . $self->_class_to_attribute_name($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 = "_" . $self->_class_to_attribute_name($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); +use namespace::clean -except => [ qw(meta) ]; + + +has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 }); + +#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); +sub _build_object_actions { {} }; +sub _build_collection_actions { {} }; +sub _build_default_object_actions { [ qw/Update Delete/ ] }; +sub _build_default_collection_actions { [ qw/Create DeleteAll/ ] }; +sub _build_builtin_object_actions { + { + Update => { name => 'Update', base => Update }, + Delete => { name => 'Delete', base => Delete, attributes => [] }, }; - - 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; +}; +sub _build_builtin_collection_actions { + { + Create => {name => 'Create', base => Create }, + DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] } }; - - implements merge_reflect_rules => as { - my ($self, $rules, $needles, $haystack, $local_opts) = @_; +}; +sub _all_object_actions { + my $self = shift; + return $self->merge_hashes + ($self->builtin_object_actions, $self->object_actions); +}; +sub _all_collection_actions { + my $self = shift; + return $self->merge_hashes + ($self->builtin_collection_actions, $self->collection_actions); +}; +sub dm_name_from_class_name { + my($self, $class) = @_; + confess("wrong arguments") unless $class; + $class =~ s/::/_/g; + $class = "_" . $self->_class_to_attribute_name($class) . "_store"; + return $class; +}; +sub dm_name_from_source_name { + my($self, $source) = @_; + confess("wrong arguments") unless $source; + $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $source = "_" . $self->_class_to_attribute_name($source) . "_store"; + return $source; +}; +sub class_name_from_source_name { + my ($self, $model_class, $source_name) = @_; + confess("wrong arguments") unless $model_class && $source_name; + return join "::", $model_class, $source_name; +}; +sub class_name_for_collection_of { + my ($self, $object_class) = @_; + confess("wrong arguments") unless $object_class; + return "${object_class}::Collection"; +}; +sub merge_hashes { + my($self, $left, $right) = @_; + return Catalyst::Utils::merge_hashes($left, $right); +}; +sub parse_reflect_rules { + 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 && ( 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); + 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; }; - 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( $base ); - Class::MOP::load_class( $schema ); - my $meta = $self->_load_or_create($model, $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; + @$haystack = grep { !$check_exclude->($_) } @$haystack; + $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts); + return $needles; +}; +sub merge_reflect_rules { + 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); } - - my $sources = $self->parse_reflect_rules($rules, $haystack); - - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; - $meta->make_mutable if $meta->is_immutable; - - $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 - ); + } +}; +sub reflect_schema { + 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( $base ); + Class::MOP::load_class( $schema ); + my $meta = $self->_load_or_create($model, $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 $sources = $self->parse_reflect_rules($rules, $haystack); + + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; + $meta->make_mutable if $meta->is_immutable; + + $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; +}; +sub _compute_source_options { + 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) }; } - $meta->make_immutable if $make_immutable; - return $meta; - }; - - 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_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; - } + 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; - } + } + 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; } - #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; + 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; } - - 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; - my $meta = $model->meta; - - unless( $collection ){ - my $object = $self->class_name_from_source_name($model, $source); - $collection = $self->class_name_for_collection_of($object); + #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; } - unless( $reader ){ - $reader = $source; - $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; - $reader = $self->_class_to_attribute_name($reader) . "_collection"; + + 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, + }; +}; +sub _class_to_attribute_name { + 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)) +}; +sub add_source { + 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 = $self->_class_to_attribute_name($reader) . "_collection"; + } + unless( $dm_name ){ + my @haystack = $meta->domain_models; + if( @haystack > 1 ){ + @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack; } - 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."); - } + 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, - required => 1, - isa => $collection, - reader => $reader, - predicate => "has_" . $self->_class_to_attribute_name($name) , - domain_model => $dm_name, - orig_attr_name => $source, - default => sub { - $collection->new - ( - _source_resultset => $_[0]->$dm_name->resultset($source), - _parent => $_[0], - ); - }, - ); - - 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; - }; - - 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( - %opts, - model_class => delete $opts{parent_class}, - domain_model_name => delete $opts{parent_domain_model_name}, - collection_class => $col_meta->name, - ); + } + + 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 => sub { + $collection->new + ( + _source_resultset => $_[0]->$dm_name->resultset($source), + _parent => $_[0], + ); + }, + ); + + 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; +}; +sub reflect_source { + 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( + %opts, + model_class => delete $opts{parent_class}, + domain_model_name => delete $opts{parent_domain_model_name}, + collection_class => $col_meta->name, + ); +}; +sub reflect_source_collection { + 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); + + Class::MOP::load_class( $base ); + Class::MOP::load_class( $object ); + my $meta = $self->_load_or_create($class, $base); + + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; + $meta->make_mutable if $meta->is_immutable; + $meta->add_method(_build_member_type => sub{ $object } ); + #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); - 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); - - Class::MOP::load_class( $base ); - Class::MOP::load_class( $object ); - my $meta = $self->_load_or_create($class, $base); - - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; - $meta->make_mutable if $meta->is_immutable; - $meta->add_method(_build_member_type => sub{ $object } ); - #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; - } - # 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( - 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); - } + { + 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; } - $meta->make_immutable if $make_immutable; - return $meta; - }; - - 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 = $self->_load_or_create($class, $base); - - #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; - my $make_immutable = $meta->is_immutable || $self->make_classes_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'); - $class->new($dm_name, $src->result_class->inflate_result(@_)); + # 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( + 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_method('inflate_result', $inflate_method); - } - - #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 Action, 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} || {}}, - ); - } - } - - { - 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( - 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); - } + $meta->add_around_method_modifier('_default_action_args_for', $act_args); } + } + $meta->make_immutable if $make_immutable; + return $meta; +}; +sub reflect_source_object { + my($self, %opts) = @_; + %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; - $meta->make_immutable if $make_immutable; - return $meta; - }; + 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} || {}; - # 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 $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 $meta = $opts{class}->meta; - my $attr_opts = $self->parameters_for_source_object_attribute(%opts); + my $action_rules = delete $opts{actions}; + my $attr_rules = delete $opts{attributes}; - my $make_immutable = $meta->is_immutable; - $meta->make_mutable if $meta->is_immutable; + $class ||= $self->class_name_from_source_name($parent, $source_name); - my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts); + Class::MOP::load_class($parent); + Class::MOP::load_class($schema) if $schema; + Class::MOP::load_class($source_class); - $meta->make_immutable if $make_immutable; - return $attr; - }; + my $meta = $self->_load_or_create($class, $base); - # 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("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; - } - } + #create the domain model + $dm_name ||= $self->dm_name_from_source_name($source_name); - my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); - my $reader = $from_attr->get_read_method; - - #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}" => - sub { defined(shift->$dm_name->$reader) } - }, - domain_model => $dm_name, - orig_attr_name => $attr_name, - ); - - #m2m / has_many - my $m2m_meta; - if(my $coderef = $source->result_class->can('_m2m_metadata')){ - $m2m_meta = $source->result_class->$coderef; - } + $dm_opts->{isa} = $source_class; + $dm_opts->{is} ||= 'rw'; + $dm_opts->{required} ||= 1; - 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); - $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 - 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; - }"; - } - } 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); + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; + $meta->make_mutable if $meta->is_immutable; - #proper collections will remove the result_class uglyness. - $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 $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts); + my $dm_reader = $dm_attr->get_read_method; - 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} = eval "sub{ shift->${dm_name}->${reader} }"; - } - return \%attr_opts; + unless( $class->can('inflate_result') ){ + my $inflate_method = sub { + my $class = shift; my ($src) = @_; + $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle'); + $class->new($dm_name, $src->result_class->inflate_result(@_)); + }; + $meta->add_method('inflate_result', $inflate_method); + } + + #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 Action, 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); - - 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, 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->parameter_attributes ]; + 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') ){ @@ -775,143 +518,377 @@ class DBIC, which { || !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 $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 $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; + } - my $o_meta = $object->meta; - my $s_meta = $source->meta; - my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); + # 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( + 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); + } + } - #create the class - my $meta = $self->_load_or_create($class, $base); - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; - $meta->make_mutable if $meta->is_immutable; + $meta->make_immutable if $make_immutable; + return $meta; +}; - 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); - 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 - ); - $meta->add_attribute( $attr_name => %$attr_params); - } +# needs class, attribute_name domain_model_name +sub reflect_source_object_attribute { + 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" ); + } - $meta->make_immutable if $make_immutable; - return $meta; - }; + my $meta = $opts{class}->meta; + my $attr_opts = $self->parameters_for_source_object_attribute(%opts); - 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 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); - - #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n"; - - 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; - } - } + 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; + return $attr; +}; - my $m2m_meta; - if(my $coderef = $source_class->result_class->can('_m2m_metadata')){ - $m2m_meta = $source_class->result_class->$coderef; +# needs class, attribute_name domain_model_name +sub parameters_for_source_object_attribute { + 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("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); + my $reader = $from_attr->get_read_method; + + #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}" => + sub { defined(shift->$dm_name->$reader) } + }, + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + + #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'); + + 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); + $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 + 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; + }"; } - #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' || $rel_accessor eq 'filter') { - $attr_opts{valid_values} = sub { - shift->target_model->result_source->related_source($attr_name)->resultset; - }; + } 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. + $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} = eval "sub{ shift->${dm_name}->${reader} }"; + } + return \%attr_opts; +}; +sub reflect_source_action { + 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, 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->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 $o_meta = $object->meta; + my $s_meta = $source->meta; + my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); + + #create the class + my $meta = $self->_load_or_create($class, $base); + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; + $meta->make_mutable if $meta->is_immutable; + + 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); + 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 + ); + $meta->add_attribute( $attr_name => %$attr_params); + } + + $meta->make_immutable if $make_immutable; + return $meta; +}; +sub parameters_for_source_object_action_attribute { + 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 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); + + #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n"; + + 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; } - } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { - my $mm_name = $1; - my $link_table = "links_to_${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 { [] }; + } + + + 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' || + $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' || $rel_accessor eq 'filter') { $attr_opts{valid_values} = sub { - shift->target_model->result_source->related_source($rel) - ->related_source($far_rel)->resultset; + shift->target_model->result_source->related_source($attr_name)->resultset; }; } - #use Data::Dumper; - #print STDERR "\n" .$attr_name ." - ". $object . "\n"; - #print STDERR Dumper(\%attr_opts); - return \%attr_opts; - }; - - implements _load_or_create => as { - my ($self, $class, $base) = @_; - my $meta = $self->_maybe_load_class($class) ? - $class->meta : $base->meta->create($class, superclasses => [ $base ]); - return $meta; - }; + } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { + my $mm_name = $1; + my $link_table = "links_to_${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"; + #print STDERR Dumper(\%attr_opts); + return \%attr_opts; +}; +sub _load_or_create { + my ($self, $class, $base) = @_; + my $meta = $self->_maybe_load_class($class) ? + $class->meta : $base->meta->create($class, superclasses => [ $base ]); + return $meta; +}; +sub _maybe_load_class { + my ($self, $class) = @_; + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + my $ret = eval { Class::MOP::load_class($class) }; + if ($INC{$file} && $@) { + confess "Error loading ${class}: $@"; + } + return $ret; +}; - implements _maybe_load_class => as { - my ($self, $class) = @_; - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - my $ret = eval { Class::MOP::load_class($class) }; - if ($INC{$file} && $@) { - confess "Error loading ${class}: $@"; - } - return $ret; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/Meta/InterfaceModel/Action/Class.pm b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm index c09bdb6..5937573 100644 --- a/lib/Reaction/Meta/InterfaceModel/Action/Class.pm +++ b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm @@ -3,24 +3,25 @@ package Reaction::Meta::InterfaceModel::Action::Class; use Reaction::Class; use aliased 'Reaction::Meta::InterfaceModel::Action::ParameterAttribute'; -class Class is 'Reaction::Meta::Class', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Meta::Class'; - implements new => as { shift->SUPER::new(@_) }; +sub new { shift->SUPER::new(@_) }; - around initialize => sub { - my $super = shift; - my $class = shift; - my $pkg = shift; - $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); - }; +around initialize => sub { + my $super = shift; + my $class = shift; + my $pkg = shift; + $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); +}; +sub parameter_attributes { + my $self = shift; + return grep { $_->isa(ParameterAttribute) } + $self->compute_all_applicable_attributes; +}; - implements parameter_attributes => as { - my $self = shift; - return grep { $_->isa(ParameterAttribute) } - $self->compute_all_applicable_attributes; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm index 6c2a651..793bb46 100644 --- a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm +++ b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm @@ -3,66 +3,65 @@ package Reaction::Meta::InterfaceModel::Action::ParameterAttribute; use Reaction::Class; use Scalar::Util 'blessed'; -class ParameterAttribute is 'Reaction::Meta::Attribute', which { - has valid_values => ( - isa => 'CodeRef', - is => 'rw', # doesnt need of it anymore, maybe we should warn before change it - predicate => 'has_valid_values' - ); - - implements new => as { shift->SUPER::new(@_); }; # work around immutable - - implements check_valid_value => as { - my ($self, $object, $value) = @_; - confess "Can't check_valid_value when no valid_values set" - unless $self->has_valid_values; - confess join " - ", blessed($object), $self->name - unless ref $self->valid_values; - my $valid = $self->valid_values->($object, $self); - if ($self->type_constraint - && ($self->type_constraint->name eq 'ArrayRef' - || $self->type_constraint->is_subtype_of('ArrayRef'))) { - confess "Parameter type is array ref but passed value isn't" - unless ref($value) eq 'ARRAY'; - return [ map { $self->_check_single_valid($valid => $_) } @$value ]; - } else { - return $self->_check_single_valid($valid => $value); - } - }; - - implements _check_single_valid => as { - my ($self, $valid, $value) = @_; - return undef unless defined($value); - if (ref $valid eq 'ARRAY') { - return $value if grep { $_ eq $value } @$valid; - } else { - $value = $value->ident_condition if blessed($value); - return $valid->find($value); - } - return undef; # XXX this is an assumption that undef is never valid - }; - - implements all_valid_values => as { - my ($self, $object) = @_; - confess "Can't call all_valid_values on an attribute without valid_values" - unless $self->has_valid_values; - my $valid = $self->valid_values->($object, $self); - return ((ref $valid eq 'ARRAY') - ? @$valid - : $valid->all); - }; - - implements valid_value_collection => as { - my ($self, $object) = @_; - confess "Can't call valid_value_collection on an attribute without valid_values" - unless $self->has_valid_values; - my $valid = $self->valid_values->($object, $self); - confess "valid_values returned an arrayref, not a collection" - if (ref $valid eq 'ARRAY'); - return $valid; - }; - +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Meta::Attribute'; + + +has valid_values => ( + isa => 'CodeRef', + is => 'rw', # doesnt need of it anymore, maybe we should warn before change it + predicate => 'has_valid_values' +); +sub new { shift->SUPER::new(@_); }; # work around immutable +sub check_valid_value { + my ($self, $object, $value) = @_; + confess "Can't check_valid_value when no valid_values set" + unless $self->has_valid_values; + confess join " - ", blessed($object), $self->name + unless ref $self->valid_values; + my $valid = $self->valid_values->($object, $self); + if ($self->type_constraint + && ($self->type_constraint->name eq 'ArrayRef' + || $self->type_constraint->is_subtype_of('ArrayRef'))) { + confess "Parameter type is array ref but passed value isn't" + unless ref($value) eq 'ARRAY'; + return [ map { $self->_check_single_valid($valid => $_) } @$value ]; + } else { + return $self->_check_single_valid($valid => $value); + } +}; +sub _check_single_valid { + my ($self, $valid, $value) = @_; + return undef unless defined($value); + if (ref $valid eq 'ARRAY') { + return $value if grep { $_ eq $value } @$valid; + } else { + $value = $value->ident_condition if blessed($value); + return $valid->find($value); + } + return undef; # XXX this is an assumption that undef is never valid +}; +sub all_valid_values { + my ($self, $object) = @_; + confess "Can't call all_valid_values on an attribute without valid_values" + unless $self->has_valid_values; + my $valid = $self->valid_values->($object, $self); + return ((ref $valid eq 'ARRAY') + ? @$valid + : $valid->all); }; +sub valid_value_collection { + my ($self, $object) = @_; + confess "Can't call valid_value_collection on an attribute without valid_values" + unless $self->has_valid_values; + my $valid = $self->valid_values->($object, $self); + confess "valid_values returned an arrayref, not a collection" + if (ref $valid eq 'ARRAY'); + return $valid; +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/Meta/InterfaceModel/Object/Class.pm b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm index 8fad3dc..912af6e 100644 --- a/lib/Reaction/Meta/InterfaceModel/Object/Class.pm +++ b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm @@ -5,36 +5,35 @@ use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute'; use Reaction::Class; -class Class is 'Reaction::Meta::Class', which { - - implements new => as { shift->SUPER::new(@_) }; - - around initialize => sub { - my $super = shift; - my $class = shift; - my $pkg = shift; - $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); - }; - - implements add_domain_model => as{ - my $self = shift; - my $name = shift; - $self->add_attribute($name, metaclass => DomainModelAttribute, @_); - }; - - implements parameter_attributes => as { - my $self = shift; - return grep { $_->isa(ParameterAttribute) } - $self->compute_all_applicable_attributes; - }; - - implements domain_models => as { - my $self = shift; - return grep { $_->isa(DomainModelAttribute) } - $self->compute_all_applicable_attributes; - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Meta::Class'; +sub new { shift->SUPER::new(@_) }; + +around initialize => sub { + my $super = shift; + my $class = shift; + my $pkg = shift; + $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); +}; +sub add_domain_model { + my $self = shift; + my $name = shift; + $self->add_attribute($name, metaclass => DomainModelAttribute, @_); +}; +sub parameter_attributes { + my $self = shift; + return grep { $_->isa(ParameterAttribute) } + $self->compute_all_applicable_attributes; }; +sub domain_models { + my $self = shift; + return grep { $_->isa(DomainModelAttribute) } + $self->compute_all_applicable_attributes; +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm index ba1e9cc..1d43266 100644 --- a/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm +++ b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm @@ -2,12 +2,15 @@ package Reaction::Meta::InterfaceModel::Object::DomainModelAttribute; use Reaction::Class; -class DomainModelAttribute is 'Reaction::Meta::Attribute', which { - #i feel like something should happen here, but i aint got nothin. +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Meta::Attribute'; - implements new => as { shift->SUPER::new(@_); }; # work around immutable -}; +#i feel like something should happen here, but i aint got nothin. +sub new { shift->SUPER::new(@_); }; # work around immutable + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm index 835fa09..ebe16e1 100644 --- a/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm +++ b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm @@ -2,21 +2,24 @@ package Reaction::Meta::InterfaceModel::Object::ParameterAttribute; use Reaction::Class; -class ParameterAttribute is 'Reaction::Meta::Attribute', which { - has domain_model => ( - isa => 'Str', - is => 'ro', - predicate => 'has_domain_model' - ); - - has orig_attr_name => ( - isa => 'Str', - is => 'ro', - predicate => 'has_orig_attr_name' - ); - - implements new => as { shift->SUPER::new(@_); }; # work around immutable -}; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::Meta::Attribute'; + + +has domain_model => ( + isa => 'Str', + is => 'ro', + predicate => 'has_domain_model' +); + +has orig_attr_name => ( + isa => 'Str', + is => 'ro', + predicate => 'has_orig_attr_name' +); +sub new { shift->SUPER::new(@_); }; # work around immutable +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/Role.pm b/lib/Reaction/Role.pm index f5e89b5..ea09925 100644 --- a/lib/Reaction/Role.pm +++ b/lib/Reaction/Role.pm @@ -7,34 +7,35 @@ use Moose::Meta::Class; #TODO: review for Reaction::Object switch / Reaction::Meta::Class -class Role which { +use namespace::clean -except => [ qw(meta) ]; - override exports_for_package => sub { - my ($self, $package) = @_; - my %exports = $self->SUPER::exports_for_package($package); - delete $exports{class}; - $exports{role} = sub { $self->do_role_sub($package, @_); }; - return %exports; - }; - override next_import_package => sub { 'Moose::Role' }; - - override default_base => sub { () }; +override exports_for_package => sub { + my ($self, $package) = @_; + my %exports = $self->SUPER::exports_for_package($package); + delete $exports{class}; + $exports{role} = sub { $self->do_role_sub($package, @_); }; + return %exports; +}; - override add_method_to_target => sub { - my ($self, $target, $method) = @_; - $target->meta->alias_method(@$method); - }; +override next_import_package => sub { 'Moose::Role' }; - implements do_role_sub => as { - my ($self, $package, $role, $which, $setup) = @_; - confess "Invalid role declaration, should be: role Role which { ... }" - unless ($which eq 'which' && ref($setup) eq 'CODE'); - $self->setup_and_cleanup($role, $setup); - }; +override default_base => sub { () }; +override add_method_to_target => sub { + my ($self, $target, $method) = @_; + $target->meta->alias_method(@$method); +}; +sub do_role_sub { + my ($self, $package, $role, $which, $setup) = @_; + confess "Invalid role declaration, should be: role Role which { ... }" + unless ($which eq 'which' && ref($setup) eq 'CODE'); + $self->setup_and_cleanup($role, $setup); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/UI/FocusStack.pm b/lib/Reaction/UI/FocusStack.pm index b786636..e582d9f 100644 --- a/lib/Reaction/UI/FocusStack.pm +++ b/lib/Reaction/UI/FocusStack.pm @@ -2,77 +2,75 @@ package Reaction::UI::FocusStack; use Reaction::Class; -class FocusStack which { - - has vp_head => ( - isa => 'Reaction::UI::ViewPort', is => 'rw', - clearer => 'clear_vp_head', - ); - has vp_tail => ( - isa => 'Reaction::UI::ViewPort', is => 'rw', - clearer => 'clear_vp_tail', - ); - has vp_count => ( - isa => 'Int', is => 'rw', required => 1, default => sub { 0 } - ); - has loc_prefix => (isa => 'Str', is => 'rw', predicate => 'has_loc_prefix'); - - implements push_viewport => as { - my ($self, $class, %create) = @_; - my $tail = $self->vp_tail; - my $loc = $self->vp_count; - if ($self->has_loc_prefix) { - $loc = join('.', $self->loc_prefix, $loc); - } - my $vp = $class->new( - %create, - location => $loc, - focus_stack => $self, - (defined $tail ? ( outer => $tail ) : ()), # XXX possibly a bug in - #immutable? - ); - if ($tail) { # if we already have a tail (non-empty vp stack) - $tail->inner($vp); # set the current tail's inner vp to the new vp - } else { # else we're currently an empty stack - $self->vp_head($vp); # so set the head to the new vp - } - $self->vp_count($self->vp_count + 1); - $self->vp_tail($vp); - return $vp; - }; - - implements pop_viewport => as { - my ($self) = @_; - my $head = $self->vp_head; - confess "Can't pop from empty focus stack" unless defined($head); - my $vp = $self->vp_tail; - if ($vp eq $head) { - $self->clear_vp_head; - $self->clear_vp_tail; - } else { - $self->vp_tail($vp->outer); - } - $self->vp_count($self->vp_count - 1); - return $vp; - }; - - implements pop_viewports_to => as { - my ($self, $vp) = @_; - 1 while ($self->pop_viewport ne $vp); - return $vp; - }; +use namespace::clean -except => [ qw(meta) ]; + + +has vp_head => ( + isa => 'Reaction::UI::ViewPort', is => 'rw', + clearer => 'clear_vp_head', +); +has vp_tail => ( + isa => 'Reaction::UI::ViewPort', is => 'rw', + clearer => 'clear_vp_tail', +); +has vp_count => ( + isa => 'Int', is => 'rw', required => 1, default => sub { 0 } +); +has loc_prefix => (isa => 'Str', is => 'rw', predicate => 'has_loc_prefix'); +sub push_viewport { + my ($self, $class, %create) = @_; + my $tail = $self->vp_tail; + my $loc = $self->vp_count; + if ($self->has_loc_prefix) { + $loc = join('.', $self->loc_prefix, $loc); + } + my $vp = $class->new( + %create, + location => $loc, + focus_stack => $self, + (defined $tail ? ( outer => $tail ) : ()), # XXX possibly a bug in + #immutable? + ); + if ($tail) { # if we already have a tail (non-empty vp stack) + $tail->inner($vp); # set the current tail's inner vp to the new vp + } else { # else we're currently an empty stack + $self->vp_head($vp); # so set the head to the new vp + } + $self->vp_count($self->vp_count + 1); + $self->vp_tail($vp); + return $vp; +}; +sub pop_viewport { + my ($self) = @_; + my $head = $self->vp_head; + confess "Can't pop from empty focus stack" unless defined($head); + my $vp = $self->vp_tail; + if ($vp eq $head) { + $self->clear_vp_head; + $self->clear_vp_tail; + } else { + $self->vp_tail($vp->outer); + } + $self->vp_count($self->vp_count - 1); + return $vp; +}; +sub pop_viewports_to { + my ($self, $vp) = @_; + 1 while ($self->pop_viewport ne $vp); + return $vp; +}; +sub apply_events { + my $self = shift; + my $vp = $self->vp_tail; + while (defined $vp) { + $vp->apply_events(@_); + $vp = $vp->outer; + } +}; - implements apply_events => as { - my $self = shift; - my $vp = $self->vp_tail; - while (defined $vp) { - $vp->apply_events(@_); - $vp = $vp->outer; - } - }; - -}; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/LayoutSet.pm b/lib/Reaction/UI/LayoutSet.pm index edb0952..a976d5b 100644 --- a/lib/Reaction/UI/LayoutSet.pm +++ b/lib/Reaction/UI/LayoutSet.pm @@ -3,107 +3,103 @@ package Reaction::UI::LayoutSet; use Reaction::Class; use File::Spec; -class LayoutSet which { +use namespace::clean -except => [ qw(meta) ]; - has 'layouts' => (is => 'ro', default => sub { {} }); - has 'name' => (is => 'ro', required => 1); +has 'layouts' => (is => 'ro', default => sub { {} }); - has 'source_file' => (is => 'ro', required => 1); +has 'name' => (is => 'ro', required => 1); - has 'widget_class' => ( - is => 'rw', lazy_fail => 1, predicate => 'has_widget_class' - ); - - has 'widget_type' => (is => 'rw', lazy_build => 1); +has 'source_file' => (is => 'ro', required => 1); - has 'super' => (is => 'rw', predicate => 'has_super'); +has 'widget_class' => ( + is => 'rw', lazy_fail => 1, predicate => 'has_widget_class' +); - implements 'BUILD' => as { - my ($self, $args) = @_; - my @path = @{$args->{search_path}||[]}; - confess "No skin object provided" unless $args->{skin}; - confess "No top skin object provided" unless $args->{top_skin}; - $self->_load_file($self->source_file, $args); - unless ($self->has_widget_class) { - $self->widget_class($args->{skin}->widget_class_for($self)); - } - }; +has 'widget_type' => (is => 'rw', lazy_build => 1); - implements 'widget_order_for' => as { - my ($self, $name) = @_; - return ( - ($self->has_layout($name) - ? ([ $self->widget_class, $self ]) #; - : ()), +has 'super' => (is => 'rw', predicate => 'has_super'); +sub BUILD { + my ($self, $args) = @_; + my @path = @{$args->{search_path}||[]}; + confess "No skin object provided" unless $args->{skin}; + confess "No top skin object provided" unless $args->{top_skin}; + $self->_load_file($self->source_file, $args); + unless ($self->has_widget_class) { + $self->widget_class($args->{skin}->widget_class_for($self)); + } +}; +sub widget_order_for { + my ($self, $name) = @_; + return ( + ($self->has_layout($name) + ? ([ $self->widget_class, $self ]) #; + : ()), + ($self->has_super + ? ($self->super->widget_order_for($name)) + : ()), + ); +}; +sub layout_names { + my ($self) = @_; + my %seen; + return [ + grep { !$seen{$_}++ } + keys %{shift->layouts}, ($self->has_super - ? ($self->super->widget_order_for($name)) - : ()), - ); - }; - - implements 'layout_names' => as { - my ($self) = @_; - my %seen; - return [ - grep { !$seen{$_}++ } - keys %{shift->layouts}, - ($self->has_super - ? (@{$self->super->layout_names}) - : ()) - ]; - }; - - implements 'has_layout' => as { exists $_[0]->layouts->{$_[1]} }; - - implements '_load_file' => as { - my ($self, $file, $build_args) = @_; - my $data = $file->slurp; - my $layouts = $self->layouts; - # cheesy match for "=for layout name ... =something" - # final split group also handles last in file, (?==) is lookahead - # assertion for '=' so "=for layout name1 ... =for layout name2" - # doesn't have the match pos go past the latter = and lose name2 - while ($data =~ m/=(.*?)\n(.*?)(?:\n(?==)|$)/sg) { - my ($data, $text) = ($1, $2); - if ($data =~ /^for layout (\S+)/) { - my $fname = $1; - $text =~ s/^(?:\s*\r?\n)+//; #remove leading empty lines - $text =~ s/[\s\r\n]+$//; #remove trailing whitespace - $layouts->{$fname} = $text; - } elsif ($data =~ /^extends (\S+)/) { - my $super_name = $1; - my $skin; - if ($super_name eq 'NEXT') { - confess "No next skin and layout extends NEXT" - unless $build_args->{next_skin}; - $skin = $build_args->{next_skin}; - $super_name = $self->name; - } else { - $skin = $build_args->{top_skin}; - } - $self->super($skin->create_layout_set($super_name)); - } elsif ($data =~ /^widget (\S+)/) { - my $widget_type = $1; - $self->widget_type($1); - } elsif ($data =~ /^cut/) { - # no-op + ? (@{$self->super->layout_names}) + : ()) + ]; +}; +sub has_layout { exists $_[0]->layouts->{$_[1]} }; +sub _load_file { + my ($self, $file, $build_args) = @_; + my $data = $file->slurp; + my $layouts = $self->layouts; + # cheesy match for "=for layout name ... =something" + # final split group also handles last in file, (?==) is lookahead + # assertion for '=' so "=for layout name1 ... =for layout name2" + # doesn't have the match pos go past the latter = and lose name2 + while ($data =~ m/=(.*?)\n(.*?)(?:\n(?==)|$)/sg) { + my ($data, $text) = ($1, $2); + if ($data =~ /^for layout (\S+)/) { + my $fname = $1; + $text =~ s/^(?:\s*\r?\n)+//; #remove leading empty lines + $text =~ s/[\s\r\n]+$//; #remove trailing whitespace + $layouts->{$fname} = $text; + } elsif ($data =~ /^extends (\S+)/) { + my $super_name = $1; + my $skin; + if ($super_name eq 'NEXT') { + confess "No next skin and layout extends NEXT" + unless $build_args->{next_skin}; + $skin = $build_args->{next_skin}; + $super_name = $self->name; } else { - confess "Unparseable directive ${data} in ${file}"; + $skin = $build_args->{top_skin}; } + $self->super($skin->create_layout_set($super_name)); + } elsif ($data =~ /^widget (\S+)/) { + my $widget_type = $1; + $self->widget_type($1); + } elsif ($data =~ /^cut/) { + # no-op + } else { + confess "Unparseable directive ${data} in ${file}"; } - }; + } +}; +sub _build_widget_type { + my ($self) = @_; + my $widget = join('', map { ucfirst($_) } split('_', $self->name)); + $widget = join('::', map { ucfirst($_) } split('/', $widget)); - implements '_build_widget_type' => as { - my ($self) = @_; - my $widget = join('', map { ucfirst($_) } split('_', $self->name)); - $widget = join('::', map { ucfirst($_) } split('/', $widget)); + #print STDERR "--- ", $self->name, " maps to widget $widget \n"; - #print STDERR "--- ", $self->name, " maps to widget $widget \n"; + return $widget; +}; - return $widget; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/LayoutSet/TT.pm b/lib/Reaction/UI/LayoutSet/TT.pm index 68d6749..fbdf569 100644 --- a/lib/Reaction/UI/LayoutSet/TT.pm +++ b/lib/Reaction/UI/LayoutSet/TT.pm @@ -4,41 +4,43 @@ use Reaction::Class; use aliased 'Reaction::UI::LayoutSet'; use aliased 'Template::View'; -class TT is LayoutSet, which { +use namespace::clean -except => [ qw(meta) ]; +extends LayoutSet; - has 'tt_view' => (is => 'rw', isa => View, lazy_fail => 1); - implements 'BUILD' => as { - my ($self, $args) = @_; - # Do this at build time rather than on demand so any exception if it - # goes wrong gets thrown sometime sensible +has 'tt_view' => (is => 'rw', isa => View, lazy_fail => 1); +sub BUILD { + my ($self, $args) = @_; - $self->tt_view($self->_build_tt_view($args)); - }; + # Do this at build time rather than on demand so any exception if it + # goes wrong gets thrown sometime sensible - implements '_build_tt_view' => as { - my ($self, $args) = @_; - my $tt_object = $args->{tt_object} - || confess "tt_object not provided to new()"; - my $tt_args = { data => {} }; - my $name = $self->name; - $name =~ s/\//__/g; #slashes are not happy here... - my $layouts = $self->layouts; - - my $tt_source = join("\n", "[%- VIEW ${name};", - (map {("BLOCK $_; -%]" . $layouts->{$_} ."[%- END;") } keys %$layouts), - "END; # End view\ndata.view = ${name}; -%]" ); + $self->tt_view($self->_build_tt_view($args)); +}; +sub _build_tt_view { + my ($self, $args) = @_; + my $tt_object = $args->{tt_object} + || confess "tt_object not provided to new()"; + my $tt_args = { data => {} }; + my $name = $self->name; + $name =~ s/\//__/g; #slashes are not happy here... + my $layouts = $self->layouts; + + my $tt_source = join("\n", "[%- VIEW ${name};", + (map {("BLOCK $_; -%]" . $layouts->{$_} ."[%- END;") } keys %$layouts), + "END; # End view\ndata.view = ${name}; -%]" ); + + $tt_object->process(\$tt_source, $tt_args) + || confess "Template processing error: ".$tt_object->error + ." processing:\n${tt_source}"; + confess "View template processed but no view object found" + ." after processing:\n${tt_source}" + unless $tt_args->{data}{view}; + return $tt_args->{data}{view}; +}; - $tt_object->process(\$tt_source, $tt_args) - || confess "Template processing error: ".$tt_object->error - ." processing:\n${tt_source}"; - confess "View template processed but no view object found" - ." after processing:\n${tt_source}" - unless $tt_args->{data}{view}; - return $tt_args->{data}{view}; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/RenderingContext.pm b/lib/Reaction/UI/RenderingContext.pm index 1c990b9..b1dea94 100644 --- a/lib/Reaction/UI/RenderingContext.pm +++ b/lib/Reaction/UI/RenderingContext.pm @@ -2,12 +2,12 @@ package Reaction::UI::RenderingContext; use Reaction::Class; -class RenderingContext which { +use namespace::clean -except => [ qw(meta) ]; +sub render { + confess "abstract method"; +}; - implements 'render' => as { - confess "abstract method"; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/RenderingContext/TT.pm b/lib/Reaction/UI/RenderingContext/TT.pm index c69fe18..a29d8d4 100644 --- a/lib/Reaction/UI/RenderingContext/TT.pm +++ b/lib/Reaction/UI/RenderingContext/TT.pm @@ -4,65 +4,67 @@ use Reaction::Class; use aliased 'Reaction::UI::RenderingContext'; use aliased 'Template::View'; -class TT is RenderingContext, which { +use namespace::clean -except => [ qw(meta) ]; +extends RenderingContext; - our $body; - implements 'dispatch' => as { - my ($self, $render_tree, $args) = @_; + +our $body; +sub dispatch { + my ($self, $render_tree, $args) = @_; #warn "-- dispatch start\n"; - local $body = ''; - my %args_copy = %$args; - foreach my $to_render (@$render_tree) { - my ($type, @to) = @$to_render; - if ($type eq '-layout') { - my ($lset, $fname, $next) = @to; - local $args_copy{call_next} = - (@$next - ? sub { $self->dispatch($next, $args); } - : '' # no point running internal dispatch if nothing -to- dispatch - ); - $self->render($lset, $fname, \%args_copy); - } elsif ($type eq '-render') { - my ($widget, $fname, $over) = @to; - #warn "@to"; - if (defined $over) { - my $count = 0; - $over->each(sub { - local $args_copy{_} = $_[0]; - local $args_copy{count} = ++$count; - $body .= $widget->render($fname, $self, \%args_copy); - }); - } else { + local $body = ''; + my %args_copy = %$args; + foreach my $to_render (@$render_tree) { + my ($type, @to) = @$to_render; + if ($type eq '-layout') { + my ($lset, $fname, $next) = @to; + local $args_copy{call_next} = + (@$next + ? sub { $self->dispatch($next, $args); } + : '' # no point running internal dispatch if nothing -to- dispatch + ); + $self->render($lset, $fname, \%args_copy); + } elsif ($type eq '-render') { + my ($widget, $fname, $over) = @to; + #warn "@to"; + if (defined $over) { + my $count = 0; + $over->each(sub { + local $args_copy{_} = $_[0]; + local $args_copy{count} = ++$count; $body .= $widget->render($fname, $self, \%args_copy); - } + }); + } else { + $body .= $widget->render($fname, $self, \%args_copy); } } + } #warn "-- dispatch end, body: ${body}\n-- end body\nbacktrace: ".Carp::longmess()."\n-- end trace\n"; - return $body; - }; - - implements 'render' => as { - my ($self, $lset, $fname, $args) = @_; + return $body; +}; +sub render { + my ($self, $lset, $fname, $args) = @_; - confess "\$body not in scope" unless defined($body); - - # foreach non-_ prefixed key in the args - # build a subref for this key that passes self so the generator has a - # rendering context when [% key %] is evaluated by TT as $val->() - # (assuming it's a subref - if not just pass through) - - my $tt_args = { - map { - my $arg = $args->{$_}; - ($_ => (ref $arg eq 'CODE' ? sub { $arg->($self, $args) } : $arg)) - } grep { !/^_/ } keys %$args - }; - - $body .= $lset->tt_view->include($fname, $tt_args); -#warn "rendered ${fname}, body length now ".length($body)."\n"; + confess "\$body not in scope" unless defined($body); + + # foreach non-_ prefixed key in the args + # build a subref for this key that passes self so the generator has a + # rendering context when [% key %] is evaluated by TT as $val->() + # (assuming it's a subref - if not just pass through) + + my $tt_args = { + map { + my $arg = $args->{$_}; + ($_ => (ref $arg eq 'CODE' ? sub { $arg->($self, $args) } : $arg)) + } grep { !/^_/ } keys %$args }; + $body .= $lset->tt_view->include($fname, $tt_args); +#warn "rendered ${fname}, body length now ".length($body)."\n"; }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/Skin.pm b/lib/Reaction/UI/Skin.pm index 7ecece8..e5233cf 100644 --- a/lib/Reaction/UI/Skin.pm +++ b/lib/Reaction/UI/Skin.pm @@ -10,185 +10,177 @@ use File::Basename; use aliased 'Path::Class::Dir'; -class Skin which { - - has '_layout_set_cache' => (is => 'ro', default => sub { {} }); - has '_widget_class_cache' => (is => 'ro', default => sub { {} }); - - has 'name' => (is => 'ro', isa => 'Str', required => 1); - has 'skin_dir' => (is => 'rw', isa => Dir, lazy_fail => 1); - - has 'widget_search_path' => ( - is => 'rw', isa => 'ArrayRef', requred => 1, default => sub { [] } - ); - - has 'view' => ( - is => 'ro', required => 1, weak_ref => 1, - handles => [ qw(layout_set_class) ], - ); - - has 'super' => ( - is => 'rw', isa => Skin, required => 0, predicate => 'has_super', - ); - - sub BUILD { - my ($self, $args) = @_; - $self->_find_skin_dir($args); - $self->_load_skin_config($args); - } - - implements '_find_skin_dir' => as { - my ($self, $args) = @_; - my $skin_name = $self->name; - if ($skin_name =~ s!^/(.*?)/!!) { - my $dist = $1; - $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; - } +use namespace::clean -except => [ qw(meta) ]; + + +has '_layout_set_cache' => (is => 'ro', default => sub { {} }); +has '_widget_class_cache' => (is => 'ro', default => sub { {} }); + +has 'name' => (is => 'ro', isa => 'Str', required => 1); +has 'skin_dir' => (is => 'rw', isa => Dir, lazy_fail => 1); + +has 'widget_search_path' => ( + is => 'rw', isa => 'ArrayRef', requred => 1, default => sub { [] } +); + +has 'view' => ( + is => 'ro', required => 1, weak_ref => 1, + handles => [ qw(layout_set_class) ], +); + +has 'super' => ( + is => 'rw', isa => Skin, required => 0, predicate => 'has_super', +); + +sub BUILD { + my ($self, $args) = @_; + $self->_find_skin_dir($args); + $self->_load_skin_config($args); +} +sub _find_skin_dir { + my ($self, $args) = @_; + my $skin_name = $self->name; + if ($skin_name =~ s!^/(.*?)/!!) { + my $dist = $1; + $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}" - unless -d $base; - $self->skin_dir($base); - }; - - implements '_load_skin_config' => as { - my ($self, $args) = @_; - my $base = $self->skin_dir; - my $lst = sub { (ref $_[0] eq 'ARRAY') ? $_[0] : [$_[0]] }; - my @files = ( - $args->{skin_base_dir}->file('defaults.conf'), $base->file('skin.conf') + } + my $base = $args->{skin_base_dir}->subdir($skin_name); + confess "No such skin base directory ${base}" + unless -d $base; + $self->skin_dir($base); +}; +sub _load_skin_config { + my ($self, $args) = @_; + my $base = $self->skin_dir; + my $lst = sub { (ref $_[0] eq 'ARRAY') ? $_[0] : [$_[0]] }; + my @files = ( + $args->{skin_base_dir}->file('defaults.conf'), $base->file('skin.conf') + ); + # we get [ { $file => $conf }, ... ] + my %cfg = (map { %{(values %{$_})[0]} } + @{Config::Any->load_files({ + files => [ grep { -e $_ } @files ], + use_ext => 1, + })} + ); + if (my $super_name = $cfg{extends}) { + my $super = $self->new( + name => $super_name, + view => $self->view, + skin_base_dir => $args->{skin_base_dir}, ); - # we get [ { $file => $conf }, ... ] - my %cfg = (map { %{(values %{$_})[0]} } - @{Config::Any->load_files({ - files => [ grep { -e $_ } @files ], - use_ext => 1, - })} - ); - if (my $super_name = $cfg{extends}) { - my $super = $self->new( - name => $super_name, - view => $self->view, - skin_base_dir => $args->{skin_base_dir}, - ); - $self->super($super); - } - if (exists $cfg{widget_search_path}) { - $self->widget_search_path($lst->($cfg{widget_search_path})); - } else { - confess "No widget_search_path in defaults.conf or skin.conf" - ." and no search path provided from super skin" - unless $self->full_widget_search_path; - } + $self->super($super); } - - implements 'create_layout_set' => as { - my ($self, $name) = @_; - $self->_create_layout_set($name, [], $self); - }; - - implements '_create_layout_set' => as { - my ($self, $name, $tried, $top_skin) = @_; - if (my $path = $self->layout_path_for($name)) { - return $self->layout_set_class->new( - $self->layout_set_args_for($name), - source_file => $path, - top_skin => $top_skin, - ); - } - $tried = [ @{$tried}, $self->our_path_for_type('layout') ]; - if ($self->has_super) { - return $self->super->_create_layout_set($name, $tried, $top_skin); + if (exists $cfg{widget_search_path}) { + $self->widget_search_path($lst->($cfg{widget_search_path})); + } else { + confess "No widget_search_path in defaults.conf or skin.conf" + ." and no search path provided from super skin" + unless $self->full_widget_search_path; + } +} +sub create_layout_set { + my ($self, $name) = @_; + $self->_create_layout_set($name, [], $self); +}; +sub _create_layout_set { + my ($self, $name, $tried, $top_skin) = @_; + if (my $path = $self->layout_path_for($name)) { + return $self->layout_set_class->new( + $self->layout_set_args_for($name), + source_file => $path, + top_skin => $top_skin, + ); + } + $tried = [ @{$tried}, $self->our_path_for_type('layout') ]; + if ($self->has_super) { + return $self->super->_create_layout_set($name, $tried, $top_skin); + } + confess "Couldn't find layout set file for ${name}, tried " + .join(', ', @$tried); +}; +sub layout_set_args_for { + my ($self, $name) = @_; + return ( + name => $name, + skin => $self, + ($self->has_super ? (next_skin => $self->super) : ()), + $self->view->layout_set_args_for($name), + ); +}; +sub layout_path_for { + my ($self, $layout) = @_; + my $file_name = join( + '.', $layout, $self->view->layout_set_file_extension + ); + my $path = $self->our_path_for_type('layout') + ->file($file_name); + return (-e $path ? $path : undef); +}; +sub search_path_for_type { + my ($self, $type) = @_; + return [ + $self->our_path_for_type($type), + ($self->has_super + ? @{$self->super->search_path_for_type($type)} + : () + ) + ]; +}; +sub our_path_for_type { + my ($self, $type) = @_; + return $self->skin_dir->subdir($type) +}; +sub full_widget_search_path { + my ($self) = @_; + return ( + @{$self->widget_search_path}, + ($self->has_super ? $self->super->full_widget_search_path : ()) + ); +}; +sub widget_class_for { + my ($self, $layout_set) = @_; + my $base = blessed($self); + my $widget_type = $layout_set->widget_type; + return $self->_widget_class_cache->{$widget_type} ||= do { + + my @search_path = $self->full_widget_search_path; + my @haystack = map {join('::', $_, $widget_type)} @search_path; + + foreach my $class (@haystack) { + #if the class is already loaded skip the call to Installed etc. + return $class if Class::MOP::is_class_loaded($class); + next unless Class::Inspector->installed($class); + + my $ok = eval { Class::MOP::load_class($class) }; + confess("Failed to load widget '${class}': $@") if $@; + return $class; } - confess "Couldn't find layout set file for ${name}, tried " - .join(', ', @$tried); - }; - - implements 'layout_set_args_for' => as { - my ($self, $name) = @_; - return ( - name => $name, - skin => $self, - ($self->has_super ? (next_skin => $self->super) : ()), - $self->view->layout_set_args_for($name), - ); - }; - - implements 'layout_path_for' => as { - my ($self, $layout) = @_; - my $file_name = join( - '.', $layout, $self->view->layout_set_file_extension - ); - my $path = $self->our_path_for_type('layout') - ->file($file_name); - return (-e $path ? $path : undef); - }; - - implements 'search_path_for_type' => as { - my ($self, $type) = @_; - return [ - $self->our_path_for_type($type), - ($self->has_super - ? @{$self->super->search_path_for_type($type)} - : () - ) - ]; - }; - - implements 'our_path_for_type' => as { - my ($self, $type) = @_; - return $self->skin_dir->subdir($type) - }; - - implements 'full_widget_search_path' => as { - my ($self) = @_; - return ( - @{$self->widget_search_path}, - ($self->has_super ? $self->super->full_widget_search_path : ()) - ); + confess "Couldn't locate widget '${widget_type}' for layout " + ."'${\$layout_set->name}': tried: ".join(", ", @haystack); }; +}; - implements 'widget_class_for' => as { - my ($self, $layout_set) = @_; - my $base = blessed($self); - my $widget_type = $layout_set->widget_type; - return $self->_widget_class_cache->{$widget_type} ||= do { - - my @search_path = $self->full_widget_search_path; - my @haystack = map {join('::', $_, $widget_type)} @search_path; - - foreach my $class (@haystack) { - #if the class is already loaded skip the call to Installed etc. - return $class if Class::MOP::is_class_loaded($class); - next unless Class::Inspector->installed($class); - - my $ok = eval { Class::MOP::load_class($class) }; - confess("Failed to load widget '${class}': $@") if $@; - return $class; - } - confess "Couldn't locate widget '${widget_type}' for layout " - ."'${\$layout_set->name}': tried: ".join(", ", @haystack); - }; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/View.pm b/lib/Reaction/UI/View.pm index fd26870..db95e7b 100644 --- a/lib/Reaction/UI/View.pm +++ b/lib/Reaction/UI/View.pm @@ -8,133 +8,122 @@ use Reaction::UI::RenderingContext; use aliased 'Reaction::UI::Skin'; use aliased 'Path::Class::Dir'; -class View which { +use namespace::clean -except => [ qw(meta) ]; - has '_widget_cache' => (is => 'ro', default => sub { {} }); - has '_layout_set_cache' => (is => 'ro', default => sub { {} }); +has '_widget_cache' => (is => 'ro', default => sub { {} }); - has 'app' => (is => 'ro', required => 1); +has '_layout_set_cache' => (is => 'ro', default => sub { {} }); - has 'skin_name' => (is => 'ro', required => 1, default => 'default'); +has 'app' => (is => 'ro', required => 1); - has 'skin' => ( - is => 'ro', lazy_build => 1, - handles => [ qw(create_layout_set search_path_for_type) ] - ); - - has 'layout_set_class' => (is => 'ro', lazy_build => 1); - - has 'rendering_context_class' => (is => 'ro', lazy_build => 1); - - implements '_build_layout_set_class' => as { - my ($self) = @_; - return $self->find_related_class('LayoutSet'); - }; - - implements '_build_rendering_context_class' => as { - my ($self) = @_; - return $self->find_related_class('RenderingContext'); - }; - - implements '_build_skin' => as { - my ($self) = @_; - Skin->new( - name => $self->skin_name, view => $self, - # path_to returns a File, not a Dir. Thanks, Catalyst. - skin_base_dir => Dir->new($self->app->path_to('share', 'skin')), - ); - }; - - implements 'COMPONENT' => as { - my ($class, $app, $args) = @_; - return $class->new(%{$args||{}}, app => $app); - }; +has 'skin_name' => (is => 'ro', required => 1, default => 'default'); - implements 'render_window' => as { - my ($self, $window) = @_; - my $root_vp = $window->focus_stack->vp_head; - my $rctx = $self->create_rendering_context; - my ($widget, $args) = $self->render_viewport_args($root_vp); - $widget->render(widget => $rctx, $args); - }; +has 'skin' => ( + is => 'ro', lazy_build => 1, + handles => [ qw(create_layout_set search_path_for_type) ] +); - implements 'render_viewport_args' => as { - my ($self, $vp) = @_; - my $layout_set = $self->layout_set_for($vp); - my $widget = $self->widget_for($vp, $layout_set); - return ($widget, { viewport => $vp }); - }; +has 'layout_set_class' => (is => 'ro', lazy_build => 1); - implements 'widget_for' => as { - my ($self, $vp, $layout_set) = @_; - return - $self->_widget_cache->{$layout_set->name} - ||= $layout_set->widget_class - ->new( - view => $self, layout_set => $layout_set - ); - }; - - implements 'layout_set_for' => as { - my ($self, $vp) = @_; - my $lset_name = eval { $vp->layout }; - confess "Couldn't call layout method on \$vp arg ${vp}: $@" if $@; - $lset_name = $self->layout_set_name_from_viewport( blessed($vp) ) - unless (length($lset_name)); - my $cache = $self->_layout_set_cache; - return $cache->{$lset_name} ||= $self->create_layout_set($lset_name); - }; - - #XXX if it ever comes to it: this could be memoized. not bothering yet. - implements 'layout_set_name_from_viewport' => as { - my ($self, $class) = @_; - my ($last) = ($class =~ /.*(?:::ViewPort::)(.+?)$/); - #split when a non-uppercase letter meets an uppercase or when an - #uppercase letter is followed by another uppercase and then a non-uppercase - #FooBar = foo_bar; Foo_Bar = foo_bar; FOOBar = foo_bar; FooBAR = foo_bar - my @fragments = map { - join("_", split(/(?:(?<=[A-Z])(?=[A-Z][^_A-Z])|(?<=[^_A-Z])(?=[A-Z]))/, $_)) - } split('::', $last); - return lc(join('/', @fragments)); - }; - - implements 'layout_set_file_extension' => as { - confess View." is abstract, you must subclass it"; - }; +has 'rendering_context_class' => (is => 'ro', lazy_build => 1); +sub _build_layout_set_class { + my ($self) = @_; + return $self->find_related_class('LayoutSet'); +}; +sub _build_rendering_context_class { + my ($self) = @_; + return $self->find_related_class('RenderingContext'); +}; +sub _build_skin { + my ($self) = @_; + Skin->new( + name => $self->skin_name, view => $self, + # path_to returns a File, not a Dir. Thanks, Catalyst. + skin_base_dir => Dir->new($self->app->path_to('share', 'skin')), + ); +}; +sub COMPONENT { + my ($class, $app, $args) = @_; + return $class->new(%{$args||{}}, app => $app); +}; +sub render_window { + my ($self, $window) = @_; + my $root_vp = $window->focus_stack->vp_head; + my $rctx = $self->create_rendering_context; + my ($widget, $args) = $self->render_viewport_args($root_vp); + $widget->render(widget => $rctx, $args); +}; +sub render_viewport_args { + my ($self, $vp) = @_; + my $layout_set = $self->layout_set_for($vp); + my $widget = $self->widget_for($vp, $layout_set); + return ($widget, { viewport => $vp }); +}; +sub widget_for { + my ($self, $vp, $layout_set) = @_; + return + $self->_widget_cache->{$layout_set->name} + ||= $layout_set->widget_class + ->new( + view => $self, layout_set => $layout_set + ); +}; +sub layout_set_for { + my ($self, $vp) = @_; + my $lset_name = eval { $vp->layout }; + confess "Couldn't call layout method on \$vp arg ${vp}: $@" if $@; + $lset_name = $self->layout_set_name_from_viewport( blessed($vp) ) + unless (length($lset_name)); + my $cache = $self->_layout_set_cache; + return $cache->{$lset_name} ||= $self->create_layout_set($lset_name); +}; - implements 'find_related_class' => as { - my ($self, $rel) = @_; - my $own_class = ref($self) || $self; - confess View." is abstract, you must subclass it" if $own_class eq View; - foreach my $super ($own_class->meta->class_precedence_list) { - next if $super eq View; - if ($super =~ /::View::/) { - (my $class = $super) =~ s/::View::/::${rel}::/; - if (eval { Class::MOP::load_class($class) }) { - return $class; - } +#XXX if it ever comes to it: this could be memoized. not bothering yet. +sub layout_set_name_from_viewport { + my ($self, $class) = @_; + my ($last) = ($class =~ /.*(?:::ViewPort::)(.+?)$/); + #split when a non-uppercase letter meets an uppercase or when an + #uppercase letter is followed by another uppercase and then a non-uppercase + #FooBar = foo_bar; Foo_Bar = foo_bar; FOOBar = foo_bar; FooBAR = foo_bar + my @fragments = map { + join("_", split(/(?:(?<=[A-Z])(?=[A-Z][^_A-Z])|(?<=[^_A-Z])(?=[A-Z]))/, $_)) + } split('::', $last); + return lc(join('/', @fragments)); +}; +sub layout_set_file_extension { + confess View." is abstract, you must subclass it"; +}; +sub find_related_class { + my ($self, $rel) = @_; + my $own_class = ref($self) || $self; + confess View." is abstract, you must subclass it" if $own_class eq View; + foreach my $super ($own_class->meta->class_precedence_list) { + next if $super eq View; + if ($super =~ /::View::/) { + (my $class = $super) =~ s/::View::/::${rel}::/; + if (eval { Class::MOP::load_class($class) }) { + return $class; } } - confess "Unable to find related ${rel} class for ${own_class}"; - }; - - implements 'create_rendering_context' => as { - my ($self, @args) = @_; - return $self->rendering_context_class->new( - $self->rendering_context_args_for(@args), - @args, - ); - }; - - implements 'rendering_context_args_for' => as { - return (); - }; + } + confess "Unable to find related ${rel} class for ${own_class}"; +}; +sub create_rendering_context { + my ($self, @args) = @_; + return $self->rendering_context_class->new( + $self->rendering_context_args_for(@args), + @args, + ); +}; +sub rendering_context_args_for { + return (); +}; +sub layout_set_args_for { + return (); +}; - implements 'layout_set_args_for' => as { - return (); - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/View/TT.pm b/lib/Reaction/UI/View/TT.pm index af282e4..d1e1168 100644 --- a/lib/Reaction/UI/View/TT.pm +++ b/lib/Reaction/UI/View/TT.pm @@ -4,35 +4,35 @@ use Reaction::Class; use aliased 'Reaction::UI::View'; use Template; -class TT is View, which { - - has '_tt' => (isa => 'Template', is => 'rw', lazy_fail => 1); - - implements 'BUILD' => as { - my ($self, $args) = @_; - my $tt_args = $args->{tt}||{}; - $self->_tt(Template->new($tt_args)); - }; - - overrides 'layout_set_args_for' => sub { - my ($self) = @_; - return (super(), tt_object => $self->_tt); - }; - - implements layout_set_file_extension => as { 'tt' }; - - implements 'serve_static_file' => as { - my ($self, $c, $args) = @_; - foreach my $path (@{$self->search_path_for_type('web')}) { - my $cand = $path->file(@$args); - if ($cand->stat) { - $c->serve_static_file($cand); - return 1; - } - } - return 0; - }; +use namespace::clean -except => [ qw(meta) ]; +extends View; + + +has '_tt' => (isa => 'Template', is => 'rw', lazy_fail => 1); +sub BUILD { + my ($self, $args) = @_; + my $tt_args = $args->{tt}||{}; + $self->_tt(Template->new($tt_args)); +}; +override 'layout_set_args_for' => sub { + my ($self) = @_; + return (super(), tt_object => $self->_tt); }; +sub layout_set_file_extension { 'tt' }; +sub serve_static_file { + my ($self, $c, $args) = @_; + foreach my $path (@{$self->search_path_for_type('web')}) { + my $cand = $path->file(@$args); + if ($cand->stat) { + $c->serve_static_file($cand); + return 1; + } + } + return 0; +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort.pm b/lib/Reaction/UI/ViewPort.pm index 02a1390..41fb935 100644 --- a/lib/Reaction/UI/ViewPort.pm +++ b/lib/Reaction/UI/ViewPort.pm @@ -3,144 +3,133 @@ package Reaction::UI::ViewPort; use Reaction::Class; use Scalar::Util qw/blessed/; -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 { {} }); - has outer => (isa => 'Reaction::UI::ViewPort', is => 'rw', weak_ref => 1); - has inner => (isa => 'Reaction::UI::ViewPort', is => 'rw'); - has focus_stack => ( - isa => 'Reaction::UI::FocusStack', is => 'rw', weak_ref => 1 - ); - has _tangent_stacks => ( - isa => 'HashRef', is => 'ro', default => sub { {} } - ); - has ctx => (isa => 'Catalyst', is => 'ro'); #, required => 1); - - implements _build_layout => as { - ''; - }; - - implements create_tangent => as { - my ($self, $name) = @_; - my $t_map = $self->_tangent_stacks; - if (exists $t_map->{$name}) { - confess "Can't create tangent with already existing name ${name}"; - } - my $loc = join('.', $self->location, $name); - my $tangent = Reaction::UI::FocusStack->new(loc_prefix => $loc); - $t_map->{$name} = $tangent; +use namespace::clean -except => [ qw(meta) ]; + + +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 { {} }); +has outer => (isa => 'Reaction::UI::ViewPort', is => 'rw', weak_ref => 1); +has inner => (isa => 'Reaction::UI::ViewPort', is => 'rw'); +has focus_stack => ( + isa => 'Reaction::UI::FocusStack', is => 'rw', weak_ref => 1 +); +has _tangent_stacks => ( + isa => 'HashRef', is => 'ro', default => sub { {} } +); +has ctx => (isa => 'Catalyst', is => 'ro'); #, required => 1); +sub _build_layout { + ''; +}; +sub create_tangent { + my ($self, $name) = @_; + my $t_map = $self->_tangent_stacks; + if (exists $t_map->{$name}) { + confess "Can't create tangent with already existing name ${name}"; + } + my $loc = join('.', $self->location, $name); + my $tangent = Reaction::UI::FocusStack->new(loc_prefix => $loc); + $t_map->{$name} = $tangent; + return $tangent; +}; +sub focus_tangent { + my ($self, $name) = @_; + if (my $tangent = $self->_tangent_stacks->{$name}) { return $tangent; - }; - - implements focus_tangent => as { - my ($self, $name) = @_; - if (my $tangent = $self->_tangent_stacks->{$name}) { - return $tangent; - } else { - return; - } - }; - - implements focus_tangents => as { - return keys %{shift->_tangent_stacks}; - }; - - implements child_event_sinks => as { - my $self = shift; - return values %{$self->_tangent_stacks}; - }; - - implements apply_events => as { - my ($self, $ctx, $events) = @_; - return unless keys %$events; - $self->apply_child_events($ctx, $events); - $self->apply_our_events($ctx, $events); - }; - - implements apply_child_events => as { - my ($self, $ctx, $events) = @_; - return unless keys %$events; - foreach my $child ($self->child_event_sinks) { - confess blessed($child) ."($child) is not a valid object" - unless blessed($child) && $child->can('apply_events'); - $child->apply_events($ctx, $events); - } - }; - - implements apply_our_events => as { - my ($self, $ctx, $events) = @_; - my @keys = keys %$events; - return unless @keys; - my $loc = $self->location; - my %our_events; - foreach my $key (keys %$events) { - if ($key =~ m/^${loc}:(.*)$/) { - $our_events{$1} = $events->{$key}; - } - } - if (keys %our_events) { - #warn "$self: events ".join(', ', %our_events)."\n"; - $self->handle_events(\%our_events); - } - }; - - implements handle_events => as { - my ($self, $events) = @_; - my $exists = exists $events->{exists}; - if ($exists) { - my %force = $self->force_events; - my @need = grep { !exists $events->{$_} } keys %force; - @{$events}{@need} = @force{@need}; + } else { + return; + } +}; +sub focus_tangents { + return keys %{shift->_tangent_stacks}; +}; +sub child_event_sinks { + my $self = shift; + return values %{$self->_tangent_stacks}; +}; +sub apply_events { + my ($self, $ctx, $events) = @_; + return unless keys %$events; + $self->apply_child_events($ctx, $events); + $self->apply_our_events($ctx, $events); +}; +sub apply_child_events { + my ($self, $ctx, $events) = @_; + return unless keys %$events; + foreach my $child ($self->child_event_sinks) { + confess blessed($child) ."($child) is not a valid object" + unless blessed($child) && $child->can('apply_events'); + $child->apply_events($ctx, $events); + } +}; +sub apply_our_events { + my ($self, $ctx, $events) = @_; + my @keys = keys %$events; + return unless @keys; + my $loc = $self->location; + my %our_events; + foreach my $key (keys %$events) { + if ($key =~ m/^${loc}:(.*)$/) { + $our_events{$1} = $events->{$key}; } - foreach my $event ($self->accept_events) { - if (exists $events->{$event}) { - if (DEBUG_EVENTS) { - my $name = join(' at ', $self, $self->location); - $self->ctx->log->debug( - "Applying Event: $event on $name with value: " - .(defined $events->{$event} ? $events->{$event} : '<undef>') - ); - } - $self->$event($events->{$event}); + } + if (keys %our_events) { + #warn "$self: events ".join(', ', %our_events)."\n"; + $self->handle_events(\%our_events); + } +}; +sub handle_events { + my ($self, $events) = @_; + my $exists = exists $events->{exists}; + if ($exists) { + my %force = $self->force_events; + my @need = grep { !exists $events->{$_} } keys %force; + @{$events}{@need} = @force{@need}; + } + foreach my $event ($self->accept_events) { + if (exists $events->{$event}) { + if (DEBUG_EVENTS) { + my $name = join(' at ', $self, $self->location); + $self->ctx->log->debug( + "Applying Event: $event on $name with value: " + .(defined $events->{$event} ? $events->{$event} : '<undef>') + ); } + $self->$event($events->{$event}); } - }; - - implements accept_events => as { () }; - - implements force_events => as { () }; - - implements event_id_for => as { - my ($self, $name) = @_; - return join(':', $self->location, $name); - }; - - implements sort_by_spec => as { - my ($self, $spec, $items) = @_; - return $items if not defined $spec; - - my @order; - if (ref $spec eq 'ARRAY') { - @order = @$spec; - } - elsif (not ref $spec) { - return $items unless length $spec; - @order = split /\s+/, $spec; - } - - my %order_map = map {$_ => 0} @$items; - for my $order_num (0..$#order) { - $order_map{ $order[$order_num] } = ($#order - $order_num) + 1; - } + } +}; +sub accept_events { () }; +sub force_events { () }; +sub event_id_for { + my ($self, $name) = @_; + return join(':', $self->location, $name); +}; +sub sort_by_spec { + my ($self, $spec, $items) = @_; + return $items if not defined $spec; + + my @order; + if (ref $spec eq 'ARRAY') { + @order = @$spec; + } + elsif (not ref $spec) { + return $items unless length $spec; + @order = split /\s+/, $spec; + } + + my %order_map = map {$_ => 0} @$items; + for my $order_num (0..$#order) { + $order_map{ $order[$order_num] } = ($#order - $order_num) + 1; + } + + return [sort {$order_map{$b} <=> $order_map{$a}} @$items]; +}; - return [sort {$order_map{$b} <=> $order_map{$a}} @$items]; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Action.pm b/lib/Reaction/UI/ViewPort/Action.pm index fba28cf..b62e68f 100644 --- a/lib/Reaction/UI/ViewPort/Action.pm +++ b/lib/Reaction/UI/ViewPort/Action.pm @@ -22,189 +22,173 @@ use aliased 'Reaction::UI::ViewPort::Field::Mutable::File'; use Reaction::Types::Core qw/NonEmptySimpleStr/; -class Action is Object, which { - has model => (is => 'ro', isa => 'Reaction::InterfaceModel::Action', required => 1); - #has '+model' => (isa => 'Reaction::InterfaceModel::Action'); - has method => ( isa => NonEmptySimpleStr, is => 'rw', default => sub { 'post' } ); +use namespace::clean -except => [ qw(meta) ]; +extends Object; - has next_action => (is => 'rw', isa => 'ArrayRef'); - has on_apply_callback => (is => 'rw', isa => 'CodeRef'); - has ok_label => (is => 'rw', isa => 'Str', lazy_build => 1); - has apply_label => (is => 'rw', isa => 'Str', lazy_build => 1); - has close_label => (is => 'rw', isa => 'Str', lazy_fail => 1); - has close_label_close => (is => 'rw', isa => 'Str', lazy_build => 1); - has close_label_cancel => (is => 'rw', isa => 'Str', lazy_build => 1); +has model => (is => 'ro', isa => 'Reaction::InterfaceModel::Action', required => 1); +#has '+model' => (isa => 'Reaction::InterfaceModel::Action'); +has method => ( isa => NonEmptySimpleStr, is => 'rw', default => sub { 'post' } ); - has changed => (is => 'rw', isa => 'Int', reader => 'is_changed', default => sub{0}); +has next_action => (is => 'rw', isa => 'ArrayRef'); +has on_apply_callback => (is => 'rw', isa => 'CodeRef'); - implements BUILD => as{ - my $self = shift; - $self->close_label($self->close_label_close); - }; - - implements _build_ok_label => as{ 'ok' }; - implements _build_apply_label => as{ 'apply' }; - implements _build_close_label_close => as{ 'close' }; - implements _build_close_label_cancel => as{ 'cancel' }; - - implements can_apply => as { - my ($self) = @_; - foreach my $field ( @{ $self->fields } ) { - if ($field->needs_sync) { - if (DEBUG_EVENTS) { - $self->ctx->log->debug( - "Failing out of can_apply on ${\ref($self)} at ${\$self->location}" - ." because field for ${\$field->attribute->name} needs sync" - ); - } - return 0; +has ok_label => (is => 'rw', isa => 'Str', lazy_build => 1); +has apply_label => (is => 'rw', isa => 'Str', lazy_build => 1); +has close_label => (is => 'rw', isa => 'Str', lazy_fail => 1); +has close_label_close => (is => 'rw', isa => 'Str', lazy_build => 1); +has close_label_cancel => (is => 'rw', isa => 'Str', lazy_build => 1); + +has changed => (is => 'rw', isa => 'Int', reader => 'is_changed', default => sub{0}); +sub BUILD { + my $self = shift; + $self->close_label($self->close_label_close); +}; +sub _build_ok_label { 'ok' }; +sub _build_apply_label { 'apply' }; +sub _build_close_label_close { 'close' }; +sub _build_close_label_cancel { 'cancel' }; +sub can_apply { + my ($self) = @_; + foreach my $field ( @{ $self->fields } ) { + if ($field->needs_sync) { + if (DEBUG_EVENTS) { + $self->ctx->log->debug( + "Failing out of can_apply on ${\ref($self)} at ${\$self->location}" + ." because field for ${\$field->attribute->name} needs sync" + ); } - # if e.g. a datetime field has an invalid value that can't be re-assembled - # into a datetime object, the action may be in a consistent state but - # not synchronized from the fields; in this case, we must not apply - } - if (DEBUG_EVENTS) { - my $ret = $self->model->can_apply; - $self->ctx->log->debug( - "model can_apply returned ${ret}" - ." on ${\ref($self)} at ${\$self->location}" - ); - return $ret; - } - return $self->model->can_apply; - }; - - implements do_apply => as { - shift->model->do_apply; - }; - - implements ok => as { - my $self = shift; - $self->close(@_) if $self->apply(@_); - }; - - 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); - $self->on_apply_callback->($self => $result) if $self->has_on_apply_callback; - return 1; - } else { - $self->changed(1); - $self->close_label($self->close_label_cancel); return 0; } - }; - - implements close => as { - my $self = shift; - my ($controller, $name, @args) = @{$self->next_action}; - $controller->pop_viewport; - $controller->$name($self->ctx, @args); - }; - - implements can_close => as { 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 - - 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) = @_; - foreach my $field (@{$self->fields}) { - $field->sync_to_action; # get the field to populate the $action if possible - } - $self->model->sync_all; - foreach my $field (@{$self->fields}) { - $field->sync_from_action; # get errors from $action if applicable - } - }; - - - implements _build_fields_for_type_Num => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Number, %$args); - }; - - implements _build_fields_for_type_Int => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Integer, %$args); - }; - - implements _build_fields_for_type_Bool => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Boolean, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_Core_SimpleStr => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => String, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_File_File => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => File, %$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 - $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); - } else { - $self->_build_simple_field(attribute => $attr, class => Text, %$args); - } - }; - - implements _build_fields_for_type_Reaction_Types_Core_Password => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Password, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_DateTime_DateTime => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => DateTime, %$args); - }; - - implements _build_fields_for_type_Enum => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); - }; - - #this needs to be fixed. somehow. beats the shit our of me. really. - #implements build_fields_for_type_Reaction_InterfaceModel_Object => as { - implements _build_fields_for_type_DBIx_Class_Row => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); - }; - - implements _build_fields_for_type_ArrayRef => as { - my ($self, $attr, $args) = @_; - if ($attr->has_valid_values) { - $self->_build_simple_field(attribute => $attr, class => ChooseMany, %$args); - } else { - $self->_build_simple_field - ( - attribute => $attr, - class => Array, - layout => 'field/mutable/hidden_array', - %$args); - } - }; + # if e.g. a datetime field has an invalid value that can't be re-assembled + # into a datetime object, the action may be in a consistent state but + # not synchronized from the fields; in this case, we must not apply + } + if (DEBUG_EVENTS) { + my $ret = $self->model->can_apply; + $self->ctx->log->debug( + "model can_apply returned ${ret}" + ." on ${\ref($self)} at ${\$self->location}" + ); + return $ret; + } + return $self->model->can_apply; +}; +sub do_apply { + shift->model->do_apply; +}; +sub ok { + my $self = shift; + $self->close(@_) if $self->apply(@_); +}; +sub apply { + my $self = shift; + if ($self->can_apply && (my $result = $self->do_apply)) { + $self->changed(0); + $self->close_label($self->close_label_close); + $self->on_apply_callback->($self => $result) if $self->has_on_apply_callback; + return 1; + } else { + $self->changed(1); + $self->close_label($self->close_label_cancel); + return 0; + } +}; +sub close { + my $self = shift; + my ($controller, $name, @args) = @{$self->next_action}; + $controller->pop_viewport; + $controller->$name($self->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 - #implements _build_fields_for_type_DateTime_Spanset => as { - # my ($self, $attr, $args) = @_; - # $self->_build_simple_field(attribute => $attr, class => TimeRange, %$args); - #}; +after apply_child_events => sub { + # interrupt here because fields will have been updated + my ($self) = @_; + $self->sync_action_from_fields; +}; +sub sync_action_from_fields { + my ($self) = @_; + foreach my $field (@{$self->fields}) { + $field->sync_to_action; # get the field to populate the $action if possible + } + $self->model->sync_all; + foreach my $field (@{$self->fields}) { + $field->sync_from_action; # get errors from $action if applicable + } +}; +sub _build_fields_for_type_Num { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Number, %$args); +}; +sub _build_fields_for_type_Int { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Integer, %$args); +}; +sub _build_fields_for_type_Bool { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Boolean, %$args); +}; +sub _build_fields_for_type_Reaction_Types_Core_SimpleStr { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => String, %$args); +}; +sub _build_fields_for_type_Reaction_Types_File_File { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => File, %$args); +}; +sub _build_fields_for_type_Str { + my ($self, $attr, $args) = @_; + if ($attr->has_valid_values) { # There's probably a better way to do this + $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); + } else { + $self->_build_simple_field(attribute => $attr, class => Text, %$args); + } +}; +sub _build_fields_for_type_Reaction_Types_Core_Password { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Password, %$args); +}; +sub _build_fields_for_type_Reaction_Types_DateTime_DateTime { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => DateTime, %$args); +}; +sub _build_fields_for_type_Enum { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); +}; +#this needs to be fixed. somehow. beats the shit our of me. really. +#implements build_fields_for_type_Reaction_InterfaceModel_Object => as { +sub _build_fields_for_type_DBIx_Class_Row { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => ChooseOne, %$args); }; +sub _build_fields_for_type_ArrayRef { + my ($self, $attr, $args) = @_; + if ($attr->has_valid_values) { + $self->_build_simple_field(attribute => $attr, class => ChooseMany, %$args); + } else { + $self->_build_simple_field + ( + attribute => $attr, + class => Array, + layout => 'field/mutable/hidden_array', + %$args); + } +}; + +#implements _build_fields_for_type_DateTime_Spanset => as { +# my ($self, $attr, $args) = @_; +# $self->_build_simple_field(attribute => $attr, class => TimeRange, %$args); +#}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Action/Link.pm b/lib/Reaction/UI/ViewPort/Action/Link.pm index c364fd7..824c33d 100644 --- a/lib/Reaction/UI/ViewPort/Action/Link.pm +++ b/lib/Reaction/UI/ViewPort/Action/Link.pm @@ -2,26 +2,28 @@ package Reaction::UI::ViewPort::Action::Link; use Reaction::Class; -class Link is 'Reaction::UI::ViewPort', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort'; - has label => (is => 'rw', required => 1); - has uri => ( is => 'rw', lazy_build => 1); - has target => (isa => 'Object', is => 'rw', required => 1); - has action => (isa => 'CodeRef', is => 'rw', required => 1); - implements BUILD => as { - my $self = shift; - $self->label( $self->label->($self->target) ) if ref $self->label eq 'CODE'; - }; - - implements _build_uri => as{ - my $self = shift; - my $c = $self->ctx; - my ($c_name, $a_name, @rest) = @{ $self->action->($self->target, $c) }; - $c->uri_for($c->controller($c_name)->action_for($a_name),@rest); - }; +has label => (is => 'rw', required => 1); +has uri => ( is => 'rw', lazy_build => 1); +has target => (isa => 'Object', is => 'rw', required => 1); +has action => (isa => 'CodeRef', is => 'rw', required => 1); +sub BUILD { + my $self = shift; + $self->label( $self->label->($self->target) ) if ref $self->label eq 'CODE'; +}; +sub _build_uri { + my $self = shift; + my $c = $self->ctx; + my ($c_name, $a_name, @rest) = @{ $self->action->($self->target, $c) }; + $c->uri_for($c->controller($c_name)->action_for($a_name),@rest); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Collection.pm b/lib/Reaction/UI/ViewPort/Collection.pm index 26b75d4..2ef6e63 100644 --- a/lib/Reaction/UI/ViewPort/Collection.pm +++ b/lib/Reaction/UI/ViewPort/Collection.pm @@ -5,66 +5,65 @@ use Scalar::Util qw/blessed/; use aliased 'Reaction::InterfaceModel::Collection' => 'IM_Collection'; use aliased 'Reaction::UI::ViewPort::Object'; -class Collection is 'Reaction::UI::ViewPort', which { - - has members => (is => 'rw', isa => 'ArrayRef', lazy_build => 1); - - has collection => (is => 'ro', isa => IM_Collection, required => 1); - has current_collection => (is => 'rw', isa => IM_Collection, lazy_build => 1); - - has member_args => ( is => 'rw', isa => 'HashRef', lazy_build => 1); - has member_class => ( is => 'ro', isa => 'Str', lazy_build => 1); - - implements BUILD => as { - my ($self, $args) = @_; - if( my $member_args = delete $args->{Member} ){ - $self->member_args( $member_args ); - } - }; - - implements _build_member_args => as{ {} }; - - implements _build_member_class => as{ Object }; - - after clear_current_collection => sub{ - shift->clear_members; #clear the members the current collection changes, duh - }; - - implements _build_current_collection => as { - return $_[0]->collection; - }; - - #I'm not really sure why this is here all of a sudden. - implements model => as { shift->current_collection }; - - implements _build_members => as { - my ($self) = @_; - my (@members, $i); - my $args = $self->member_args; - my $builders = {}; - my $ctx = $self->ctx; - my $loc = join('-', $self->location, 'member'); - my $class = $self->member_class; - - #replace $i with a real unique identifier so that we don't run a risk of - # events being passed down to the wrong viewport. for now i disabled event - # passing until i fix this (groditi) - for my $obj ( $self->current_collection->members ) { - my $type = blessed $obj; - my $builder_cache = $builders->{$type} ||= {}; - my $member = $class->new( - ctx => $ctx, - model => $obj, - location => join('-', $loc, $i++), - builder_cache => $builder_cache, - %$args - ); - push(@members, $member); - } - return \@members; - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort'; + + +has members => (is => 'rw', isa => 'ArrayRef', lazy_build => 1); + +has collection => (is => 'ro', isa => IM_Collection, required => 1); +has current_collection => (is => 'rw', isa => IM_Collection, lazy_build => 1); + +has member_args => ( is => 'rw', isa => 'HashRef', lazy_build => 1); +has member_class => ( is => 'ro', isa => 'Str', lazy_build => 1); +sub BUILD { + my ($self, $args) = @_; + if( my $member_args = delete $args->{Member} ){ + $self->member_args( $member_args ); + } +}; +sub _build_member_args { {} }; +sub _build_member_class { Object }; + +after clear_current_collection => sub{ + shift->clear_members; #clear the members the current collection changes, duh }; +sub _build_current_collection { + return $_[0]->collection; +}; + +#I'm not really sure why this is here all of a sudden. +sub model { shift->current_collection }; +sub _build_members { + my ($self) = @_; + my (@members, $i); + my $args = $self->member_args; + my $builders = {}; + my $ctx = $self->ctx; + my $loc = join('-', $self->location, 'member'); + my $class = $self->member_class; + + #replace $i with a real unique identifier so that we don't run a risk of + # events being passed down to the wrong viewport. for now i disabled event + # passing until i fix this (groditi) + for my $obj ( $self->current_collection->members ) { + my $type = blessed $obj; + my $builder_cache = $builders->{$type} ||= {}; + my $member = $class->new( + ctx => $ctx, + model => $obj, + location => join('-', $loc, $i++), + builder_cache => $builder_cache, + %$args + ); + push(@members, $member); + } + return \@members; +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Collection/Grid.pm b/lib/Reaction/UI/ViewPort/Collection/Grid.pm index 66ce8d3..42d69f7 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Grid.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Grid.pm @@ -5,54 +5,55 @@ use Reaction::Class; use aliased 'Reaction::InterfaceModel::Collection' => 'IM_Collection'; use aliased 'Reaction::UI::ViewPort::Collection::Grid::Member'; -class Grid is 'Reaction::UI::ViewPort::Collection', which { - - has field_order => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1); - has excluded_fields => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1); - has field_labels => ( is => 'ro', isa => 'HashRef', lazy_build => 1); - - has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - - #################################### - implements _build_member_class => as { Member }; - - implements _build_field_labels => as { - my $self = shift; - my %labels; - for my $field ( @{$self->computed_field_order}){ - $labels{$field} = join(' ', map{ ucfirst } split('_', $field)); - } - return \%labels; - }; - - implements _build_field_order => as { []; }; - implements _build_excluded_fields => as { []; }; - - implements _build_computed_field_order => as { - my ($self) = @_; - 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 { - !($_->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') } - ) - ) } - grep { defined $_->get_read_method } - $self->current_collection->member_type->parameter_attributes; - - return $self->sort_by_spec($self->field_order, \@names); - }; - - before _build_members => sub { - my ($self) = @_; - $self->member_args->{computed_field_order} ||= $self->computed_field_order; - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Collection'; + + +has field_order => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1); +has excluded_fields => ( is => 'ro', isa => 'ArrayRef', lazy_build => 1); +has field_labels => ( is => 'ro', isa => 'HashRef', lazy_build => 1); + +has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); + +#################################### +sub _build_member_class { Member }; +sub _build_field_labels { + my $self = shift; + my %labels; + for my $field ( @{$self->computed_field_order}){ + $labels{$field} = join(' ', map{ ucfirst } split('_', $field)); + } + return \%labels; +}; +sub _build_field_order { []; }; +sub _build_excluded_fields { []; }; +sub _build_computed_field_order { + my ($self) = @_; + 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 { + !($_->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') } + ) + ) } + grep { defined $_->get_read_method } + $self->current_collection->member_type->parameter_attributes; + + return $self->sort_by_spec($self->field_order, \@names); }; +before _build_members => sub { + my ($self) = @_; + $self->member_args->{computed_field_order} ||= $self->computed_field_order; +}; + +__PACKAGE__->meta->make_immutable; + + 1; __END__; diff --git a/lib/Reaction/UI/ViewPort/Collection/Grid/Member.pm b/lib/Reaction/UI/ViewPort/Collection/Grid/Member.pm index aae25dd..1f6442e 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Grid/Member.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Grid/Member.pm @@ -2,44 +2,48 @@ package Reaction::UI::ViewPort::Collection::Grid::Member; use Reaction::Class; -class Member is 'Reaction::UI::ViewPort::Object', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Object'; - around _build_fields_for_type_Num => sub { - $_[0]->(@_[1,2], { layout => 'value/number', %{ $_[3] || {}} }) - }; - around _build_fields_for_type_Int => sub { - $_[0]->(@_[1,2], { layout => 'value/number', %{ $_[3] || {} } }) - }; - around _build_fields_for_type_Bool => sub { - $_[0]->(@_[1,2], { layout => 'value/boolean', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Num => sub { + $_[0]->(@_[1,2], { layout => 'value/number', %{ $_[3] || {}} }) +}; - around _build_fields_for_type_Enum => sub { - $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Int => sub { + $_[0]->(@_[1,2], { layout => 'value/number', %{ $_[3] || {} } }) +}; - around _build_fields_for_type_Str => sub { - $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Bool => sub { + $_[0]->(@_[1,2], { layout => 'value/boolean', %{ $_[3] || {} } }) +}; - around _build_fields_for_type_Reaction_Types_Core_SimpleStr => sub { - $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Enum => sub { + $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) +}; - around _build_fields_for_type_Reaction_InterfaceModel_Object => sub { - $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Str => sub { + $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) +}; - around _build_fields_for_type_Reaction_Types_DateTime_DateTime => sub { - $_[0]->(@_[1,2], { layout => 'value/date_time', %{ $_[3] || {} } }) - }; +around _build_fields_for_type_Reaction_Types_Core_SimpleStr => sub { + $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) +}; - around _build_fields_for_type_Reaction_Types_Core_Password => sub { return }; - around _build_fields_for_type_ArrayRef => sub { return }; - around _build_fields_for_type_Reaction_InterfaceModel_Collection => sub { return }; +around _build_fields_for_type_Reaction_InterfaceModel_Object => sub { + $_[0]->(@_[1,2], { layout => 'value/string', %{ $_[3] || {} } }) +}; +around _build_fields_for_type_Reaction_Types_DateTime_DateTime => sub { + $_[0]->(@_[1,2], { layout => 'value/date_time', %{ $_[3] || {} } }) }; +around _build_fields_for_type_Reaction_Types_Core_Password => sub { return }; +around _build_fields_for_type_ArrayRef => sub { return }; +around _build_fields_for_type_Reaction_InterfaceModel_Collection => sub { return }; + +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Collection/Grid/Member/WithActions.pm b/lib/Reaction/UI/ViewPort/Collection/Grid/Member/WithActions.pm index ef44141..ea3d832 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Grid/Member/WithActions.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Grid/Member/WithActions.pm @@ -2,10 +2,12 @@ package Reaction::UI::ViewPort::Collection::Grid::Member::WithActions; use Reaction::Class; -class WithActions is 'Reaction::UI::ViewPort::Collection::Grid::Member', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Collection::Grid::Member'; - does 'Reaction::UI::ViewPort::Role::Actions'; +with 'Reaction::UI::ViewPort::Role::Actions'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Collection/Role/Order.pm b/lib/Reaction/UI/ViewPort/Collection/Role/Order.pm index a3d1cf7..0121605 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Role/Order.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Role/Order.pm @@ -2,34 +2,33 @@ package Reaction::UI::ViewPort::Collection::Role::Order; use Reaction::Role; -role Order, which { +use namespace::clean -except => [ qw(meta) ]; - has order_by => (isa => 'Str', is => 'rw', trigger_adopt('order_by')); - has order_by_desc => (isa => 'Int', is => 'rw', trigger_adopt('order_by'), lazy_build => 1); - implements _build_order_by_desc => as { 0 }; +has order_by => (isa => 'Str', is => 'rw', trigger_adopt('order_by')); +has order_by_desc => (isa => 'Int', is => 'rw', trigger_adopt('order_by'), lazy_build => 1); +sub _build_order_by_desc { 0 }; +sub adopt_order_by { + shift->clear_current_collection; +}; - implements adopt_order_by => as { - shift->clear_current_collection; - }; +around _build_current_collection => sub { + my $orig = shift; + my ($self) = @_; + my $collection = $orig->(@_); + my %attrs; - around _build_current_collection => sub { - my $orig = shift; - my ($self) = @_; - my $collection = $orig->(@_); - my %attrs; + #XXX DBICism that needs to be fixed + if ($self->has_order_by) { + $attrs{order_by} = $self->order_by; + $attrs{order_by} .= ' DESC' if ($self->order_by_desc); + } - #XXX DBICism that needs to be fixed - if ($self->has_order_by) { - $attrs{order_by} = $self->order_by; - $attrs{order_by} .= ' DESC' if ($self->order_by_desc); - } + return $collection->where(undef, \%attrs); +}; - return $collection->where(undef, \%attrs); - }; +around accept_events => sub { ('order_by', 'order_by_desc', shift->(@_)); }; - around accept_events => sub { ('order_by', 'order_by_desc', shift->(@_)); }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Collection/Role/Pager.pm b/lib/Reaction/UI/ViewPort/Collection/Role/Pager.pm index df10970..64752a6 100644 --- a/lib/Reaction/UI/ViewPort/Collection/Role/Pager.pm +++ b/lib/Reaction/UI/ViewPort/Collection/Role/Pager.pm @@ -5,44 +5,42 @@ use Reaction::Role; use aliased 'Reaction::InterfaceModel::Collection'; # XX This needs to be consumed after Ordered -role Pager, which { +use namespace::clean -except => [ qw(meta) ]; - #has paged_collection => (isa => Collection, is => 'rw', lazy_build => 1); - has pager => (isa => 'Data::Page', is => 'rw', lazy_build => 1); - has page => (isa => 'Int', is => 'rw', lazy_build => 1, trigger_adopt('page')); - has per_page => (isa => 'Int', is => 'rw', lazy_build => 1, trigger_adopt('page')); - has per_page_max => (isa => 'Int', is => 'rw', lazy_build => 1); +#has paged_collection => (isa => Collection, is => 'rw', lazy_build => 1); - implements _build_page => as { 1 }; - implements _build_per_page => as { 10 }; - implements _build_per_page_max => as { 100 }; +has pager => (isa => 'Data::Page', is => 'rw', lazy_build => 1); +has page => (isa => 'Int', is => 'rw', lazy_build => 1, trigger_adopt('page')); +has per_page => (isa => 'Int', is => 'rw', lazy_build => 1, trigger_adopt('page')); +has per_page_max => (isa => 'Int', is => 'rw', lazy_build => 1); +sub _build_page { 1 }; +sub _build_per_page { 10 }; +sub _build_per_page_max { 100 }; +sub _build_pager { shift->current_collection->pager }; +sub adopt_page { + my ($self) = @_; + #$self->clear_paged_collection; - implements _build_pager => as { shift->current_collection->pager }; - - implements adopt_page => as { - my ($self) = @_; - #$self->clear_paged_collection; + $self->clear_pager; + $self->clear_current_collection; +}; - $self->clear_pager; - $self->clear_current_collection; - }; +around accept_events => sub { ('page','per_page', shift->(@_)); }; - around accept_events => sub { ('page','per_page', shift->(@_)); }; +#implements build_paged_collection => as { +# my ($self) = @_; +# my $collection = $self->current_collection; +# return $collection->where(undef, {rows => $self->per_page})->page($self->page); +#}; - #implements build_paged_collection => as { - # my ($self) = @_; - # my $collection = $self->current_collection; - # return $collection->where(undef, {rows => $self->per_page})->page($self->page); - #}; +around _build_current_collection => sub { + my $orig = shift; + my ($self) = @_; + my $collection = $orig->(@_); + return $collection->where(undef, {rows => $self->per_page})->page($self->page); +}; - around _build_current_collection => sub { - my $orig = shift; - my ($self) = @_; - my $collection = $orig->(@_); - return $collection->where(undef, {rows => $self->per_page})->page($self->page); - }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field.pm b/lib/Reaction/UI/ViewPort/Field.pm index 1ccc99c..a4bb219 100644 --- a/lib/Reaction/UI/ViewPort/Field.pm +++ b/lib/Reaction/UI/ViewPort/Field.pm @@ -4,64 +4,60 @@ use Reaction::Class; use aliased 'Reaction::InterfaceModel::Object'; use aliased 'Reaction::Meta::InterfaceModel::Object::ParameterAttribute'; -class Field is 'Reaction::UI::ViewPort', which { - - has value => (is => 'rw', lazy_build => 1); - has name => (is => 'rw', isa => 'Str', lazy_build => 1); - has label => (is => 'rw', isa => 'Str', lazy_build => 1); - has value_string => (is => 'rw', isa => 'Str', lazy_build => 1); - - has model => (is => 'ro', isa => Object, required => 1); - has attribute => (is => 'ro', isa => ParameterAttribute, required => 1); - - implements _build_name => as { shift->attribute->name }; - - implements _build_label => as { - join(' ', map { ucfirst } split('_', shift->name)); - }; - - implements _build_value => as { - my ($self) = @_; - my $reader = $self->attribute->get_read_method; - return $self->model->$reader; - }; - - implements _model_has_value => as { - my ($self) = @_; - my $predicate = $self->attribute->get_predicate_method; - - if (!$predicate || $self->model->$predicate - #|| ($self->attribute->is_lazy - # && !$self->attribute->is_lazy_fail) - ) { - # either model attribute has a value now or can build it - return 1; - } - return 0; - }; - - implements _build_value_string => as { - my ($self) = @_; - # XXX need the defined test because the IM lazy builds from - # the model and DBIC can have nullable fields and DBIC doesn't - # have a way to tell us that doesn't force value inflation (extra - # SELECTs for belongs_to) so basically we're screwed. - return ($self->_model_has_value && defined($self->_build_value) - ? $self->_value_string_from_value - : $self->_empty_string_value); - }; - - implements _value_string_from_value => as { - shift->value; - }; - - implements _empty_string_value => as { '' }; - - implements value_is_required => as { - shift->attribute->is_required; - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort'; + + +has value => (is => 'rw', lazy_build => 1); +has name => (is => 'rw', isa => 'Str', lazy_build => 1); +has label => (is => 'rw', isa => 'Str', lazy_build => 1); +has value_string => (is => 'rw', isa => 'Str', lazy_build => 1); + +has model => (is => 'ro', isa => Object, required => 1); +has attribute => (is => 'ro', isa => ParameterAttribute, required => 1); +sub _build_name { shift->attribute->name }; +sub _build_label { + join(' ', map { ucfirst } split('_', shift->name)); +}; +sub _build_value { + my ($self) = @_; + my $reader = $self->attribute->get_read_method; + return $self->model->$reader; +}; +sub _model_has_value { + my ($self) = @_; + my $predicate = $self->attribute->get_predicate_method; + + if (!$predicate || $self->model->$predicate + #|| ($self->attribute->is_lazy + # && !$self->attribute->is_lazy_fail) + ) { + # either model attribute has a value now or can build it + return 1; + } + return 0; }; +sub _build_value_string { + my ($self) = @_; + # XXX need the defined test because the IM lazy builds from + # the model and DBIC can have nullable fields and DBIC doesn't + # have a way to tell us that doesn't force value inflation (extra + # SELECTs for belongs_to) so basically we're screwed. + return ($self->_model_has_value && defined($self->_build_value) + ? $self->_value_string_from_value + : $self->_empty_string_value); +}; +sub _value_string_from_value { + shift->value; +}; +sub _empty_string_value { '' }; +sub value_is_required { + shift->attribute->is_required; +}; + +__PACKAGE__->meta->make_immutable; + 1; __END__; diff --git a/lib/Reaction/UI/ViewPort/Field/.ToDo/File.pm b/lib/Reaction/UI/ViewPort/Field/.ToDo/File.pm index c06f1a3..4df820d 100644 --- a/lib/Reaction/UI/ViewPort/Field/.ToDo/File.pm +++ b/lib/Reaction/UI/ViewPort/Field/.ToDo/File.pm @@ -3,23 +3,27 @@ package Reaction::UI::ViewPort::InterfaceModel::Field::File; use Reaction::Class; use Reaction::Types::File; -class File is 'Reaction::UI::ViewPort::InterfaceModel::Field', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::InterfaceModel::Field'; - has '+value' => (isa => 'File', required => 0); - override apply_our_events => sub { - my ($self, $ctx, $events) = @_; - my $value_key = join(':', $self->location, 'value'); - if (my $upload = $ctx->req->upload($value_key)) { - local $events->{$value_key} = $upload; - return super(); - } else { - return super(); - } - }; +has '+value' => (isa => 'File', required => 0); + +override apply_our_events => sub { + my ($self, $ctx, $events) = @_; + my $value_key = join(':', $self->location, 'value'); + if (my $upload = $ctx->req->upload($value_key)) { + local $events->{$value_key} = $upload; + return super(); + } else { + return super(); + } }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/UI/ViewPort/Field/.ToDo/TimeRange.pm b/lib/Reaction/UI/ViewPort/Field/.ToDo/TimeRange.pm index 9d65f2e..b411152 100644 --- a/lib/Reaction/UI/ViewPort/Field/.ToDo/TimeRange.pm +++ b/lib/Reaction/UI/ViewPort/Field/.ToDo/TimeRange.pm @@ -6,89 +6,88 @@ use DateTime; use DateTime::SpanSet; use Time::ParseDate (); -class TimeRange is 'Reaction::UI::ViewPort::InterfaceModel::Field', which { - - has '+value' => (isa => 'DateTime::SpanSet'); - - #has '+layout' => (default => 'timerange'); - - has value_string => - (isa => 'Str', is => 'rw', lazy_fail => 1, trigger_adopt('value_string')); - - has delete_label => ( - isa => 'Str', is => 'rw', required => 1, default => sub { 'Delete' }, - ); - - has parent => ( - isa => 'Reaction::UI::ViewPort::TimeRangeCollection', - is => 'ro', - required => 1, - is_weak_ref => 1 - ); - - implements _build_value_string => as { - my $self = shift; - #return '' unless $self->has_value; - #return $self->value_string; - }; - - implements value_array => as { - my $self = shift; - return split(',', $self->value_string); - }; - - implements adopt_value_string => as { - my ($self) = @_; - my @values = $self->value_array; - for my $idx (0 .. 3) { # last value is repeat - if (length $values[$idx]) { - my ($epoch) = Time::ParseDate::parsedate($values[$idx], UK => 1); - $values[$idx] = DateTime->from_epoch( epoch => $epoch ); - } +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::InterfaceModel::Field'; + + + +has '+value' => (isa => 'DateTime::SpanSet'); + +#has '+layout' => (default => 'timerange'); + +has value_string => + (isa => 'Str', is => 'rw', lazy_fail => 1, trigger_adopt('value_string')); + +has delete_label => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'Delete' }, +); + +has parent => ( + isa => 'Reaction::UI::ViewPort::TimeRangeCollection', + is => 'ro', + required => 1, + is_weak_ref => 1 +); +sub _build_value_string { + my $self = shift; + #return '' unless $self->has_value; + #return $self->value_string; +}; +sub value_array { + my $self = shift; + return split(',', $self->value_string); +}; +sub adopt_value_string { + my ($self) = @_; + my @values = $self->value_array; + for my $idx (0 .. 3) { # last value is repeat + if (length $values[$idx]) { + my ($epoch) = Time::ParseDate::parsedate($values[$idx], UK => 1); + $values[$idx] = DateTime->from_epoch( epoch => $epoch ); } - $self->value($self->range_to_spanset(@values)); - }; - - implements range_to_spanset => as { - my ($self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern) = @_; - my $spanset = DateTime::SpanSet->empty_set; - if (!$pattern || $pattern eq 'none') { - my $span = DateTime::Span->from_datetimes( - start => $time_from, end => $time_to - ); - $spanset = $spanset->union( $span ); - } else { - my $duration = $time_to - $time_from; - my %args = ( days => $time_from->day + 2, - hours => $time_from->hour, - minutes => $time_from->minute, - seconds => $time_from->second ); - - delete $args{'days'} if ($pattern eq 'daily'); - delete @args{qw/hours days/} if ($pattern eq 'hourly'); - $args{'days'} = $time_from->day if ($pattern eq 'monthly'); - my $start_set = DateTime::Event::Recurrence->$pattern( %args ); - my $iter = $start_set->iterator( start => $repeat_from, end => $repeat_to ); - while ( my $dt = $iter->next ) { - my $endtime = $dt + $duration; - my $new_span = DateTime::Span->from_datetimes( - start => $dt, - end => $endtime - ); - $spanset = $spanset->union( $new_span ); - } + } + $self->value($self->range_to_spanset(@values)); +}; +sub range_to_spanset { + my ($self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern) = @_; + my $spanset = DateTime::SpanSet->empty_set; + if (!$pattern || $pattern eq 'none') { + my $span = DateTime::Span->from_datetimes( + start => $time_from, end => $time_to + ); + $spanset = $spanset->union( $span ); + } else { + my $duration = $time_to - $time_from; + my %args = ( days => $time_from->day + 2, + hours => $time_from->hour, + minutes => $time_from->minute, + seconds => $time_from->second ); + + delete $args{'days'} if ($pattern eq 'daily'); + delete @args{qw/hours days/} if ($pattern eq 'hourly'); + $args{'days'} = $time_from->day if ($pattern eq 'monthly'); + my $start_set = DateTime::Event::Recurrence->$pattern( %args ); + my $iter = $start_set->iterator( start => $repeat_from, end => $repeat_to ); + while ( my $dt = $iter->next ) { + my $endtime = $dt + $duration; + my $new_span = DateTime::Span->from_datetimes( + start => $dt, + end => $endtime + ); + $spanset = $spanset->union( $new_span ); } - return $spanset; - }; + } + return $spanset; +}; +sub delete { + my ($self) = @_; + $self->parent->remove_range_vp($self); +}; - implements delete => as { - my ($self) = @_; - $self->parent->remove_range_vp($self); - }; +override accept_events => sub { ('value_string', 'delete', super()) }; - override accept_events => sub { ('value_string', 'delete', super()) }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Array.pm b/lib/Reaction/UI/ViewPort/Field/Array.pm index 92a735e..82e01d2 100644 --- a/lib/Reaction/UI/ViewPort/Field/Array.pm +++ b/lib/Reaction/UI/ViewPort/Field/Array.pm @@ -4,22 +4,24 @@ use Reaction::Class; use Scalar::Util 'blessed'; use aliased 'Reaction::UI::ViewPort::Field'; -class Array is Field, which { - has '+value' => (isa => 'ArrayRef'); +use namespace::clean -except => [ qw(meta) ]; +extends Field; - has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); - has value_map_method => ( - isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, - ); - implements _build_value_names => as { - my $self = shift; - my $meth = $self->value_map_method; - my @names = map { blessed($_) ? $_->$meth : $_ } @{ $self->value }; - return [ sort @names ]; - }; +has '+value' => (isa => 'ArrayRef'); - implements _empty_value => as { [] }; +has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); +has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, +); +sub _build_value_names { + my $self = shift; + my $meth = $self->value_map_method; + my @names = map { blessed($_) ? $_->$meth : $_ } @{ $self->value }; + return [ sort @names ]; }; +sub _empty_value { [] }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Boolean.pm b/lib/Reaction/UI/ViewPort/Field/Boolean.pm index cb6695e..53356ef 100644 --- a/lib/Reaction/UI/ViewPort/Field/Boolean.pm +++ b/lib/Reaction/UI/ViewPort/Field/Boolean.pm @@ -3,10 +3,14 @@ package Reaction::UI::ViewPort::Field::Boolean; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Field'; -class Boolean, is Field, which { - has '+value' => (isa => 'Bool'); +use namespace::clean -except => [ qw(meta) ]; +extends Field; + + +has '+value' => (isa => 'Bool'); + +override _empty_string_value => sub { 0 }; +__PACKAGE__->meta->make_immutable; - override _empty_string_value => sub { 0 }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Collection.pm b/lib/Reaction/UI/ViewPort/Field/Collection.pm index b772e02..02dfa75 100644 --- a/lib/Reaction/UI/ViewPort/Field/Collection.pm +++ b/lib/Reaction/UI/ViewPort/Field/Collection.pm @@ -4,20 +4,23 @@ use Reaction::Class; use Scalar::Util 'blessed'; use aliased 'Reaction::UI::ViewPort::Field::Array'; -class Collection is Array, which { +use namespace::clean -except => [ qw(meta) ]; +extends Array; - has value => ( - is => 'rw', lazy_build => 1, - isa => 'Reaction::InterfaceModel::Collection' - ); - implements _build_value_names => as { - my $self = shift; - my $meth = $self->value_map_method; - my @names = map { blessed($_) ? $_->$meth : $_ } $self->value->members; - return [ sort @names ]; - }; +has value => ( + is => 'rw', lazy_build => 1, + isa => 'Reaction::InterfaceModel::Collection' +); +sub _build_value_names { + my $self = shift; + my $meth = $self->value_map_method; + my @names = map { blessed($_) ? $_->$meth : $_ } $self->value->members; + return [ sort @names ]; }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/DateTime.pm b/lib/Reaction/UI/ViewPort/Field/DateTime.pm index bb896c7..46fbb60 100644 --- a/lib/Reaction/UI/ViewPort/Field/DateTime.pm +++ b/lib/Reaction/UI/ViewPort/Field/DateTime.pm @@ -5,20 +5,24 @@ use Reaction::Class; use Reaction::Types::DateTime (); use aliased 'Reaction::UI::ViewPort::Field'; -class DateTime is Field, which { - has '+value' => (isa => Reaction::Types::DateTime::DateTime()); +use namespace::clean -except => [ qw(meta) ]; +extends Field; - has value_string_default_format => ( - isa => 'Str', is => 'rw', required => 1, default => sub { "%F %H:%M:%S" } - ); - around _value_string_from_value => sub { - my $orig = shift; - my $self = shift; - my $format = $self->value_string_default_format; - return $self->$orig(@_)->strftime($format); - }; +has '+value' => (isa => Reaction::Types::DateTime::DateTime()); +has value_string_default_format => ( + isa => 'Str', is => 'rw', required => 1, default => sub { "%F %H:%M:%S" } +); + +around _value_string_from_value => sub { + my $orig = shift; + my $self = shift; + my $format = $self->value_string_default_format; + return $self->$orig(@_)->strftime($format); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/File.pm b/lib/Reaction/UI/ViewPort/Field/File.pm index dfe4dac..5d731e6 100644 --- a/lib/Reaction/UI/ViewPort/Field/File.pm +++ b/lib/Reaction/UI/ViewPort/Field/File.pm @@ -3,25 +3,27 @@ package Reaction::UI::ViewPort::Field::File; use Reaction::Class; use Reaction::Types::File; -class File is 'Reaction::UI::ViewPort::Field', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; - has '+value' => (isa => Reaction::Types::File::File()); - has uri => ( is => 'rw', lazy_build => 1); - has action => (isa => 'CodeRef', is => 'rw', required => 1); +has '+value' => (isa => Reaction::Types::File::File()); - implements _build_uri => as{ - my $self = shift; - my $c = $self->ctx; - my ($c_name, $a_name, @rest) = @{ $self->action->($self->model, $c) }; - $c->uri_for($c->controller($c_name)->action_for($a_name),@rest); - }; +has uri => ( is => 'rw', lazy_build => 1); - implements _value_string_from_value => as { - shift->value->stringify; - }; - +has action => (isa => 'CodeRef', is => 'rw', required => 1); +sub _build_uri { + my $self = shift; + my $c = $self->ctx; + my ($c_name, $a_name, @rest) = @{ $self->action->($self->model, $c) }; + $c->uri_for($c->controller($c_name)->action_for($a_name),@rest); }; +sub _value_string_from_value { + shift->value->stringify; +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Integer.pm b/lib/Reaction/UI/ViewPort/Field/Integer.pm index d3681cb..7064edb 100644 --- a/lib/Reaction/UI/ViewPort/Field/Integer.pm +++ b/lib/Reaction/UI/ViewPort/Field/Integer.pm @@ -3,8 +3,12 @@ package Reaction::UI::ViewPort::Field::Integer; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Field'; -class Integer is Field, which { - has '+value' => (isa => 'Int'); -}; +use namespace::clean -except => [ qw(meta) ]; +extends Field; + + +has '+value' => (isa => 'Int'); +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Array.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Array.pm index 0bf0104..6f5129c 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Array.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Array.pm @@ -2,17 +2,20 @@ package Reaction::UI::ViewPort::Field::Mutable::Array; use Reaction::Class; -class Array is 'Reaction::UI::ViewPort::Field::Array', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable'; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::Array'; - around value => sub { - my $orig = shift; - my $self = shift; - return $orig->($self) unless @_; - my $value = defined $_[0] ? $_[0] : []; - $orig->($self, (ref $value eq 'ARRAY' ? $value : [ $value ])); - }; +with 'Reaction::UI::ViewPort::Field::Role::Mutable'; + +around value => sub { + my $orig = shift; + my $self = shift; + return $orig->($self) unless @_; + my $value = defined $_[0] ? $_[0] : []; + $orig->($self, (ref $value eq 'ARRAY' ? $value : [ $value ])); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Boolean.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Boolean.pm index dfd936e..9063fca 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Boolean.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Boolean.pm @@ -2,19 +2,20 @@ package Reaction::UI::ViewPort::Field::Mutable::Boolean; use Reaction::Class; -class Boolean is 'Reaction::UI::ViewPort::Field::Boolean', which{ - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::Boolean'; - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); +}; +sub BUILD { + my($self) = @_; + $self->value(0) unless $self->_model_has_value; +}; - implements BUILD => as { - my($self) = @_; - $self->value(0) unless $self->_model_has_value; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseMany.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseMany.pm index b3dca44..0833c73 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseMany.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseMany.pm @@ -7,77 +7,76 @@ my $listify = sub{ return ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]]; }; -class ChooseMany is 'Reaction::UI::ViewPort::Field', which { - - does 'Reaction::UI::ViewPort::Field::Role::Mutable'; - does 'Reaction::UI::ViewPort::Field::Role::Choices'; - - #MUST BE HERE, BELOW THE 'does', OR THE TRIGGER WILL NOT HAPPEN! - has '+value' => (isa => 'ArrayRef'); - - around value => sub { - my $orig = shift; - my $self = shift; - return $orig->($self) unless @_; - my $value = $listify->(shift); - $_ = $self->str_to_ident($_) for @$value; - my $checked = $self->attribute->check_valid_value($self->model, $value); - # i.e. fail if any of the values fail - confess "Not a valid set of values" - if (@$checked < @$value || grep { !defined($_) } @$checked); - $orig->($self, $checked); - }; - - - around _value_string_from_value => sub { - my $orig = shift; - my $self = shift; - join(", ", (map {$self->obj_to_name($_->{value}) } @{ $self->current_value_choices })); - }; - - implements is_current_value => as { - my ($self, $check_value) = @_; - return unless $self->_model_has_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_value_choices => as { - my $self = shift; - my @all = grep { $self->is_current_value($_->{value}) } @{$self->value_choices}; - return [ @all ]; - }; - - implements available_value_choices => as { - my $self = shift; - my @all = grep { !$self->is_current_value($_->{value}) } @{$self->value_choices}; - return [ @all ]; - }; - - around handle_events => sub { - my $orig = shift; - my ($self, $events) = @_; - $events->{value} = [] if $events->{no_current_value}; - my $ev_value = $listify->($events->{value}); - if (delete $events->{add_all_values}) { - $events->{value} = [map {$self->obj_to_str($_)} @{$self->valid_values}]; - } elsif (exists $events->{add_values} && delete $events->{do_add_values}) { - my $add = $listify->(delete $events->{add_values}); - $events->{value} = [ @{$ev_value}, @$add ]; - } elsif (delete $events->{remove_all_values}) { - $events->{value} = []; - }elsif (exists $events->{remove_values} && delete $events->{do_remove_values}) { - my $remove = $listify->(delete $events->{remove_values}); - my %r = map { ($_ => 1) } @$remove; - $events->{value} = [ grep { !$r{$_} } @{$ev_value} ]; - } - - return $orig->(@_); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; + +with 'Reaction::UI::ViewPort::Field::Role::Mutable'; +with 'Reaction::UI::ViewPort::Field::Role::Choices'; + +#MUST BE HERE, BELOW THE 'does', OR THE TRIGGER WILL NOT HAPPEN! +has '+value' => (isa => 'ArrayRef'); + +around value => sub { + my $orig = shift; + my $self = shift; + return $orig->($self) unless @_; + my $value = $listify->(shift); + $_ = $self->str_to_ident($_) for @$value; + my $checked = $self->attribute->check_valid_value($self->model, $value); + # i.e. fail if any of the values fail + confess "Not a valid set of values" + if (@$checked < @$value || grep { !defined($_) } @$checked); + $orig->($self, $checked); +}; + +around _value_string_from_value => sub { + my $orig = shift; + my $self = shift; + join(", ", (map {$self->obj_to_name($_->{value}) } @{ $self->current_value_choices })); +}; +sub is_current_value { + my ($self, $check_value) = @_; + return unless $self->_model_has_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; +}; +sub current_value_choices { + my $self = shift; + my @all = grep { $self->is_current_value($_->{value}) } @{$self->value_choices}; + return [ @all ]; +}; +sub available_value_choices { + my $self = shift; + my @all = grep { !$self->is_current_value($_->{value}) } @{$self->value_choices}; + return [ @all ]; }; +around handle_events => sub { + my $orig = shift; + my ($self, $events) = @_; + $events->{value} = [] if $events->{no_current_value}; + my $ev_value = $listify->($events->{value}); + if (delete $events->{add_all_values}) { + $events->{value} = [map {$self->obj_to_str($_)} @{$self->valid_values}]; + } elsif (exists $events->{add_values} && delete $events->{do_add_values}) { + my $add = $listify->(delete $events->{add_values}); + $events->{value} = [ @{$ev_value}, @$add ]; + } elsif (delete $events->{remove_all_values}) { + $events->{value} = []; + }elsif (exists $events->{remove_values} && delete $events->{do_remove_values}) { + my $remove = $listify->(delete $events->{remove_values}); + my %r = map { ($_ => 1) } @$remove; + $events->{value} = [ grep { !$r{$_} } @{$ev_value} ]; + } + + return $orig->(@_); +}; + +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseOne.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseOne.pm index f6b679a..dba1a6d 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseOne.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/ChooseOne.pm @@ -3,45 +3,45 @@ package Reaction::UI::ViewPort::Field::Mutable::ChooseOne; use Reaction::Class; use Scalar::Util (); -class ChooseOne is 'Reaction::UI::ViewPort::Field', which { - - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - does 'Reaction::UI::ViewPort::Field::Role::Choices'; - - implements adopt_value_string => as { - my ($self) = @_; - my $value = $self->value_string; - $value = $self->str_to_ident($value) if (!ref $value); - my $attribute = $self->attribute; - my $checked = $attribute->check_valid_value($self->model, $value); - unless (defined $checked) { - require Data::Dumper; - my $serialised = Data::Dumper->new([ $value ])->Indent(0)->Dump; - $serialised =~ s/^\$VAR1 = //; $serialised =~ s/;$//; - confess "${serialised} is not a valid value for ${\$attribute->name} on " - ."${\$attribute->associated_class->name}"; - } - $self->value($checked); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; + +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +with 'Reaction::UI::ViewPort::Field::Role::Choices'; +sub adopt_value_string { + my ($self) = @_; + my $value = $self->value_string; + $value = $self->str_to_ident($value) if (!ref $value); + my $attribute = $self->attribute; + my $checked = $attribute->check_valid_value($self->model, $value); + unless (defined $checked) { + require Data::Dumper; + my $serialised = Data::Dumper->new([ $value ])->Indent(0)->Dump; + $serialised =~ s/^\$VAR1 = //; $serialised =~ s/;$//; + confess "${serialised} is not a valid value for ${\$attribute->name} on " + ."${\$attribute->associated_class->name}"; + } + $self->value($checked); +}; - around _value_string_from_value => sub { - my $orig = shift; - my $self = shift; - my $value = $self->$orig(@_); - return $self->obj_to_name($value->{value}) if Scalar::Util::blessed($value); - return $self->obj_to_name($value) if blessed $value; - return "$value"; # force stringify. might work. probably won't. - }; +around _value_string_from_value => sub { + my $orig = shift; + my $self = shift; + my $value = $self->$orig(@_); + return $self->obj_to_name($value->{value}) if Scalar::Util::blessed($value); + return $self->obj_to_name($value) if blessed $value; + return "$value"; # force stringify. might work. probably won't. +}; +sub is_current_value { + my ($self, $check_value) = @_; + return unless $self->_model_has_value; + my $our_value = $self->value; + return unless defined($our_value); + $check_value = $self->obj_to_str($check_value) if ref($check_value); + return $self->obj_to_str($our_value) eq $check_value; +}; - implements is_current_value => as { - my ($self, $check_value) = @_; - return unless $self->_model_has_value; - my $our_value = $self->value; - return unless defined($our_value); - $check_value = $self->obj_to_str($check_value) if ref($check_value); - return $self->obj_to_str($our_value) eq $check_value; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm index 654f0d8..27181f5 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/DateTime.pm @@ -4,25 +4,25 @@ use Reaction::Class; use Time::ParseDate; use DateTime; -class 'Reaction::UI::ViewPort::Field::Mutable::DateTime', - is 'Reaction::UI::ViewPort::Field::DateTime', which { - - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - implements adopt_value_string => as { - my ($self) = @_; - my $value = $self->value_string; - my ($epoch) = Time::ParseDate::parsedate($value); - if (defined $epoch) { - my $dt = 'DateTime'->from_epoch( epoch => $epoch ); - $self->value($dt); - } else { - $self->value($self->value_string); - } - }; - +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::DateTime'; + +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + my $value = $self->value_string; + my ($epoch) = Time::ParseDate::parsedate($value); + if (defined $epoch) { + my $dt = 'DateTime'->from_epoch( epoch => $epoch ); + $self->value($dt); + } else { + $self->value($self->value_string); + } }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/File.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/File.pm index ffbcbc9..d6d05c2 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/File.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/File.pm @@ -3,29 +3,30 @@ package Reaction::UI::ViewPort::Field::Mutable::File; use Reaction::Types::File qw/Upload/; use Reaction::Class; -class File is 'Reaction::UI::ViewPort::Field', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - has '+value' => (isa => Upload); - - override apply_our_events => sub { - my ($self, $ctx, $events) = @_; - my $value_key = $self->event_id_for('value_string'); - if (my $upload = $ctx->req->upload($value_key)) { - local $events->{$value_key} = $upload; - return super(); - } else { - return super(); - } - }; - - implements adopt_value_string => sub { - my($self) = @_; - $self->value($self->value_string) if $self->value_string; - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; + +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; + +has '+value' => (isa => Upload); + +override apply_our_events => sub { + my ($self, $ctx, $events) = @_; + my $value_key = $self->event_id_for('value_string'); + if (my $upload = $ctx->req->upload($value_key)) { + local $events->{$value_key} = $upload; + return super(); + } else { + return super(); + } +}; +sub adopt_value_string { + my($self) = @_; + $self->value($self->value_string) if $self->value_string; +}; +override _value_string_from_value => sub { '' }; - overrides _value_string_from_value => sub { '' }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/HiddenArray.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/HiddenArray.pm index e55836f..fa75e3c 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/HiddenArray.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/HiddenArray.pm @@ -2,26 +2,27 @@ package Reaction::UI::ViewPort::Field::Mutable::HiddenArray; use Reaction::Class; -class HiddenArray is 'Reaction::UI::ViewPort::Field', which { - - does 'Reaction::UI::ViewPort::Field::Role::Mutable'; - - has '+value' => (isa => 'ArrayRef'); - - around value => sub { - my $orig = shift; - my $self = shift; - if (@_) { - #this hsould be done with coercions - $orig->($self, (ref $_[0] eq 'ARRAY' ? $_[0] : [ $_[0] ])); - $self->sync_to_action; - } else { - $orig->($self); - } - }; - - implements _empty_value => as { [] }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; + +with 'Reaction::UI::ViewPort::Field::Role::Mutable'; + +has '+value' => (isa => 'ArrayRef'); + +around value => sub { + my $orig = shift; + my $self = shift; + if (@_) { + #this hsould be done with coercions + $orig->($self, (ref $_[0] eq 'ARRAY' ? $_[0] : [ $_[0] ])); + $self->sync_to_action; + } else { + $orig->($self); + } }; +sub _empty_value { [] }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Integer.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Integer.pm index 958150a..452e2ab 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Integer.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Integer.pm @@ -2,14 +2,16 @@ package Reaction::UI::ViewPort::Field::Mutable::Integer; use Reaction::Class; -class Integer is 'Reaction::UI::ViewPort::Field::Integer', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::Integer'; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm index 6d9d8aa..0685f87 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/MatchingPasswords.pm @@ -3,38 +3,41 @@ package Reaction::UI::ViewPort::Field::Mutable::MatchingPasswords; use Reaction::Class; 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 { - 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 ... - #i don't like how this works, it's unnecessarily fragile, but how else ? - around accept_events => sub { ('check_value', shift->(@_)) }; - - around can_sync_to_action => sub { - my $orig = shift; - my ($self) = @_; - return $orig->(@_) if $self->check_value eq $self->value_string; - $self->message("Passwords do not match"); - return; - }; +use namespace::clean -except => [ qw(meta) ]; +extends Password; + + +has check_value => (is => 'rw', isa => 'Str', ); +has check_label => (is => 'rw', isa => 'Str', lazy_build => 1); +sub _build_check_label { + 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 { + 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 ... +#i don't like how this works, it's unnecessarily fragile, but how else ? +around accept_events => sub { ('check_value', shift->(@_)) }; + +around can_sync_to_action => sub { + my $orig = shift; + my ($self) = @_; + return $orig->(@_) if $self->check_value eq $self->value_string; + $self->message("Passwords do not match"); + return; +}; + +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Number.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Number.pm index d2be595..31416e4 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Number.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Number.pm @@ -2,13 +2,15 @@ package Reaction::UI::ViewPort::Field::Mutable::Number; use Reaction::Class; -class Number is 'Reaction::UI::ViewPort::Field::Number', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::Number'; - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Password.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Password.pm index d009698..b89cc76 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Password.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Password.pm @@ -2,14 +2,16 @@ package Reaction::UI::ViewPort::Field::Mutable::Password; use Reaction::Class; -class Password is 'Reaction::UI::ViewPort::Field::String', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::String'; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/String.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/String.pm index 11d5d14..ca6d73a 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/String.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/String.pm @@ -2,14 +2,16 @@ package Reaction::UI::ViewPort::Field::Mutable::String; use Reaction::Class; -class String is 'Reaction::UI::ViewPort::Field::String', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::String'; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Mutable/Text.pm b/lib/Reaction/UI/ViewPort/Field/Mutable/Text.pm index 09d2127..d4e6935 100644 --- a/lib/Reaction/UI/ViewPort/Field/Mutable/Text.pm +++ b/lib/Reaction/UI/ViewPort/Field/Mutable/Text.pm @@ -2,14 +2,16 @@ package Reaction::UI::ViewPort::Field::Mutable::Text; use Reaction::Class; -class Text is 'Reaction::UI::ViewPort::Field::Text', which { - does 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; - - implements adopt_value_string => as { - my ($self) = @_; - $self->value($self->value_string); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::Text'; +with 'Reaction::UI::ViewPort::Field::Role::Mutable::Simple'; +sub adopt_value_string { + my ($self) = @_; + $self->value($self->value_string); }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Number.pm b/lib/Reaction/UI/ViewPort/Field/Number.pm index a5725fa..a7ccc55 100644 --- a/lib/Reaction/UI/ViewPort/Field/Number.pm +++ b/lib/Reaction/UI/ViewPort/Field/Number.pm @@ -3,8 +3,12 @@ package Reaction::UI::ViewPort::Field::Number; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Field'; -class Number is Field, which { - has '+value' => (isa => 'Num'); -}; +use namespace::clean -except => [ qw(meta) ]; +extends Field; + + +has '+value' => (isa => 'Num'); +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Password.pm b/lib/Reaction/UI/ViewPort/Field/Password.pm index a80e71a..edb8fd2 100644 --- a/lib/Reaction/UI/ViewPort/Field/Password.pm +++ b/lib/Reaction/UI/ViewPort/Field/Password.pm @@ -4,12 +4,16 @@ use Reaction::Class; use Reaction::Types::Core qw(SimpleStr); -class Password is 'Reaction::UI::ViewPort::Field::String', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field::String'; - has '+value' => (isa => SimpleStr); - #has '+layout' => (default => 'password'); -}; + +has '+value' => (isa => SimpleStr); +#has '+layout' => (default => 'password'); + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/RelatedObject.pm b/lib/Reaction/UI/ViewPort/Field/RelatedObject.pm index 3a3354f..ec5c883 100644 --- a/lib/Reaction/UI/ViewPort/Field/RelatedObject.pm +++ b/lib/Reaction/UI/ViewPort/Field/RelatedObject.pm @@ -3,19 +3,23 @@ package Reaction::UI::ViewPort::Field::RelatedObject; use Reaction::Class; use Scalar::Util 'blessed'; -class RelatedObject is 'Reaction::UI::ViewPort::Field', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; - has value_map_method => ( - isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, - ); - around _value_string_from_value => sub { - my $orig = shift; - my $self = shift; - my $meth = $self->value_map_method; - return $self->$orig(@_)->$meth; - }; +has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, +); + +around _value_string_from_value => sub { + my $orig = shift; + my $self = shift; + my $meth = $self->value_map_method; + return $self->$orig(@_)->$meth; }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Role/Choices.pm b/lib/Reaction/UI/ViewPort/Field/Role/Choices.pm index df8615d..fa329b7 100644 --- a/lib/Reaction/UI/ViewPort/Field/Role/Choices.pm +++ b/lib/Reaction/UI/ViewPort/Field/Role/Choices.pm @@ -4,51 +4,47 @@ use Reaction::Role; use URI; use Scalar::Util 'blessed'; -role Choices, which { - - has valid_values => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); - has value_choices => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); - has value_map_method => ( - isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, - ); - - implements str_to_ident => as { - my ($self, $str) = @_; - my $u = URI->new('','http'); - $u->query($str); - return ($u->query_keywords ? ($u->query_keywords)[0] : { $u->query_form }); - }; - - implements obj_to_str => as { - my ($self, $obj) = @_; - return $obj unless ref($obj); - confess "${obj} not an object" unless blessed($obj); - my $ident = $obj->ident_condition; #XXX DBIC ism that needs to go away - my $u = URI->new('', 'http'); - $u->query_form(%$ident); - return $u->query; - }; - - implements obj_to_name => as { - my ($self, $obj) = @_; - return $obj unless ref($obj); - confess "${obj} not an object" unless blessed($obj); - my $meth = $self->value_map_method; - return $obj->$meth; - }; - - implements _build_valid_values => as { - my $self = shift; - return [ $self->attribute->all_valid_values($self->model) ]; - }; +use namespace::clean -except => [ qw(meta) ]; + + +has valid_values => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); +has value_choices => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); +has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, +); +sub str_to_ident { + my ($self, $str) = @_; + my $u = URI->new('','http'); + $u->query($str); + return ($u->query_keywords ? ($u->query_keywords)[0] : { $u->query_form }); +}; +sub obj_to_str { + my ($self, $obj) = @_; + return $obj unless ref($obj); + confess "${obj} not an object" unless blessed($obj); + my $ident = $obj->ident_condition; #XXX DBIC ism that needs to go away + my $u = URI->new('', 'http'); + $u->query_form(%$ident); + return $u->query; +}; +sub obj_to_name { + my ($self, $obj) = @_; + return $obj unless ref($obj); + confess "${obj} not an object" unless blessed($obj); + my $meth = $self->value_map_method; + return $obj->$meth; +}; +sub _build_valid_values { + my $self = shift; + return [ $self->attribute->all_valid_values($self->model) ]; +}; +sub _build_value_choices { + my $self = shift; + my @pairs = map{{value => $self->obj_to_str($_), name => $self->obj_to_name($_)}} + @{ $self->valid_values }; + return [ sort { $a->{name} cmp $b->{name} } @pairs ]; +}; - implements _build_value_choices => sub{ - my $self = shift; - my @pairs = map{{value => $self->obj_to_str($_), name => $self->obj_to_name($_)}} - @{ $self->valid_values }; - return [ sort { $a->{name} cmp $b->{name} } @pairs ]; - }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm index e2304ef..b73114c 100644 --- a/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm +++ b/lib/Reaction/UI/ViewPort/Field/Role/Mutable.pm @@ -5,92 +5,89 @@ use Reaction::Role; use aliased 'Reaction::InterfaceModel::Action'; use aliased 'Reaction::Meta::InterfaceModel::Action::ParameterAttribute'; -role Mutable, which { - has model => (is => 'ro', isa => Action, required => 1); - has attribute => (is => 'ro', isa => ParameterAttribute, required => 1); - - has value => ( - is => 'rw', lazy_build => 1, trigger_adopt('value'), - clearer => 'clear_value', - ); - has needs_sync => (is => 'rw', isa => 'Int', default => 0); - #predicates are autmagically generated for lazy and non-required attrs - has message => (is => 'rw', isa => 'Str', clearer => 'clear_message'); - - after clear_value => sub { - my $self = shift; - $self->clear_message if $self->has_message; - $self->needs_sync(1); - }; - - implements adopt_value => as { - my ($self) = @_; - $self->clear_message if $self->has_message; - $self->needs_sync(1); # if $self->has_attribute; - }; - - implements can_sync_to_action => as { - my $self = shift; - return 1 unless $self->needs_sync; - my $attr = $self->attribute; - - if ($self->has_value) { - my $value = $self->value; - if (my $tc = $attr->type_constraint) { - $value = $tc->coercion->coerce($value) if ($tc->has_coercion); - if (defined (my $error = $tc->validate($value))) { - $self->message($error); - return; - } +use namespace::clean -except => [ qw(meta) ]; + +has model => (is => 'ro', isa => Action, required => 1); +has attribute => (is => 'ro', isa => ParameterAttribute, required => 1); + +has value => ( + is => 'rw', lazy_build => 1, trigger_adopt('value'), + clearer => 'clear_value', +); +has needs_sync => (is => 'rw', isa => 'Int', default => 0); +#predicates are autmagically generated for lazy and non-required attrs +has message => (is => 'rw', isa => 'Str', clearer => 'clear_message'); + +after clear_value => sub { + my $self = shift; + $self->clear_message if $self->has_message; + $self->needs_sync(1); +}; +sub adopt_value { + my ($self) = @_; + $self->clear_message if $self->has_message; + $self->needs_sync(1); # if $self->has_attribute; +}; +sub can_sync_to_action { + my $self = shift; + return 1 unless $self->needs_sync; + my $attr = $self->attribute; + + if ($self->has_value) { + my $value = $self->value; + if (my $tc = $attr->type_constraint) { + $value = $tc->coercion->coerce($value) if ($tc->has_coercion); + if (defined (my $error = $tc->validate($value))) { + $self->message($error); + return; } - } else { - return if $attr->is_required; } - return 1; - }; - - implements sync_to_action => as { - my ($self) = @_; - return unless $self->needs_sync; - return unless $self->can_sync_to_action; - - my $attr = $self->attribute; - - if ($self->has_value) { - my $value = $self->value; - if (my $tc = $attr->type_constraint) { - #this will go away when we have moose dbic. until then though... - $value = $tc->coercion->coerce($value) if ($tc->has_coercion); - } - my $writer = $attr->get_write_method; - confess "No writer for attribute" unless defined($writer); - $self->model->$writer($value); - } else { - my $predicate = $attr->get_predicate_method; - confess "No predicate for attribute" unless defined($predicate); - if ($self->model->$predicate) { - my $clearer = $attr->get_clearer_method; - confess "${predicate} returned true but no clearer for attribute" - unless defined($clearer); - $self->model->$clearer; - } + } else { + return if $attr->is_required; + } + return 1; +}; +sub sync_to_action { + my ($self) = @_; + return unless $self->needs_sync; + return unless $self->can_sync_to_action; + + my $attr = $self->attribute; + + if ($self->has_value) { + my $value = $self->value; + if (my $tc = $attr->type_constraint) { + #this will go away when we have moose dbic. until then though... + $value = $tc->coercion->coerce($value) if ($tc->has_coercion); } - $self->needs_sync(0); - }; - - implements sync_from_action => as { - my ($self) = @_; - return unless !$self->needs_sync; # && $self->has_attribute; - if( !$self->has_message ){ - if(my $error = $self->model->error_for($self->attribute) ){ - $self->message( $error ); - } + my $writer = $attr->get_write_method; + confess "No writer for attribute" unless defined($writer); + $self->model->$writer($value); + } else { + my $predicate = $attr->get_predicate_method; + confess "No predicate for attribute" unless defined($predicate); + if ($self->model->$predicate) { + my $clearer = $attr->get_clearer_method; + confess "${predicate} returned true but no clearer for attribute" + unless defined($clearer); + $self->model->$clearer; + } + } + $self->needs_sync(0); +}; +sub sync_from_action { + my ($self) = @_; + return unless !$self->needs_sync; # && $self->has_attribute; + if( !$self->has_message ){ + if(my $error = $self->model->error_for($self->attribute) ){ + $self->message( $error ); } - }; + } +}; + +around accept_events => sub { ('value', shift->(@_)) }; - around accept_events => sub { ('value', shift->(@_)) }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Role/Mutable/Simple.pm b/lib/Reaction/UI/ViewPort/Field/Role/Mutable/Simple.pm index 4244b31..e41f264 100644 --- a/lib/Reaction/UI/ViewPort/Field/Role/Mutable/Simple.pm +++ b/lib/Reaction/UI/ViewPort/Field/Role/Mutable/Simple.pm @@ -4,35 +4,34 @@ use Reaction::Role; use aliased 'Reaction::UI::ViewPort::Field::Role::Mutable'; -role Simple which { - - does Mutable; - - has value_string => ( - is => 'rw', lazy_build => 1, trigger_adopt('value_string'), - clearer => 'clear_value', - ); +use namespace::clean -except => [ qw(meta) ]; +with Mutable; + +has value_string => ( + is => 'rw', lazy_build => 1, trigger_adopt('value_string'), + clearer => 'clear_value', +); + +around value_string => sub { + my $orig = shift; + my $self = shift; + if (@_ && defined($_[0]) && !ref($_[0]) && $_[0] eq '' + && !$self->value_is_required) { + $self->clear_value; + return undef; + } + return $self->$orig(@_); +}; - around value_string => sub { - my $orig = shift; - my $self = shift; - if (@_ && defined($_[0]) && !ref($_[0]) && $_[0] eq '' - && !$self->value_is_required) { - $self->clear_value; - return undef; - } - return $self->$orig(@_); - }; +# the user needs to implement this because, honestly, you're always going +# to need to do something custom and the only common thing really is +# "you probably set $self->value at the end" +requires 'adopt_value_string'; - # the user needs to implement this because, honestly, you're always going - # to need to do something custom and the only common thing really is - # "you probably set $self->value at the end" - requires 'adopt_value_string'; +around accept_events => sub { ('value_string', shift->(@_)) }; - around accept_events => sub { ('value_string', shift->(@_)) }; +around force_events => sub { (value_string => '', shift->(@_)) }; - around force_events => sub { (value_string => '', shift->(@_)) }; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/Field/String.pm b/lib/Reaction/UI/ViewPort/Field/String.pm index 9935ae5..ec7e295 100644 --- a/lib/Reaction/UI/ViewPort/Field/String.pm +++ b/lib/Reaction/UI/ViewPort/Field/String.pm @@ -3,8 +3,12 @@ package Reaction::UI::ViewPort::Field::String; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Field'; -class String is Field, which { - has '+value' => (isa => 'Str'); -}; +use namespace::clean -except => [ qw(meta) ]; +extends Field; + + +has '+value' => (isa => 'Str'); +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/Text.pm b/lib/Reaction/UI/ViewPort/Field/Text.pm index 3d19047..b0c90da 100644 --- a/lib/Reaction/UI/ViewPort/Field/Text.pm +++ b/lib/Reaction/UI/ViewPort/Field/Text.pm @@ -3,8 +3,12 @@ package Reaction::UI::ViewPort::Field::Text; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Field'; -class Text is Field, which { - has '+value' => (isa => 'Str'); -}; +use namespace::clean -except => [ qw(meta) ]; +extends Field; + + +has '+value' => (isa => 'Str'); +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Field/TimeRange.pm b/lib/Reaction/UI/ViewPort/Field/TimeRange.pm index ccf6e65..f227203 100644 --- a/lib/Reaction/UI/ViewPort/Field/TimeRange.pm +++ b/lib/Reaction/UI/ViewPort/Field/TimeRange.pm @@ -6,89 +6,88 @@ use DateTime; use DateTime::SpanSet; use Time::ParseDate (); -class TimeRange is 'Reaction::UI::ViewPort::Field', which { - - has '+value' => (isa => SpanSet); - - #has '+layout' => (default => 'timerange'); - - has value_string => - (isa => 'Str', is => 'rw', lazy_fail => 1, trigger_adopt('value_string')); - - has delete_label => ( - isa => 'Str', is => 'rw', required => 1, default => sub { 'Delete' }, - ); - - has parent => ( - isa => 'Reaction::UI::ViewPort::TimeRangeCollection', - is => 'ro', - required => 1, - is_weak_ref => 1 - ); - - implements _build_value_string => as { - my $self = shift; - #return '' unless $self->has_value; - #return $self->value_string; - }; - - implements value_array => as { - my $self = shift; - return split(',', $self->value_string); - }; - - implements adopt_value_string => as { - my ($self) = @_; - my @values = $self->value_array; - for my $idx (0 .. 3) { # last value is repeat - if (length $values[$idx]) { - my ($epoch) = Time::ParseDate::parsedate($values[$idx], UK => 1); - $values[$idx] = DateTime->from_epoch( epoch => $epoch ); - } +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Field'; + + + +has '+value' => (isa => SpanSet); + +#has '+layout' => (default => 'timerange'); + +has value_string => + (isa => 'Str', is => 'rw', lazy_fail => 1, trigger_adopt('value_string')); + +has delete_label => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'Delete' }, +); + +has parent => ( + isa => 'Reaction::UI::ViewPort::TimeRangeCollection', + is => 'ro', + required => 1, + is_weak_ref => 1 +); +sub _build_value_string { + my $self = shift; + #return '' unless $self->has_value; + #return $self->value_string; +}; +sub value_array { + my $self = shift; + return split(',', $self->value_string); +}; +sub adopt_value_string { + my ($self) = @_; + my @values = $self->value_array; + for my $idx (0 .. 3) { # last value is repeat + if (length $values[$idx]) { + my ($epoch) = Time::ParseDate::parsedate($values[$idx], UK => 1); + $values[$idx] = DateTime->from_epoch( epoch => $epoch ); } - $self->value($self->range_to_spanset(@values)); - }; - - implements range_to_spanset => as { - my ($self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern) = @_; - my $spanset = DateTime::SpanSet->empty_set; - if (!$pattern || $pattern eq 'none') { - my $span = DateTime::Span->from_datetimes( - start => $time_from, end => $time_to - ); - $spanset = $spanset->union( $span ); - } else { - my $duration = $time_to - $time_from; - my %args = ( days => $time_from->day + 2, - hours => $time_from->hour, - minutes => $time_from->minute, - seconds => $time_from->second ); - - delete $args{'days'} if ($pattern eq 'daily'); - delete @args{qw/hours days/} if ($pattern eq 'hourly'); - $args{'days'} = $time_from->day if ($pattern eq 'monthly'); - my $start_set = DateTime::Event::Recurrence->$pattern( %args ); - my $iter = $start_set->iterator( start => $repeat_from, end => $repeat_to ); - while ( my $dt = $iter->next ) { - my $endtime = $dt + $duration; - my $new_span = DateTime::Span->from_datetimes( - start => $dt, - end => $endtime - ); - $spanset = $spanset->union( $new_span ); - } + } + $self->value($self->range_to_spanset(@values)); +}; +sub range_to_spanset { + my ($self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern) = @_; + my $spanset = DateTime::SpanSet->empty_set; + if (!$pattern || $pattern eq 'none') { + my $span = DateTime::Span->from_datetimes( + start => $time_from, end => $time_to + ); + $spanset = $spanset->union( $span ); + } else { + my $duration = $time_to - $time_from; + my %args = ( days => $time_from->day + 2, + hours => $time_from->hour, + minutes => $time_from->minute, + seconds => $time_from->second ); + + delete $args{'days'} if ($pattern eq 'daily'); + delete @args{qw/hours days/} if ($pattern eq 'hourly'); + $args{'days'} = $time_from->day if ($pattern eq 'monthly'); + my $start_set = DateTime::Event::Recurrence->$pattern( %args ); + my $iter = $start_set->iterator( start => $repeat_from, end => $repeat_to ); + while ( my $dt = $iter->next ) { + my $endtime = $dt + $duration; + my $new_span = DateTime::Span->from_datetimes( + start => $dt, + end => $endtime + ); + $spanset = $spanset->union( $new_span ); } - return $spanset; - }; + } + return $spanset; +}; +sub delete { + my ($self) = @_; + $self->parent->remove_range_vp($self); +}; - implements delete => as { - my ($self) = @_; - $self->parent->remove_range_vp($self); - }; +override accept_events => sub { ('value_string', 'delete', super()) }; - override accept_events => sub { ('value_string', 'delete', super()) }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/ViewPort/ListView.pm b/lib/Reaction/UI/ViewPort/ListView.pm index 1c2247d..356fc18 100644 --- a/lib/Reaction/UI/ViewPort/ListView.pm +++ b/lib/Reaction/UI/ViewPort/ListView.pm @@ -3,27 +3,29 @@ package Reaction::UI::ViewPort::ListView; use Reaction::Class; use aliased 'Reaction::UI::ViewPort::Collection::Grid::Member::WithActions'; -class ListView is 'Reaction::UI::ViewPort::Collection::Grid', which { - - does 'Reaction::UI::ViewPort::Collection::Role::Order'; - does 'Reaction::UI::ViewPort::Collection::Role::Pager'; - does 'Reaction::UI::ViewPort::Role::Actions'; - - #If I decide that object actions and collection actions should be - #lumped together i oculd move these into the collection action role - #ooor we could create a third role that does this, but gah, no? - implements _build_member_class => as { WithActions }; - - #You'se has to goes aways. sorry. - #if i saved the args as an attribute i could probably get around this.... - implements object_action_count => as { - my $self = shift; - for ( @{ $self->members } ) { - #pickup here, and of to the widget for listview - return scalar @{ $_->action_prototypes }; - } - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort::Collection::Grid'; +with 'Reaction::UI::ViewPort::Collection::Role::Order'; +with 'Reaction::UI::ViewPort::Collection::Role::Pager'; +with 'Reaction::UI::ViewPort::Role::Actions'; + +#If I decide that object actions and collection actions should be +#lumped together i oculd move these into the collection action role +#ooor we could create a third role that does this, but gah, no? +sub _build_member_class { WithActions }; + +#You'se has to goes aways. sorry. +#if i saved the args as an attribute i could probably get around this.... +sub object_action_count { + my $self = shift; + for ( @{ $self->members } ) { + #pickup here, and of to the widget for listview + return scalar @{ $_->action_prototypes }; + } }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/UI/ViewPort/Object.pm b/lib/Reaction/UI/ViewPort/Object.pm index 7efbe15..bc62459 100644 --- a/lib/Reaction/UI/ViewPort/Object.pm +++ b/lib/Reaction/UI/ViewPort/Object.pm @@ -15,182 +15,170 @@ use aliased 'Reaction::UI::ViewPort::Field::File'; use aliased 'Reaction::InterfaceModel::Object' => 'IM_Object'; -class Object is 'Reaction::UI::ViewPort', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::UI::ViewPort'; - #everything is read only right now. Later I can make somethings read-write - #but first I need to figure out what depends on what so we can have decent triggers - has model => (is => 'ro', isa => IM_Object, required => 1); - has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - has field_args => (is => 'rw'); - has field_order => (is => 'ro', isa => 'ArrayRef'); - has builder_cache => (is => 'ro', isa => 'HashRef', lazy_build => 1); - has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); +#everything is read only right now. Later I can make somethings read-write +#but first I need to figure out what depends on what so we can have decent triggers +has model => (is => 'ro', isa => IM_Object, required => 1); +has fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - implements BUILD => as { - my ($self, $args) = @_; - if( my $field_args = delete $args->{Field} ){ - $self->field_args( $field_args ); - } - }; - - implements _build_excluded_fields => as { [] }; - implements _build_builder_cache => as { {} }; - - implements _build_fields => as { - my ($self) = @_; - my $obj = $self->model; - my $args = $self->has_field_args ? $self->field_args : {}; - my @fields; - for my $field_name (@{ $self->computed_field_order }) { - my $attr = $obj->meta->find_attribute_by_name($field_name); - my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr); - my $field = $self->$meth($attr, ($args->{$field_name} || {})); - push(@fields, $field) if $field; - } - return \@fields; - }; - - implements _build_computed_field_order => as { - my ($self) = @_; - 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->parameter_attributes; - return $self->sort_by_spec($self->field_order || [], \@names); - }; - - override child_event_sinks => sub { - return ( @{shift->fields}, super()); - }; - - #candidate for shared role! - implements get_builder_for => as { - my ($self, $attr) = @_; - my $attr_name = $attr->name; - my $builder = "_build_fields_for_name_${attr_name}"; - return $builder if $self->can($builder); - if ($attr->has_type_constraint) { - my $constraint = $attr->type_constraint; - my $base_name = $constraint->name; - my $tried_isa = 0; - my @tried; - CONSTRAINT: while (defined($constraint)) { - my $name = $constraint->name; - $name = $attr->_isa_metadata if($name eq '__ANON__'); - if (eval { $name->can('meta') } && !$tried_isa++) { - foreach my $class ($name->meta->class_precedence_list) { - push(@tried, $class); - my $mangled_name = $class; - $mangled_name =~ s/:+/_/g; - my $builder = "_build_fields_for_type_${mangled_name}"; - return $builder if $self->can($builder); - } - } - if (defined($name)) { - push(@tried, $name); - unless (defined($base_name)) { - $base_name = "(anon subtype of ${name})"; - } - my $mangled_name = $name; +has field_args => (is => 'rw'); +has field_order => (is => 'ro', isa => 'ArrayRef'); + +has builder_cache => (is => 'ro', isa => 'HashRef', lazy_build => 1); +has excluded_fields => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); +has computed_field_order => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); +sub BUILD { + my ($self, $args) = @_; + if( my $field_args = delete $args->{Field} ){ + $self->field_args( $field_args ); + } +}; +sub _build_excluded_fields { [] }; +sub _build_builder_cache { {} }; +sub _build_fields { + my ($self) = @_; + my $obj = $self->model; + my $args = $self->has_field_args ? $self->field_args : {}; + my @fields; + for my $field_name (@{ $self->computed_field_order }) { + my $attr = $obj->meta->find_attribute_by_name($field_name); + my $meth = $self->builder_cache->{$field_name} ||= $self->get_builder_for($attr); + my $field = $self->$meth($attr, ($args->{$field_name} || {})); + push(@fields, $field) if $field; + } + return \@fields; +}; +sub _build_computed_field_order { + my ($self) = @_; + 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->parameter_attributes; + return $self->sort_by_spec($self->field_order || [], \@names); +}; + +override child_event_sinks => sub { + return ( @{shift->fields}, super()); +}; + +#candidate for shared role! +sub get_builder_for { + my ($self, $attr) = @_; + my $attr_name = $attr->name; + my $builder = "_build_fields_for_name_${attr_name}"; + return $builder if $self->can($builder); + if ($attr->has_type_constraint) { + my $constraint = $attr->type_constraint; + my $base_name = $constraint->name; + my $tried_isa = 0; + my @tried; + CONSTRAINT: while (defined($constraint)) { + my $name = $constraint->name; + $name = $attr->_isa_metadata if($name eq '__ANON__'); + if (eval { $name->can('meta') } && !$tried_isa++) { + foreach my $class ($name->meta->class_precedence_list) { + push(@tried, $class); + my $mangled_name = $class; $mangled_name =~ s/:+/_/g; my $builder = "_build_fields_for_type_${mangled_name}"; return $builder if $self->can($builder); } - $constraint = $constraint->parent; } - if (!defined($constraint)) { - confess "Can't build field ${attr_name} of type ${base_name} without " - ."$builder method or _build_fields_for_type_<type> method " - ."for type or any supertype (tried ".join(', ', @tried).")"; + if (defined($name)) { + push(@tried, $name); + unless (defined($base_name)) { + $base_name = "(anon subtype of ${name})"; + } + my $mangled_name = $name; + $mangled_name =~ s/:+/_/g; + my $builder = "_build_fields_for_type_${mangled_name}"; + return $builder if $self->can($builder); } - } else { - confess "Can't build field ${attr} without $builder method or type constraint"; + $constraint = $constraint->parent; } - }; - - implements _build_simple_field => as { - my ($self, %args) = @_; - my $class = delete $args{class}; - confess("Can not build simple field without a viewport class") - unless $class; - confess("Can not build simple field without attribute") - unless defined $args{attribute}; - - my $field_name = $args{attribute}->name; - return $class->new( - ctx => $self->ctx, - model => $self->model, - location => join('-', $self->location, 'field', $field_name), - %args - ); - }; - - implements _build_fields_for_type_Num => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Number, %$args); - }; - - implements _build_fields_for_type_Int => as { - my ($self, $attr, $args) = @_; - #XXX - $self->_build_simple_field(attribute => $attr, class => Integer, %$args); - }; - - implements _build_fields_for_type_Bool => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Boolean, %$args); - }; - + if (!defined($constraint)) { + confess "Can't build field ${attr_name} of type ${base_name} without " + ."$builder method or _build_fields_for_type_<type> method " + ."for type or any supertype (tried ".join(', ', @tried).")"; + } + } else { + confess "Can't build field ${attr} without $builder method or type constraint"; + } +}; +sub _build_simple_field { + my ($self, %args) = @_; + my $class = delete $args{class}; + confess("Can not build simple field without a viewport class") + unless $class; + confess("Can not build simple field without attribute") + unless defined $args{attribute}; + + my $field_name = $args{attribute}->name; + return $class->new( + ctx => $self->ctx, + model => $self->model, + location => join('-', $self->location, 'field', $field_name), + %args + ); +}; +sub _build_fields_for_type_Num { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Number, %$args); +}; +sub _build_fields_for_type_Int { + my ($self, $attr, $args) = @_; #XXX - implements _build_fields_for_type_Reaction_Types_Core_Password => as { return }; - - implements _build_fields_for_type_Str => as { - my ($self, $attr, $args) = @_; - #XXX - $self->_build_simple_field(attribute => $attr, class => String, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_Core_SimpleStr => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => String, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_DateTime_DateTime => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => DateTime, %$args); - }; - - implements _build_fields_for_type_Enum => as { - my ($self, $attr, $args) = @_; - #XXX - $self->_build_simple_field(attribute => $attr, class => String, %$args); - }; - - implements _build_fields_for_type_ArrayRef => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Array, %$args); - }; - - implements _build_fields_for_type_Reaction_Types_File_File => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => File, %$args); - }; - - implements _build_fields_for_type_Reaction_InterfaceModel_Object => as { - my ($self, $attr, $args) = @_; - #XXX - $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args); - }; - - implements _build_fields_for_type_Reaction_InterfaceModel_Collection => as { - my ($self, $attr, $args) = @_; - $self->_build_simple_field(attribute => $attr, class => Collection, %$args); - }; + $self->_build_simple_field(attribute => $attr, class => Integer, %$args); +}; +sub _build_fields_for_type_Bool { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Boolean, %$args); +}; +#XXX +sub _build_fields_for_type_Reaction_Types_Core_Password { return }; +sub _build_fields_for_type_Str { + my ($self, $attr, $args) = @_; + #XXX + $self->_build_simple_field(attribute => $attr, class => String, %$args); +}; +sub _build_fields_for_type_Reaction_Types_Core_SimpleStr { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => String, %$args); +}; +sub _build_fields_for_type_Reaction_Types_DateTime_DateTime { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => DateTime, %$args); +}; +sub _build_fields_for_type_Enum { + my ($self, $attr, $args) = @_; + #XXX + $self->_build_simple_field(attribute => $attr, class => String, %$args); }; +sub _build_fields_for_type_ArrayRef { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Array, %$args); +}; +sub _build_fields_for_type_Reaction_Types_File_File { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => File, %$args); +}; +sub _build_fields_for_type_Reaction_InterfaceModel_Object { + my ($self, $attr, $args) = @_; + #XXX + $self->_build_simple_field(attribute => $attr, class => RelatedObject, %$args); +}; +sub _build_fields_for_type_Reaction_InterfaceModel_Collection { + my ($self, $attr, $args) = @_; + $self->_build_simple_field(attribute => $attr, class => Collection, %$args); +}; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/ViewPort/Role/Actions.pm b/lib/Reaction/UI/ViewPort/Role/Actions.pm index f11b7a2..7da0072 100644 --- a/lib/Reaction/UI/ViewPort/Role/Actions.pm +++ b/lib/Reaction/UI/ViewPort/Role/Actions.pm @@ -3,32 +3,32 @@ package Reaction::UI::ViewPort::Role::Actions; use Reaction::Role; use Reaction::UI::ViewPort::Action::Link; -role Actions, which { - - has actions => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - has action_prototypes => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); - implements _build_action_prototypes => as { [] }; - - implements _build_actions => as { - my ($self) = @_; - my (@act, $i); - my $ctx = $self->ctx; - my $loc = $self->location; - foreach my $proto (@{ $self->action_prototypes }) { - my $action = Reaction::UI::ViewPort::Action::Link->new - ( - ctx => $ctx, - target => $self->model, - location => join ('-', $loc, 'action', $i++), - %$proto, - ); - push(@act, $action); - } - return \@act; - }; - +use namespace::clean -except => [ qw(meta) ]; + + +has actions => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); +has action_prototypes => (is => 'ro', isa => 'ArrayRef', lazy_build => 1); +sub _build_action_prototypes { [] }; +sub _build_actions { + my ($self) = @_; + my (@act, $i); + my $ctx = $self->ctx; + my $loc = $self->location; + foreach my $proto (@{ $self->action_prototypes }) { + my $action = Reaction::UI::ViewPort::Action::Link->new + ( + ctx => $ctx, + target => $self->model, + location => join ('-', $loc, 'action', $i++), + %$proto, + ); + push(@act, $action); + } + return \@act; }; + + 1; __END__; diff --git a/lib/Reaction/UI/ViewPort/SiteLayout.pm b/lib/Reaction/UI/ViewPort/SiteLayout.pm index a8ee133..2c53f8b 100644 --- a/lib/Reaction/UI/ViewPort/SiteLayout.pm +++ b/lib/Reaction/UI/ViewPort/SiteLayout.pm @@ -3,17 +3,21 @@ package Reaction::UI::ViewPort::SiteLayout; use Reaction::Class; use aliased 'Reaction::UI::ViewPort'; -class SiteLayout is ViewPort, which { +use namespace::clean -except => [ qw(meta) ]; +extends ViewPort; - has 'title' => (isa => 'Str', is => 'rw', lazy_fail => 1); - has 'static_base_uri' => (isa => 'Str', is => 'rw', lazy_fail => 1); - has 'meta_info' => ( - is => 'rw', isa => 'HashRef', - required => '1', default => sub { {} } - ); +has 'title' => (isa => 'Str', is => 'rw', lazy_fail => 1); + +has 'static_base_uri' => (isa => 'Str', is => 'rw', lazy_fail => 1); + +has 'meta_info' => ( + is => 'rw', isa => 'HashRef', + required => '1', default => sub { {} } +); + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm index ac6feaf..7e7216c 100644 --- a/lib/Reaction/UI/WidgetClass.pm +++ b/lib/Reaction/UI/WidgetClass.pm @@ -9,106 +9,104 @@ use aliased 'Reaction::UI::WidgetClass::_OVER'; no warnings 'once'; -class WidgetClass, which { - - # for local() for fragment wrap - our ($next_call, $fragment_args, $current_widget, $do_render, $new_args); - - after 'do_import' => sub { - my ($self, $package) = @_; - Devel::Declare->install_declarator( - $package, 'fragment', DECLARE_NAME, - sub { }, - sub { - WidgetClass->handle_fragment(@_); - } - ); - }; +use namespace::clean -except => [ qw(meta) ]; - after 'setup_and_cleanup' => sub { - my ($self, $package) = @_; - { - no strict 'refs'; - delete ${"${package}::"}{'fragment'}; - } - #Devel::Declare->teardown_for($package); - }; - overrides exports_for_package => sub { - my ($self, $package) = @_; - return (super(), - over => sub { - my ($collection) = @_; - confess "too many args, should be: over \$collection" if @_ > 1; - _OVER->new(collection => $collection); - }, - render => sub { - my ($name, $over) = @_; - - my $sig = "should be: render 'name' or render 'name' => over \$coll"; - if (!defined $name) { confess "name undefined: $sig"; } - if (ref $name) { confess "name not string: $sig"; } - if (defined $over && !(blessed($over) && $over->isa(_OVER))) { - confess "invalid args after name, $sig"; - } - $do_render->($package, $current_widget, $name, $over); - }, - arg => sub { - my ($name, $value) = @_; - - my $sig = "should be: arg 'name' => \$value"; - if (@_ < 2) { confess "Not enough arguments, $sig"; } - if (!defined $name) { confess "name undefined, $sig"; } - if (ref $name) { confess "name is not a string, $sig"; } - - $new_args->{$name} = $value; - }, - call_next => sub { - confess "args passed, should be just call_next; or call_next();" - if @_; - $next_call->(@$fragment_args); - }, - event_id => sub { - my ($name) = @_; - $_{viewport}->event_id_for($name); - }, - event_uri => sub { - my ($events) = @_; - my $vp = $_{viewport}; - my %args = map{ $vp->event_id_for($_) => $events->{$_} } keys %$events; - $vp->ctx->req->uri_with(\%args); - }, - ); - }; +# for local() for fragment wrap +our ($next_call, $fragment_args, $current_widget, $do_render, $new_args); - overrides default_base => sub { ('Reaction::UI::Widget') }; +after 'do_import' => sub { + my ($self, $package) = @_; + Devel::Declare->install_declarator( + $package, 'fragment', DECLARE_NAME, + sub { }, + sub { + WidgetClass->handle_fragment(@_); + } + ); +}; - implements handle_fragment => as { - my ($self, $name, $proto, $code) = @_; +after 'setup_and_cleanup' => sub { + my ($self, $package) = @_; + { + no strict 'refs'; + delete ${"${package}::"}{'fragment'}; + } + #Devel::Declare->teardown_for($package); +}; +override exports_for_package => sub { + my ($self, $package) = @_; + return (super(), + over => sub { + my ($collection) = @_; + confess "too many args, should be: over \$collection" if @_ > 1; + _OVER->new(collection => $collection); + }, + render => sub { + my ($name, $over) = @_; + + my $sig = "should be: render 'name' or render 'name' => over \$coll"; + if (!defined $name) { confess "name undefined: $sig"; } + if (ref $name) { confess "name not string: $sig"; } + if (defined $over && !(blessed($over) && $over->isa(_OVER))) { + confess "invalid args after name, $sig"; + } + $do_render->($package, $current_widget, $name, $over); + }, + arg => sub { + my ($name, $value) = @_; + + my $sig = "should be: arg 'name' => \$value"; + if (@_ < 2) { confess "Not enough arguments, $sig"; } + if (!defined $name) { confess "name undefined, $sig"; } + if (ref $name) { confess "name is not a string, $sig"; } + + $new_args->{$name} = $value; + }, + call_next => sub { + confess "args passed, should be just call_next; or call_next();" + if @_; + $next_call->(@$fragment_args); + }, + event_id => sub { + my ($name) = @_; + $_{viewport}->event_id_for($name); + }, + event_uri => sub { + my ($events) = @_; + my $vp = $_{viewport}; + my %args = map{ $vp->event_id_for($_) => $events->{$_} } keys %$events; + $vp->ctx->req->uri_with(\%args); + }, + ); +}; +override default_base => sub { ('Reaction::UI::Widget') }; +sub handle_fragment { + my ($self, $name, $proto, $code) = @_; #warn ($self, $name, $code); - return ("_fragment_${name}" => $self->wrap_as_fragment($code)); + return ("_fragment_${name}" => $self->wrap_as_fragment($code)); +}; +sub wrap_as_fragment { + my ($self, $code) = @_; + return sub { + local $next_call; + if (ref $_[0] eq 'CODE') { # inside 'around' modifier + $next_call = shift; + } + local $fragment_args = \@_; + + # $self->$method($do_render, \%_, $new_args) + local $current_widget = $_[0]; + local $do_render = $_[1]; + local *_ = \%{$_[2]}; + local $_ = $_[2]->{_}; + local $new_args = $_[3]; + $code->(@_); }; +}; - implements wrap_as_fragment => as { - my ($self, $code) = @_; - return sub { - local $next_call; - if (ref $_[0] eq 'CODE') { # inside 'around' modifier - $next_call = shift; - } - local $fragment_args = \@_; - - # $self->$method($do_render, \%_, $new_args) - local $current_widget = $_[0]; - local $do_render = $_[1]; - local *_ = \%{$_[2]}; - local $_ = $_[2]->{_}; - local $new_args = $_[3]; - $code->(@_); - }; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/UI/WidgetClass/_OVER.pm b/lib/Reaction/UI/WidgetClass/_OVER.pm index d368f23..e5d97de 100644 --- a/lib/Reaction/UI/WidgetClass/_OVER.pm +++ b/lib/Reaction/UI/WidgetClass/_OVER.pm @@ -2,33 +2,33 @@ package Reaction::UI::WidgetClass::_OVER; use Reaction::Class; -class _OVER, which { +use namespace::clean -except => [ qw(meta) ]; - has 'collection' => (is => 'ro', required => 1); - implements BUILD => as { - my ($self, $args) = @_; - my $coll = $args->{collection}; - unless (ref $coll eq 'ARRAY' || (blessed($coll) && $coll->can('next'))) { - confess _OVER."->new collection arg ${coll} is neither" - ." arrayref nor implements next()"; +has 'collection' => (is => 'ro', required => 1); +sub BUILD { + my ($self, $args) = @_; + my $coll = $args->{collection}; + unless (ref $coll eq 'ARRAY' || (blessed($coll) && $coll->can('next'))) { + confess _OVER."->new collection arg ${coll} is neither" + ." arrayref nor implements next()"; + } +}; +sub each { + my ($self, $do) = @_; + my $coll = $self->collection; + if (ref $coll eq 'ARRAY') { + foreach my $el (@$coll) { + $do->($el); } - }; - - implements 'each' => as { - my ($self, $do) = @_; - my $coll = $self->collection; - if (ref $coll eq 'ARRAY') { - foreach my $el (@$coll) { - $do->($el); - } - } else { - $coll->reset if $coll->can('reset'); - while (my $el = $coll->next) { - $do->($el); - } + } else { + $coll->reset if $coll->can('reset'); + while (my $el = $coll->next) { + $do->($el); } - }; + } }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/UI/Window.pm b/lib/Reaction/UI/Window.pm index 9e344e2..50e99af 100644 --- a/lib/Reaction/UI/Window.pm +++ b/lib/Reaction/UI/Window.pm @@ -3,77 +3,74 @@ package Reaction::UI::Window; use Reaction::Class; use Reaction::UI::FocusStack; -class Window which { - - has ctx => (isa => 'Catalyst', is => 'ro', required => 1); - has view_name => (isa => 'Str', is => 'ro', lazy_fail => 1); - has content_type => (isa => 'Str', is => 'ro', lazy_fail => 1); - has title => (isa => 'Str', is => 'rw', default => sub { 'Untitled window' }); - has view => ( - # XXX compile failure because the Catalyst::View constraint would be - # auto-generated which doesn't work with unions. ::Types::Catalyst needed. - #isa => 'Catalyst::View|Reaction::UI::View', - isa => 'Object', is => 'ro', lazy_build => 1 - ); - has focus_stack => ( - isa => 'Reaction::UI::FocusStack', - is => 'ro', required => 1, - default => sub { Reaction::UI::FocusStack->new }, - ); - - implements _build_view => as { - my ($self) = @_; - return $self->ctx->view($self->view_name); - }; - - implements flush => as { - my ($self) = @_; - $self->flush_events; - $self->flush_view; - }; - - implements flush_events => as { - my ($self) = @_; - my $ctx = $self->ctx; - - #I really think we should make a copies of the parameter hashes here - #and then as we handle events, delete ethem from the event hashref, so - #that it thins down as it makes it down the viewport tree. which would - #limit the number of events that get to the children viewports. it wont - #save that many subcalls unless there is a lot of child_items, but it's - #more about doing the correct thing. It also avoids children viewports - #being able to see their parents' events, which leaves the door open for - #abuse of the system. thoughts anyone? - - foreach my $type (qw/query body/) { - my $meth = "${type}_parameters"; - my $param_hash = $ctx->req->$meth; - $self->focus_stack->apply_events($ctx, $param_hash) - if keys %$param_hash; - } - }; - - implements flush_view => as { - my ($self) = @_; - my $res = $self->ctx->res; - if ( $res->status =~ /^3/ || length($res->body) ) { - $res->content_type('text/plain') unless $res->content_type; - return; - } - $res->body($self->view->render_window($self)); - $res->content_type($self->content_type); - }; - - # required by old Renderer::XHTML - - implements render_viewport => as { - my ($self, $vp) = @_; - return unless $vp; - return $self->view->render_viewport($self, $vp); - }; +use namespace::clean -except => [ qw(meta) ]; + + +has ctx => (isa => 'Catalyst', is => 'ro', required => 1); +has view_name => (isa => 'Str', is => 'ro', lazy_fail => 1); +has content_type => (isa => 'Str', is => 'ro', lazy_fail => 1); +has title => (isa => 'Str', is => 'rw', default => sub { 'Untitled window' }); +has view => ( + # XXX compile failure because the Catalyst::View constraint would be + # auto-generated which doesn't work with unions. ::Types::Catalyst needed. + #isa => 'Catalyst::View|Reaction::UI::View', + isa => 'Object', is => 'ro', lazy_build => 1 +); +has focus_stack => ( + isa => 'Reaction::UI::FocusStack', + is => 'ro', required => 1, + default => sub { Reaction::UI::FocusStack->new }, +); +sub _build_view { + my ($self) = @_; + return $self->ctx->view($self->view_name); +}; +sub flush { + my ($self) = @_; + $self->flush_events; + $self->flush_view; +}; +sub flush_events { + my ($self) = @_; + my $ctx = $self->ctx; + + #I really think we should make a copies of the parameter hashes here + #and then as we handle events, delete ethem from the event hashref, so + #that it thins down as it makes it down the viewport tree. which would + #limit the number of events that get to the children viewports. it wont + #save that many subcalls unless there is a lot of child_items, but it's + #more about doing the correct thing. It also avoids children viewports + #being able to see their parents' events, which leaves the door open for + #abuse of the system. thoughts anyone? + + foreach my $type (qw/query body/) { + my $meth = "${type}_parameters"; + my $param_hash = $ctx->req->$meth; + $self->focus_stack->apply_events($ctx, $param_hash) + if keys %$param_hash; + } +}; +sub flush_view { + my ($self) = @_; + my $res = $self->ctx->res; + if ( $res->status =~ /^3/ || length($res->body) ) { + $res->content_type('text/plain') unless $res->content_type; + return; + } + $res->body($self->view->render_window($self)); + $res->content_type($self->content_type); +}; +# required by old Renderer::XHTML +sub render_viewport { + my ($self, $vp) = @_; + return unless $vp; + return $self->view->render_viewport($self, $vp); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/script/rclass_back_to_moose_helper.sh b/script/rclass_back_to_moose_helper.sh index 9beb7df..fad3734 100755 --- a/script/rclass_back_to_moose_helper.sh +++ b/script/rclass_back_to_moose_helper.sh @@ -1,3 +1,3 @@ #!/bin/sh -find lib -type 'f' | egrep -v '/Widget(\.|/)' | xargs perl script/rclass_back_to_moose.pl +find lib -type 'f' | egrep -v '/Widget(\.|/)' | xargs perl ~/wdir/reaction/Reaction/0.001/trunk/script/rclass_back_to_moose.pl |