#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;
use Reaction::Class;
-class TestModel is DBIC, which {
+use namespace::clean -except => [ qw(meta) ];
+extends DBIC;
+
+
+
+__PACKAGE__->meta->make_immutable;
-};
__PACKAGE__->config
(
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;
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;
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;
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;
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
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
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;
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
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;
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;
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
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;
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
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;
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
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;
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
# 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
# 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;
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
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;
# 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;
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;
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;
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;
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;
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') ){
|| !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;
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;
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;
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;
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;
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;
#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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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__;
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;
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;
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;
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;
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__;
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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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__;
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;
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;
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;
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
#!/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
projects / catagits/Reaction.git / commitdiff