diff options
| author | matthewt <matthewt@03d0b0b2-0e1a-0410-a411-fdb2f4bd65d7> | 2008-07-24 01:42:34 +0000 |
|---|---|---|
| committer | matthewt <matthewt@03d0b0b2-0e1a-0410-a411-fdb2f4bd65d7> | 2008-07-24 01:42:34 +0000 |
| commit | 8139388160b0a38002b22ff95c3fee3d8380f156 (patch) | |
| tree | d7610c5db84c2c996107adb36bca1fe8a2b0b7cb /lib/Reaction/InterfaceModel | |
| parent | 2a4c89335368295f0fc55f79d2c8fd5e33afd212 (diff) | |
| download | reaction-8139388160b0a38002b22ff95c3fee3d8380f156.tar.gz reaction-8139388160b0a38002b22ff95c3fee3d8380f156.zip | |
rclass stuff ripped out of everything but widget classes
Diffstat (limited to 'lib/Reaction/InterfaceModel')
26 files changed, 1450 insertions, 1456 deletions
diff --git a/lib/Reaction/InterfaceModel/Action.pm b/lib/Reaction/InterfaceModel/Action.pm index 55cdfbe..7a57d78 100644 --- a/lib/Reaction/InterfaceModel/Action.pm +++ b/lib/Reaction/InterfaceModel/Action.pm @@ -6,83 +6,79 @@ use metaclass 'Reaction::Meta::InterfaceModel::Action::Class'; use Reaction::Meta::Attribute; use Reaction::Class; -class Action which { - - has target_model => (is => 'ro', required => 1, - metaclass => 'Reaction::Meta::Attribute'); - - has ctx => (isa => 'Catalyst', is => 'ro', required => 1, - metaclass => 'Reaction::Meta::Attribute'); - - implements parameter_attributes => as { - shift->meta->parameter_attributes; - }; - - implements parameter_hashref => as { - my ($self) = @_; - my %params; - foreach my $attr ($self->parameter_attributes) { - my $reader = $attr->get_read_method; - my $predicate = $attr->get_predicate_method; - next if defined($predicate) && !$self->$predicate; - $params{$attr->name} = $self->$reader; - } - return \%params; - }; - - implements can_apply => as { - my ($self) = @_; - foreach my $attr ($self->parameter_attributes) { - my $predicate = $attr->get_predicate_method; - if ($self->attribute_is_required($attr)) { - return 0 unless $self->$predicate; - } - if ($attr->has_valid_values) { - unless ($predicate && !($self->$predicate)) { - my $reader = $attr->get_read_method; - return 0 unless $attr->check_valid_value($self, $self->$reader); - } - } - } - return 1; - }; - - implements error_for => as { - my ($self, $attr) = @_; - confess "No attribute passed to error_for" unless defined($attr); - unless (ref($attr)) { - my $meta = $self->meta->find_attribute_by_name($attr); - confess "Can't find attribute ${attr} on $self" unless $meta; - $attr = $meta; - } - return $self->error_for_attribute($attr); - }; +use namespace::clean -except => [ qw(meta) ]; - implements error_for_attribute => as { - my ($self, $attr) = @_; + +has target_model => (is => 'ro', required => 1, + metaclass => 'Reaction::Meta::Attribute'); + +has ctx => (isa => 'Catalyst', is => 'ro', required => 1, + metaclass => 'Reaction::Meta::Attribute'); +sub parameter_attributes { + shift->meta->parameter_attributes; +}; +sub parameter_hashref { + my ($self) = @_; + my %params; + foreach my $attr ($self->parameter_attributes) { my $reader = $attr->get_read_method; my $predicate = $attr->get_predicate_method; + next if defined($predicate) && !$self->$predicate; + $params{$attr->name} = $self->$reader; + } + return \%params; +}; +sub can_apply { + my ($self) = @_; + foreach my $attr ($self->parameter_attributes) { + my $predicate = $attr->get_predicate_method; if ($self->attribute_is_required($attr)) { - unless ($self->$predicate) { - return $attr->name." is required"; - } + return 0 unless $self->$predicate; } - if ($self->$predicate && $attr->has_valid_values) { - unless ($attr->check_valid_value($self, $self->$reader)) { - return "Not a valid value for ".$attr->name; + if ($attr->has_valid_values) { + unless ($predicate && !($self->$predicate)) { + my $reader = $attr->get_read_method; + return 0 unless $attr->check_valid_value($self, $self->$reader); } } - return; # ok - }; + } + return 1; +}; +sub error_for { + my ($self, $attr) = @_; + confess "No attribute passed to error_for" unless defined($attr); + unless (ref($attr)) { + my $meta = $self->meta->find_attribute_by_name($attr); + confess "Can't find attribute ${attr} on $self" unless $meta; + $attr = $meta; + } + return $self->error_for_attribute($attr); +}; +sub error_for_attribute { + my ($self, $attr) = @_; + my $reader = $attr->get_read_method; + my $predicate = $attr->get_predicate_method; + if ($self->attribute_is_required($attr)) { + unless ($self->$predicate) { + return $attr->name." is required"; + } + } + if ($self->$predicate && $attr->has_valid_values) { + unless ($attr->check_valid_value($self, $self->$reader)) { + return "Not a valid value for ".$attr->name; + } + } + return; # ok +}; +sub attribute_is_required { + my ($self, $attr) = @_; + return $attr->is_required; +}; - implements attribute_is_required => as { - my ($self, $attr) = @_; - return $attr->is_required; - }; +sub sync_all { } - sub sync_all { } +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm index ad2f130..405209e 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result.pm @@ -4,10 +4,14 @@ use Reaction::InterfaceModel::Action; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Result is 'Reaction::InterfaceModel::Action', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; - has '+target_model' => (isa => Row); -}; + +has '+target_model' => (isa => Row); + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm index c30b9f6..3f4e818 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm @@ -5,13 +5,14 @@ use aliased 'Reaction::InterfaceModel::Action::Role::SimpleMethodCall'; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Delete is Result, which { - - does SimpleMethodCall; +use namespace::clean -except => [ qw(meta) ]; +extends Result; - implements _target_model_method => as { 'delete' }; +with SimpleMethodCall; +sub _target_model_method { 'delete' }; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm index 3b4c776..78e3146 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm @@ -4,39 +4,39 @@ use aliased 'Reaction::InterfaceModel::Action::DBIC::Result'; use Reaction::Types::DBIC 'Row'; use Reaction::Class; -class Update is Result, which { - - does 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; - - implements BUILD => as { - my ($self) = @_; - my $tm = $self->target_model; - foreach my $attr ($self->parameter_attributes) { - my $writer = $attr->get_write_method; - my $name = $attr->name; - my $tm_attr = $tm->meta->find_attribute_by_name($name); - next unless ref $tm_attr; - my $tm_reader = $tm_attr->get_read_method; - $self->$writer($tm->$tm_reader) if defined($tm->$tm_reader); - } - }; - - implements do_apply => as { - my $self = shift; - my $args = $self->parameter_hashref; - my $model = $self->target_model; - foreach my $name (keys %$args) { - my $tm_attr = $model->meta->find_attribute_by_name($name); - next unless ref $tm_attr; - my $tm_writer = $tm_attr->get_write_method; - $model->$tm_writer($args->{$name}); - } - $model->update; - return $model; - }; - +use namespace::clean -except => [ qw(meta) ]; +extends Result; + +with 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; +sub BUILD { + my ($self) = @_; + my $tm = $self->target_model; + foreach my $attr ($self->parameter_attributes) { + my $writer = $attr->get_write_method; + my $name = $attr->name; + my $tm_attr = $tm->meta->find_attribute_by_name($name); + next unless ref $tm_attr; + my $tm_reader = $tm_attr->get_read_method; + $self->$writer($tm->$tm_reader) if defined($tm->$tm_reader); + } +}; +sub do_apply { + my $self = shift; + my $args = $self->parameter_hashref; + my $model = $self->target_model; + foreach my $name (keys %$args) { + my $tm_attr = $model->meta->find_attribute_by_name($name); + next unless ref $tm_attr; + my $tm_writer = $tm_attr->get_write_method; + $model->$tm_writer($args->{$name}); + } + $model->update; + return $model; }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm index 3494f9b..eaaafec 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm @@ -5,45 +5,46 @@ use Reaction::Class; use Reaction::InterfaceModel::Action; use Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques; -class Create is 'Reaction::InterfaceModel::Action', which { - - does 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; - - has '+target_model' => (isa => ResultSet); - - implements do_apply => as { - my $self = shift; - my $args = $self->parameter_hashref; - my $new = $self->target_model->new({}); - my @delay; - foreach my $name (keys %$args) { - my $tm_attr = $new->meta->find_attribute_by_name($name); - unless ($tm_attr) { - warn "Unable to find attr for ${name}"; - next; - } - my $tm_writer = $tm_attr->get_write_method; - unless ($tm_writer) { - warn "Unable to find writer for ${name}"; - next; - } - if ($tm_attr->type_constraint->name eq 'ArrayRef' - || $tm_attr->type_constraint->is_subtype_of('ArrayRef')) { - push(@delay, [ $tm_writer, $args->{$name} ]); - } else { - $new->$tm_writer($args->{$name}); - } +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; + +with 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; + +has '+target_model' => (isa => ResultSet); +sub do_apply { + my $self = shift; + my $args = $self->parameter_hashref; + my $new = $self->target_model->new({}); + my @delay; + foreach my $name (keys %$args) { + my $tm_attr = $new->meta->find_attribute_by_name($name); + unless ($tm_attr) { + warn "Unable to find attr for ${name}"; + next; } - $new->insert; - foreach my $d (@delay) { - my ($meth, $val) = @$d; - $new->$meth($val); + my $tm_writer = $tm_attr->get_write_method; + unless ($tm_writer) { + warn "Unable to find writer for ${name}"; + next; } - return $new; - }; - + if ($tm_attr->type_constraint->name eq 'ArrayRef' + || $tm_attr->type_constraint->is_subtype_of('ArrayRef')) { + push(@delay, [ $tm_writer, $args->{$name} ]); + } else { + $new->$tm_writer($args->{$name}); + } + } + $new->insert; + foreach my $d (@delay) { + my ($meth, $val) = @$d; + $new->$meth($val); + } + return $new; }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm index c26e287..b30990b 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/DeleteAll.pm @@ -4,19 +4,22 @@ use Reaction::Types::DBIC 'ResultSet'; use Reaction::Class; use Reaction::InterfaceModel::Action; -class DeleteAll is 'Reaction::InterfaceModel::Action', which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; - has '+target_model' => (isa => ResultSet); - sub can_apply { 1 } - implements do_apply => as { - my $self = shift; - return $self->target_model->delete_all; - }; +has '+target_model' => (isa => ResultSet); +sub can_apply { 1 } +sub do_apply { + my $self = shift; + return $self->target_model->delete_all; }; +__PACKAGE__->meta->make_immutable; + + 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm index e4756fd..1524f8c 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm @@ -2,93 +2,93 @@ package Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques; use Reaction::Role; -role CheckUniques which { - - # requires qw(target_model - # parameter_hashref - # parameter_attributes - # ); - - has _unique_constraint_results => - ( - isa => 'HashRef', - is => 'rw', - required => 1, - default => sub { {} }, - metaclass => 'Reaction::Meta::Attribute' - ); - - implements check_all_uniques => as { - my ($self) = @_; - my $source = $self->target_model->result_source; - my %uniques = $source->unique_constraints; - my $proto = ($self->target_model->isa('DBIx::Class::ResultSet') - ? $self->target_model->new_result({}) - : $self->target_model); - my $param_hr = $self->parameter_hashref; - my %proto_hash = ( - map { - my @ret; - my $attr = $proto->meta->get_attribute($_->name); - if ($attr) { - my $reader = $attr->get_read_method; - if ($reader) { - my $value = $proto->$reader; - if (defined($value)) { - @ret = ($_->name => $value); - } +use namespace::clean -except => [ qw(meta) ]; + + +# requires qw(target_model +# parameter_hashref +# parameter_attributes +# ); + +has _unique_constraint_results => + ( + isa => 'HashRef', + is => 'rw', + required => 1, + default => sub { {} }, + metaclass => 'Reaction::Meta::Attribute' + ); +sub check_all_uniques { + my ($self) = @_; + my $source = $self->target_model->result_source; + my %uniques = $source->unique_constraints; + my $proto = ($self->target_model->isa('DBIx::Class::ResultSet') + ? $self->target_model->new_result({}) + : $self->target_model); + my $param_hr = $self->parameter_hashref; + my %proto_hash = ( + map { + my @ret; + my $attr = $proto->meta->get_attribute($_->name); + if ($attr) { + my $reader = $attr->get_read_method; + if ($reader) { + my $value = $proto->$reader; + if (defined($value)) { + @ret = ($_->name => $value); } } - @ret; - } $self->parameter_attributes - ); - my %merged = ( - %proto_hash, - (map { - (defined $param_hr->{$_} ? ($_ => $param_hr->{$_}) : ()); - } keys %$param_hr), - ); - my %ident = %{$proto->ident_condition}; - my %clashes; - my $rs = $source->resultset; - foreach my $unique (keys %uniques) { - my %pass; - my @attrs = @{$uniques{$unique}}; - next if grep { !exists $merged{$_} } @attrs; - # skip PK before insertion if auto-inc etc. etc. - @pass{@attrs} = @merged{@attrs}; - if (my $obj = $rs->find(\%pass, { key => $unique })) { - my $found_ident = $obj->ident_condition; - #warn join(', ', %$found_ident, %ident); - if (!$proto->in_storage - || (grep { $found_ident->{$_} ne $ident{$_} } keys %ident)) { - # if in storage and no ident conditions are different the found - # obj is *us* :) - $clashes{$_} = 1 for @attrs; - } + } + @ret; + } $self->parameter_attributes + ); + my %merged = ( + %proto_hash, + (map { + (defined $param_hr->{$_} ? ($_ => $param_hr->{$_}) : ()); + } keys %$param_hr), + ); + my %ident = %{$proto->ident_condition}; + my %clashes; + my $rs = $source->resultset; + foreach my $unique (keys %uniques) { + my %pass; + my @attrs = @{$uniques{$unique}}; + next if grep { !exists $merged{$_} } @attrs; + # skip PK before insertion if auto-inc etc. etc. + @pass{@attrs} = @merged{@attrs}; + if (my $obj = $rs->find(\%pass, { key => $unique })) { + my $found_ident = $obj->ident_condition; +#warn join(', ', %$found_ident, %ident); + if (!$proto->in_storage + || (grep { $found_ident->{$_} ne $ident{$_} } keys %ident)) { + # if in storage and no ident conditions are different the found + # obj is *us* :) + $clashes{$_} = 1 for @attrs; } } - $self->_unique_constraint_results(\%clashes); - }; - - after sync_all => sub { shift->check_all_uniques; }; + } + $self->_unique_constraint_results(\%clashes); +}; - override error_for_attribute => sub { - my ($self, $attr) = @_; - if ($self->_unique_constraint_results->{$attr->name}) { - return "Already taken, please try an alternative"; - } - return super(); - }; +after sync_all => sub { shift->check_all_uniques; }; - override can_apply => sub { - my ($self) = @_; - return 0 if keys %{$self->_unique_constraint_results}; - return super(); - }; +override error_for_attribute => sub { + my ($self, $attr) = @_; + if ($self->_unique_constraint_results->{$attr->name}) { + return "Already taken, please try an alternative"; + } + return super(); +}; +override can_apply => sub { + my ($self) = @_; + return 0 if keys %{$self->_unique_constraint_results}; + return super(); }; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm index 3602f86..a18b5c5 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::ChangePassword; use Reaction::Class; -class ChangePassword - is 'Reaction::InterfaceModel::Action::User::ChangePassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::ChangePassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm index 6620d30..169f92c 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::ResetPassword; use Reaction::Class; -class ResetPassword - is 'Reaction::InterfaceModel::Action::User::ResetPassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::ResetPassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm index 0cd41a8..68c3895 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm @@ -2,20 +2,20 @@ package Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword; use Reaction::Role; -role SetPassword, which { +use namespace::clean -except => [ qw(meta) ]; - #requires qw/target_model/; - - implements do_apply => as { - my $self = shift; - my $user = $self->target_model; - $user->password($self->new_password); - $user->update; - return $user; - }; +#requires qw/target_model/; +sub do_apply { + my $self = shift; + my $user = $self->target_model; + $user->password($self->new_password); + $user->update; + return $user; }; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm index b15e218..bca939a 100644 --- a/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm @@ -2,13 +2,13 @@ package Reaction::InterfaceModel::Action::DBIC::User::SetPassword; use Reaction::Class; -class SetPassword - is 'Reaction::InterfaceModel::Action::User::SetPassword', - which { +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::SetPassword'; - does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; +with 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm index 6546502..f637284 100644 --- a/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm @@ -4,38 +4,41 @@ use Reaction::Class; use Reaction::Types::Core qw(Password); -class ChangePassword is 'Reaction::InterfaceModel::Action::User::SetPassword', which { - has old_password => (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'old_password') { - return "Old password incorrect" - unless $self->verify_old_password; - } - #return $super->(@_); #commented out because the original didn't super() - }; - - around can_apply => sub { - my $super = shift; - my ($self) = @_; - return 0 unless $self->verify_old_password; - return $super->(@_); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action::User::SetPassword'; + + +has old_password => (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'old_password') { + return "Old password incorrect" + unless $self->verify_old_password; + } + #return $super->(@_); #commented out because the original didn't super() +}; + +around can_apply => sub { + my $super = shift; + my ($self) = @_; + return 0 unless $self->verify_old_password; + return $super->(@_); +}; +sub verify_old_password { + my $self = shift; + return unless $self->has_old_password; - implements verify_old_password => as { - my $self = shift; - return unless $self->has_old_password; - - my $user = $self->target_model; - return $user->can("check_password") ? + my $user = $self->target_model; + return $user->can("check_password") ? $user->check_password($self->old_password) : $self->old_password eq $user->password; - }; - }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/User/Login.pm b/lib/Reaction/InterfaceModel/Action/User/Login.pm index 46dddea..31abd8b 100644 --- a/lib/Reaction/InterfaceModel/Action/User/Login.pm +++ b/lib/Reaction/InterfaceModel/Action/User/Login.pm @@ -4,28 +4,31 @@ use Reaction::Class; use aliased 'Reaction::InterfaceModel::Action'; use Reaction::Types::Core qw(SimpleStr Password); -class Login, is Action, which { - - has 'username' => (isa => SimpleStr, is => 'rw', lazy_fail => 1); - has 'password' => (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - my $result = $super->(@_); - my $predicate = $attr->get_predicate_method; - if (defined $result && $self->$predicate) { - return 'Invalid username or password'; - } - return; - }; - - implements do_apply => as { - my $self = shift; - my $target = $self->target_model; - return $target->login($self->username, $self->password); - }; +use namespace::clean -except => [ qw(meta) ]; +extends Action; + + + +has 'username' => (isa => SimpleStr, is => 'rw', lazy_fail => 1); +has 'password' => (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + my $result = $super->(@_); + my $predicate = $attr->get_predicate_method; + if (defined $result && $self->$predicate) { + return 'Invalid username or password'; + } + return; +}; +sub do_apply { + my $self = shift; + my $target = $self->target_model; + return $target->login($self->username, $self->password); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm index 2637dc0..3c5d8d6 100644 --- a/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm @@ -9,31 +9,32 @@ use aliased 'Reaction::InterfaceModel::Action::User::SetPassword'; use Reaction::Types::Core qw(NonEmptySimpleStr); -class ResetPassword is SetPassword, which { - - does ConfirmationCodeSupport; - - has confirmation_code => - (isa => NonEmptySimpleStr, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'confirmation_code') { - return "Confirmation code incorrect" - unless $self->verify_confirmation_code; - } - #return $super->(@_); #commented out because the original didn't super() - }; - - implements verify_confirmation_code => as { - my $self = shift; - return $self->has_confirmation_code - && ($self->confirmation_code eq $self->generate_confirmation_code); - }; - +use namespace::clean -except => [ qw(meta) ]; +extends SetPassword; + +with ConfirmationCodeSupport; + +has confirmation_code => + (isa => NonEmptySimpleStr, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'confirmation_code') { + return "Confirmation code incorrect" + unless $self->verify_confirmation_code; + } + #return $super->(@_); #commented out because the original didn't super() +}; +sub verify_confirmation_code { + my $self = shift; + return $self->has_confirmation_code + && ($self->confirmation_code eq $self->generate_confirmation_code); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm index 649f76a..1b85d26 100644 --- a/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm +++ b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm @@ -3,21 +3,21 @@ package Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport; use Reaction::Role; use Digest::MD5; -role ConfirmationCodeSupport, which{ - - #requires qw/target_model ctx/; +use namespace::clean -except => [ qw(meta) ]; + + +#requires qw/target_model ctx/; +sub generate_confirmation_code { + my $self = shift; + my $ident = $self->target_model->identity_string. + $self->target_model->password; + my $secret = $self->ctx->config->{confirmation_code_secret}; + die "Application config does not define confirmation_code_secret" + unless $secret; + return Digest::MD5::md5_hex($secret.$ident); +}; - implements generate_confirmation_code => as { - my $self = shift; - my $ident = $self->target_model->identity_string. - $self->target_model->password; - my $secret = $self->ctx->config->{confirmation_code_secret}; - die "Application config does not define confirmation_code_secret" - unless $secret; - return Digest::MD5::md5_hex($secret.$ident); - }; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm index 14a561a..b9aa5d5 100644 --- a/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm +++ b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm @@ -4,37 +4,40 @@ use Reaction::Class; use Reaction::InterfaceModel::Action; use Reaction::Types::Core qw(Password); -class SetPassword is 'Reaction::InterfaceModel::Action', which { - - has new_password => (isa => Password, is => 'rw', lazy_fail => 1); - has confirm_new_password => - (isa => Password, is => 'rw', lazy_fail => 1); - - around error_for_attribute => sub { - my $super = shift; - my ($self, $attr) = @_; - if ($attr->name eq 'confirm_new_password') { - return "New password doesn't match" - unless $self->verify_confirm_new_password; - } - return $super->(@_); - }; - - around can_apply => sub { - my $super = shift; - my ($self) = @_; - return 0 unless $self->verify_confirm_new_password; - return $super->(@_); - }; - - implements verify_confirm_new_password => as { - my $self = shift; - return $self->has_new_password && $self->has_confirm_new_password - && ($self->new_password eq $self->confirm_new_password); - }; +use namespace::clean -except => [ qw(meta) ]; +extends 'Reaction::InterfaceModel::Action'; + + +has new_password => (isa => Password, is => 'rw', lazy_fail => 1); +has confirm_new_password => + (isa => Password, is => 'rw', lazy_fail => 1); + +around error_for_attribute => sub { + my $super = shift; + my ($self, $attr) = @_; + if ($attr->name eq 'confirm_new_password') { + return "New password doesn't match" + unless $self->verify_confirm_new_password; + } + return $super->(@_); +}; + +around can_apply => sub { + my $super = shift; + my ($self) = @_; + return 0 unless $self->verify_confirm_new_password; + return $super->(@_); +}; +sub verify_confirm_new_password { + my $self = shift; + return $self->has_new_password && $self->has_confirm_new_password + && ($self->new_password eq $self->confirm_new_password); }; +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection.pm b/lib/Reaction/InterfaceModel/Collection.pm index 068e1c0..614e51b 100644 --- a/lib/Reaction/InterfaceModel/Collection.pm +++ b/lib/Reaction/InterfaceModel/Collection.pm @@ -6,73 +6,74 @@ use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute'; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class Collection is "Reaction::InterfaceModel::Object", which { - - # consider supporting slice, first, iterator, last etc. - # pager functionality should probably be a role - - # IM objects don't have write methods because those are handled through actions, - # no support for write actions either unless someone makes a good case for it - # many models may not even be writable, so we cant make that assumption... - - # I feel like we should hasa result_class or object_class ? - # having this here would remove a lot of PITA complexity from - # ObjectClass and SchemaClass when it comes to munging with internals - - #Answer: No, because collections should be able to hold more than one type of object - - # ALL IMPLEMENTATIONS ARE TO ILLUSTRATE POSSIBLE BEHAVIOR ONLY. DON'T CONSIDER - # THEM CORRECT, OR FINAL. JUST A ROUGH DRAFT. - - #domain_models are 'ro' unless otherwise specified - has _collection_store => ( - is => 'rw', - isa => 'ArrayRef', - lazy_build => 1, - clearer => "_clear_collection_store", - metaclass => DomainModelAttribute, - ); - - has 'member_type' => (is => 'ro', isa => 'ClassName'); - - implements _build__collection_store => as { [] }; - - implements members => as { - my $self = shift; - return @{ $self->_collection_store }; - }; - - #return new member or it's index # ? - implements add_member => as { - my $self = shift; - my $new = shift; - confess "Argument passed is not an object" unless blessed $new; - confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" - unless $new->isa('Reaction::InterfaceModel::Object'); - my $store = $self->_collection_store; - push @$store, $new; - return $#$store; #return index # of inserted item - }; - - implements remove_member => as { - my $self = shift; - my $rem = shift; - confess "Argument passed is not an object" unless blessed $rem; - confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" - unless $rem->isa('Reaction::InterfaceModel::Object'); - - my $addr = refaddr $rem; - @{ $self->_collection_store } = grep {$addr ne refaddr $_ } @{ $self->_store }; - }; - - #that was easy.. - implements count_members => sub{ - my $self = shift; - return scalar @{ $self->_collection_store }; - }; +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Object"; + + +# consider supporting slice, first, iterator, last etc. +# pager functionality should probably be a role + +# IM objects don't have write methods because those are handled through actions, +# no support for write actions either unless someone makes a good case for it +# many models may not even be writable, so we cant make that assumption... + +# I feel like we should hasa result_class or object_class ? +# having this here would remove a lot of PITA complexity from +# ObjectClass and SchemaClass when it comes to munging with internals + +#Answer: No, because collections should be able to hold more than one type of object + +# ALL IMPLEMENTATIONS ARE TO ILLUSTRATE POSSIBLE BEHAVIOR ONLY. DON'T CONSIDER +# THEM CORRECT, OR FINAL. JUST A ROUGH DRAFT. + +#domain_models are 'ro' unless otherwise specified +has _collection_store => ( + is => 'rw', + isa => 'ArrayRef', + lazy_build => 1, + clearer => "_clear_collection_store", + metaclass => DomainModelAttribute, + ); + +has 'member_type' => (is => 'ro', isa => 'ClassName'); +sub _build__collection_store { [] }; +sub members { + my $self = shift; + return @{ $self->_collection_store }; }; +#return new member or it's index # ? +sub add_member { + my $self = shift; + my $new = shift; + confess "Argument passed is not an object" unless blessed $new; + confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" + unless $new->isa('Reaction::InterfaceModel::Object'); + my $store = $self->_collection_store; + push @$store, $new; + return $#$store; #return index # of inserted item +}; +sub remove_member { + my $self = shift; + my $rem = shift; + confess "Argument passed is not an object" unless blessed $rem; + confess "Object Passed does not meet constraint isa Reaction::InterfaceModel::Object" + unless $rem->isa('Reaction::InterfaceModel::Object'); + + my $addr = refaddr $rem; + @{ $self->_collection_store } = grep {$addr ne refaddr $_ } @{ $self->_store }; +}; + +#that was easy.. +sub count_members { + my $self = shift; + return scalar @{ $self->_collection_store }; +}; + +__PACKAGE__->meta->make_immutable; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm index 7b82176..b9acae9 100644 --- a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm @@ -6,87 +6,80 @@ use Class::MOP; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -role Base, which { - - has '_source_resultset' => ( - is => 'ro', - required => 1, - isa => 'DBIx::Class::ResultSet', - ); - - has 'member_type' => ( - is => 'rw', - isa => 'ClassName', - required => 1, - builder => '_build_member_type', - clearer => 'clear_member_type', - predicate => 'has_member_type', - ); - - - #implements BUILD => as { - # my $self = shift; - # Class::MOP::load_class($self->_im_class); - # confess "_im_result_class must be a Reaction::InterfaceModel::Object" - # unless $self->_im_class->isa("Reaction::InterfaceModel::Object"); - # confess "_im_result_class must have an inflate_result method" - # unless $self->_im_class->can("inflate_result"); - #}; - - - - #Oh man. I have a bad feeling about this one. - implements _build_member_type => as { - my $self = shift; - my $class = blessed($self) || $self; - $class =~ s/::Collection$//; - return $class; - }; - - implements _build__collection_store => as { - my $self = shift; - [ $self->_source_resultset->search({}, {result_class => $self->member_type})->all ]; - }; - - implements clone => as { - my $self = shift; - my $rs = $self->_source_resultset; #->search_rs({}); - #should the clone include the arrayref of IM::Objects too? - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type, @_ - ); - }; - - implements count_members => as { - my $self = shift; - $self->_source_resultset->count; - }; - - implements add_member => as { - confess "Not yet implemented"; - }; - - implements remove_member => as { - confess "Not yet implemented"; - }; - - - implements page => as { - my $self = shift; - my $rs = $self->_source_resultset->page(@_); - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type, - ); - }; - - implements pager => as { - my $self = shift; - return $self->_source_resultset->pager(@_); - }; - +use namespace::clean -except => [ qw(meta) ]; + + +has '_source_resultset' => ( + is => 'ro', + required => 1, + isa => 'DBIx::Class::ResultSet', + ); + +has 'member_type' => ( + is => 'rw', + isa => 'ClassName', + required => 1, + builder => '_build_member_type', + clearer => 'clear_member_type', + predicate => 'has_member_type', + ); + + +#implements BUILD => as { +# my $self = shift; +# Class::MOP::load_class($self->_im_class); +# confess "_im_result_class must be a Reaction::InterfaceModel::Object" +# unless $self->_im_class->isa("Reaction::InterfaceModel::Object"); +# confess "_im_result_class must have an inflate_result method" +# unless $self->_im_class->can("inflate_result"); +#}; + + + +#Oh man. I have a bad feeling about this one. +sub _build_member_type { + my $self = shift; + my $class = blessed($self) || $self; + $class =~ s/::Collection$//; + return $class; +}; +sub _build__collection_store { + my $self = shift; + [ $self->_source_resultset->search({}, {result_class => $self->member_type})->all ]; +}; +sub clone { + my $self = shift; + my $rs = $self->_source_resultset; #->search_rs({}); + #should the clone include the arrayref of IM::Objects too? + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type, @_ + ); +}; +sub count_members { + my $self = shift; + $self->_source_resultset->count; +}; +sub add_member { + confess "Not yet implemented"; }; +sub remove_member { + confess "Not yet implemented"; +}; +sub page { + my $self = shift; + my $rs = $self->_source_resultset->page(@_); + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type, + ); +}; +sub pager { + my $self = shift; + return $self->_source_resultset->pager(@_); +}; + + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm index c5459ae..c612cb8 100644 --- a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm @@ -3,35 +3,35 @@ package Reaction::InterfaceModel::Collection::DBIC::Role::Where; use Reaction::Role; use Scalar::Util qw/blessed/; -role Where, which { - - #requires qw/_source_resultset _im_class/; - implements where => as { - my $self = shift; - my $rs = $self->_source_resultset->search_rs(@_); - return (blessed $self)->new( - _source_resultset => $rs, - member_type => $self->member_type - ); - }; - - implements add_where => as { - my $self = shift; - my $rs = $self->_source_resultset->search_rs(@_); - $self->_source_resultset($rs); - $self->_clear_collection_store if $self->_has_collection_store; - return $self; - }; - - #XXX may need a rename, but i needed this for ListView - implements find => as { - my $self = shift; - $self->_source_resultset - ->search({},{result_class => $self->member_type}) - ->find(@_); - }; +use namespace::clean -except => [ qw(meta) ]; + + +#requires qw/_source_resultset _im_class/; +sub where { + my $self = shift; + my $rs = $self->_source_resultset->search_rs(@_); + return (blessed $self)->new( + _source_resultset => $rs, + member_type => $self->member_type + ); +}; +sub add_where { + my $self = shift; + my $rs = $self->_source_resultset->search_rs(@_); + $self->_source_resultset($rs); + $self->_clear_collection_store if $self->_has_collection_store; + return $self; }; +#XXX may need a rename, but i needed this for ListView +sub find { + my $self = shift; + $self->_source_resultset + ->search({},{result_class => $self->member_type}) + ->find(@_); +}; + + 1; =head1 NAME diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent.pm b/lib/Reaction/InterfaceModel/Collection/Persistent.pm index d023a6c..ebf1fc9 100644 --- a/lib/Reaction/InterfaceModel/Collection/Persistent.pm +++ b/lib/Reaction/InterfaceModel/Collection/Persistent.pm @@ -3,10 +3,14 @@ package Reaction::InterfaceModel::Collection::Persistent; use Reaction::Class; use aliased 'Reaction::InterfaceModel::Collection'; -class Persistent is Collection, which { +use namespace::clean -except => [ qw(meta) ]; +extends Collection; -}; + + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm index a73e5cc..6ca63fb 100644 --- a/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm +++ b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm @@ -4,11 +4,13 @@ use Reaction::Class; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class ResultSet is "Reaction::InterfaceModel::Collection::Persistent", which{ +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Collection::Persistent"; - does "Reaction::InterfaceModel::Collection::DBIC::Role::Base"; +with "Reaction::InterfaceModel::Collection::DBIC::Role::Base"; + +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual.pm b/lib/Reaction/InterfaceModel/Collection/Virtual.pm index df81496..6a958b6 100644 --- a/lib/Reaction/InterfaceModel/Collection/Virtual.pm +++ b/lib/Reaction/InterfaceModel/Collection/Virtual.pm @@ -3,10 +3,14 @@ package Reaction::InterfaceModel::Collection::Virtual; use Reaction::Class; use aliased 'Reaction::InterfaceModel::Collection'; -class Virtual is Collection, which { +use namespace::clean -except => [ qw(meta) ]; +extends Collection; -}; + + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm index 5c905d7..41a4b36 100644 --- a/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm +++ b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm @@ -3,17 +3,17 @@ package Reaction::InterfaceModel::Collection::Virtual::ResultSet; use Reaction::Class; # WARNING - DANGER: this is just an RFC, please DO NOT USE YET -class ResultSet is "Reaction::InterfaceModel::Collection::Virtual", which { - - does "Reaction::InterfaceModel::Collection::DBIC::Role::Base", - "Reaction::InterfaceModel::Collection::DBIC::Role::Where"; +use namespace::clean -except => [ qw(meta) ]; +extends "Reaction::InterfaceModel::Collection::Virtual"; +with "Reaction::InterfaceModel::Collection::DBIC::Role::Base", + "Reaction::InterfaceModel::Collection::DBIC::Role::Where"; +sub _build__default_action_class_prefix { + shift->member_type; +}; - implements _build__default_action_class_prefix => as { - shift->member_type; - }; +__PACKAGE__->meta->make_immutable; -}; 1; diff --git a/lib/Reaction/InterfaceModel/Object.pm b/lib/Reaction/InterfaceModel/Object.pm index fce4fd2..cd3c3db 100644 --- a/lib/Reaction/InterfaceModel/Object.pm +++ b/lib/Reaction/InterfaceModel/Object.pm @@ -4,74 +4,73 @@ use metaclass 'Reaction::Meta::InterfaceModel::Object::Class'; use Reaction::Meta::Attribute; use Reaction::Class; -class Object which { - - has _action_class_map => - (is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, - metaclass => 'Reaction::Meta::Attribute'); - - has _default_action_class_prefix => - ( - is => 'ro', - isa => 'Str', - lazy_build => 1, - metaclass => 'Reaction::Meta::Attribute', - ); - - #DBIC::Collection would override this to use result_class for example - implements _build__default_action_class_prefix => as { - my $self = shift; - ref $self || $self; - }; - - #just a little convenience - implements parameter_attributes => as { - shift->meta->parameter_attributes; - }; - - #just a little convenience - implements domain_models => as { - shift->meta->domain_models; - }; - - implements '_default_action_class_for' => as { - my ($self, $action) = @_; - confess("Wrong arguments") unless $action; - #little trick in case we call it in class context! - my $prefix = ref $self ? - $self->_default_action_class_prefix : - $self->_build__default_action_class_prefix; - - return join "::", $prefix, 'Action', $action; - }; - - implements '_action_class_for' => as { - my ($self, $action) = @_; - confess("Wrong arguments") unless $action; - if (defined (my $class = $self->_action_class_map->{$action})) { - return $class; - } - return $self->_default_action_class_for($action); - }; - - implements 'action_for' => as { - my ($self, $action, %args) = @_; - confess("Wrong arguments") unless $action; - my $class = $self->_action_class_for($action); - %args = ( - %{$self->_default_action_args_for($action)}, - %args, - %{$self->_override_action_args_for($action)}, - ); - return $class->new(%args); - }; - - #this really needs to be smarter, fine for CRUD, shit for anything else - # massive fucking reworking needed here, really - implements _default_action_args_for => as { {} }; - implements _override_action_args_for => as { {} }; +use namespace::clean -except => [ qw(meta) ]; + +has _action_class_map => + (is => 'rw', isa => 'HashRef', required => 1, default => sub{ {} }, + metaclass => 'Reaction::Meta::Attribute'); + +has _default_action_class_prefix => + ( + is => 'ro', + isa => 'Str', + lazy_build => 1, + metaclass => 'Reaction::Meta::Attribute', + ); + +#DBIC::Collection would override this to use result_class for example +sub _build__default_action_class_prefix { + my $self = shift; + ref $self || $self; +}; + +#just a little convenience +sub parameter_attributes { + shift->meta->parameter_attributes; +}; + +#just a little convenience +sub domain_models { + shift->meta->domain_models; }; +sub _default_action_class_for { + my ($self, $action) = @_; + confess("Wrong arguments") unless $action; + #little trick in case we call it in class context! + my $prefix = ref $self ? + $self->_default_action_class_prefix : + $self->_build__default_action_class_prefix; + + return join "::", $prefix, 'Action', $action; +}; +sub _action_class_for { + my ($self, $action) = @_; + confess("Wrong arguments") unless $action; + if (defined (my $class = $self->_action_class_map->{$action})) { + return $class; + } + return $self->_default_action_class_for($action); +}; +sub action_for { + my ($self, $action, %args) = @_; + confess("Wrong arguments") unless $action; + my $class = $self->_action_class_for($action); + %args = ( + %{$self->_default_action_args_for($action)}, + %args, + %{$self->_override_action_args_for($action)}, + ); + return $class->new(%args); +}; + +#this really needs to be smarter, fine for CRUD, shit for anything else +# massive fucking reworking needed here, really +sub _default_action_args_for { {} }; +sub _override_action_args_for { {} }; + +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/ObjectClass.pm b/lib/Reaction/InterfaceModel/ObjectClass.pm index 2ea5fb6..b2f70fb 100644 --- a/lib/Reaction/InterfaceModel/ObjectClass.pm +++ b/lib/Reaction/InterfaceModel/ObjectClass.pm @@ -5,18 +5,17 @@ use Reaction::Class; use Reaction::InterfaceModel::Object; -class ObjectClass which { - - overrides default_base => sub { ('Reaction::InterfaceModel::Object') }; - - overrides exports_for_package => sub { - my ($self, $package) = @_; - return (super(), - domain_model => sub { - $package->meta->add_domain_model(@_); - }, - ); - }; +use namespace::clean -except => [ qw(meta) ]; +override default_base => sub { ('Reaction::InterfaceModel::Object') }; +override exports_for_package => sub { + my ($self, $package) = @_; + return (super(), + domain_model => sub { + $package->meta->add_domain_model(@_); + }, + ); }; +__PACKAGE__->meta->make_immutable; + 1; diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm index cde8c79..4d14edd 100644 --- a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm +++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm @@ -13,757 +13,500 @@ use Class::MOP; use Catalyst::Utils; -class DBIC, which { - - has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 }); - - #user defined actions and prototypes - has object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); - has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); - - #which actions to create by default - has default_object_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); - has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); - - #builtin actions and prototypes - has builtin_object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); - has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); - - implements _build_object_actions => as { {} }; - implements _build_collection_actions => as { {} }; - - implements _build_default_object_actions => as { [ qw/Update Delete/ ] }; - implements _build_default_collection_actions => as { [ qw/Create DeleteAll/ ] }; - - implements _build_builtin_object_actions => as { - { - Update => { name => 'Update', base => Update }, - Delete => { name => 'Delete', base => Delete, attributes => [] }, - }; - }; - - implements _build_builtin_collection_actions => as { - { - Create => {name => 'Create', base => Create }, - DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] } - }; - }; - - implements _all_object_actions => as { - my $self = shift; - return $self->merge_hashes - ($self->builtin_object_actions, $self->object_actions); - }; - - implements _all_collection_actions => as { - my $self = shift; - return $self->merge_hashes - ($self->builtin_collection_actions, $self->collection_actions); - }; - - implements dm_name_from_class_name => as { - my($self, $class) = @_; - confess("wrong arguments") unless $class; - $class =~ s/::/_/g; - $class = "_" . $self->_class_to_attribute_name($class) . "_store"; - return $class; - }; - - implements dm_name_from_source_name => as { - my($self, $source) = @_; - confess("wrong arguments") unless $source; - $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; - $source = "_" . $self->_class_to_attribute_name($source) . "_store"; - return $source; - }; - - implements class_name_from_source_name => as { - my ($self, $model_class, $source_name) = @_; - confess("wrong arguments") unless $model_class && $source_name; - return join "::", $model_class, $source_name; - }; - - implements class_name_for_collection_of => as { - my ($self, $object_class) = @_; - confess("wrong arguments") unless $object_class; - return "${object_class}::Collection"; - }; - - implements merge_hashes => as { - my($self, $left, $right) = @_; - return Catalyst::Utils::merge_hashes($left, $right); +use namespace::clean -except => [ qw(meta) ]; + + +has make_classes_immutable => (isa => "Bool", is => "rw", required => 1, default => sub{ 1 }); + +#user defined actions and prototypes +has object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); +has collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); + +#which actions to create by default +has default_object_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); +has default_collection_actions => (isa => "ArrayRef", is => "rw", lazy_build => 1); + +#builtin actions and prototypes +has builtin_object_actions => (isa => "HashRef", is => "rw", lazy_build => 1); +has builtin_collection_actions => (isa => "HashRef", is => "rw", lazy_build => 1); +sub _build_object_actions { {} }; +sub _build_collection_actions { {} }; +sub _build_default_object_actions { [ qw/Update Delete/ ] }; +sub _build_default_collection_actions { [ qw/Create DeleteAll/ ] }; +sub _build_builtin_object_actions { + { + Update => { name => 'Update', base => Update }, + Delete => { name => 'Delete', base => Delete, attributes => [] }, }; - - implements parse_reflect_rules => as { - my ($self, $rules, $haystack) = @_; - confess('$rules must be an array reference') unless ref $rules eq 'ARRAY'; - confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY'; - - my $needles = {}; - my (@exclude, @include, $global_opts); - if(@$rules == 2 && $rules->[0] eq '-exclude'){ - push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1])); - } else { - for my $rule ( @$rules ){ - if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){ - push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1])); - } elsif( ref $rule eq 'HASH' ){ - $global_opts = ref $global_opts eq 'HASH' ? - $self->merge_hashes($global_opts, $rule) : $rule; - } else { - push(@include, $rule); - } - } - } - my $check_exclude = sub{ - for my $rule (@exclude){ - return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule); - } - return; - }; - - @$haystack = grep { !$check_exclude->($_) } @$haystack; - $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts); - return $needles; +}; +sub _build_builtin_collection_actions { + { + Create => {name => 'Create', base => Create }, + DeleteAll => {name => 'DeleteAll', base => DeleteAll, attributes => [] } }; - - implements merge_reflect_rules => as { - my ($self, $rules, $needles, $haystack, $local_opts) = @_; +}; +sub _all_object_actions { + my $self = shift; + return $self->merge_hashes + ($self->builtin_object_actions, $self->object_actions); +}; +sub _all_collection_actions { + my $self = shift; + return $self->merge_hashes + ($self->builtin_collection_actions, $self->collection_actions); +}; +sub dm_name_from_class_name { + my($self, $class) = @_; + confess("wrong arguments") unless $class; + $class =~ s/::/_/g; + $class = "_" . $self->_class_to_attribute_name($class) . "_store"; + return $class; +}; +sub dm_name_from_source_name { + my($self, $source) = @_; + confess("wrong arguments") unless $source; + $source =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $source = "_" . $self->_class_to_attribute_name($source) . "_store"; + return $source; +}; +sub class_name_from_source_name { + my ($self, $model_class, $source_name) = @_; + confess("wrong arguments") unless $model_class && $source_name; + return join "::", $model_class, $source_name; +}; +sub class_name_for_collection_of { + my ($self, $object_class) = @_; + confess("wrong arguments") unless $object_class; + return "${object_class}::Collection"; +}; +sub merge_hashes { + my($self, $left, $right) = @_; + return Catalyst::Utils::merge_hashes($left, $right); +}; +sub parse_reflect_rules { + my ($self, $rules, $haystack) = @_; + confess('$rules must be an array reference') unless ref $rules eq 'ARRAY'; + confess('$haystack must be an array reference') unless ref $haystack eq 'ARRAY'; + + my $needles = {}; + my (@exclude, @include, $global_opts); + if(@$rules == 2 && $rules->[0] eq '-exclude'){ + push(@exclude, (ref $rules->[1] eq 'ARRAY' ? @{$rules->[1]} : $rules->[1])); + } else { for my $rule ( @$rules ){ - if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){ - $needles->{$rule} = defined $needles->{$rule} ? - $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts; - } elsif( ref $rule eq 'Regexp' ){ - for my $match ( grep { /$rule/ } @$haystack ){ - $needles->{$match} = defined $needles->{$match} ? - $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts; - } - } elsif( ref $rule eq 'ARRAY' ){ - my $opts; - $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH'; - $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts; - $self->merge_reflect_rules($rule, $needles, $haystack, $opts); + if (ref $rule eq 'ARRAY' && $rule->[0] eq '-exclude'){ + push(@exclude, (ref $rule->[1] eq 'ARRAY' ? @{$rule->[1]} : $rule->[1])); + } elsif( ref $rule eq 'HASH' ){ + $global_opts = ref $global_opts eq 'HASH' ? + $self->merge_hashes($global_opts, $rule) : $rule; + } else { + push(@include, $rule); } } + } + my $check_exclude = sub{ + for my $rule (@exclude){ + return 1 if(ref $rule eq 'Regexp' ? $_[0] =~ /$rule/ : $_[0] eq $rule); + } + return; }; - implements reflect_schema => as { - my ($self, %opts) = @_; - my $base = delete $opts{base} || Object; - my $model = delete $opts{model_class}; - my $schema = delete $opts{schema_class}; - my $dm_name = delete $opts{domain_model_name}; - my $dm_args = delete $opts{domain_model_args} || {}; - $dm_name ||= $self->dm_name_from_class_name($schema); - - #load all necessary classes - confess("model_class and schema_class are required parameters") - unless($model && $schema); - Class::MOP::load_class( $base ); - Class::MOP::load_class( $schema ); - my $meta = $self->_load_or_create($model, $base); - - # sources => undef, #default to qr/./ - # sources => [], #default to nothing - # sources => qr//, #DWIM, treated as [qr//] - # sources => [{...}] #DWIM, treat as [qr/./, {...} ] - # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] - my $haystack = [ $schema->sources ]; - - my $rules = delete $opts{sources}; - if(!defined $rules){ - $rules = [qr/./]; - } elsif( ref $rules eq 'Regexp'){ - $rules = [ $rules ]; - } elsif( ref $rules eq 'ARRAY' && @$rules){ - #don't add a qr/./ rule if we have at least one match rule - push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') - || !ref $_ || ref $_ eq 'Regexp'} @$rules; + @$haystack = grep { !$check_exclude->($_) } @$haystack; + $self->merge_reflect_rules(\@include, $needles, $haystack, $global_opts); + return $needles; +}; +sub merge_reflect_rules { + my ($self, $rules, $needles, $haystack, $local_opts) = @_; + for my $rule ( @$rules ){ + if(!ref $rule && ( grep {$rule eq $_} @$haystack ) ){ + $needles->{$rule} = defined $needles->{$rule} ? + $self->merge_hashes($needles->{$rule}, $local_opts) : $local_opts; + } elsif( ref $rule eq 'Regexp' ){ + for my $match ( grep { /$rule/ } @$haystack ){ + $needles->{$match} = defined $needles->{$match} ? + $self->merge_hashes($needles->{$match}, $local_opts) : $local_opts; + } + } elsif( ref $rule eq 'ARRAY' ){ + my $opts; + $opts = pop(@$rule) if @$rule > 1 and ref $rule->[$#$rule] eq 'HASH'; + $opts = $self->merge_hashes($local_opts, $opts) if defined $local_opts; + $self->merge_reflect_rules($rule, $needles, $haystack, $opts); } - - my $sources = $self->parse_reflect_rules($rules, $haystack); - - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; - $meta->make_mutable if $meta->is_immutable; - - $meta->add_domain_model - ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args); - - for my $source_name (keys %$sources){ - my $source_opts = $sources->{$source_name} || {}; - $self->reflect_source( - source_name => $source_name, - parent_class => $model, - schema_class => $schema, - source_class => $schema->class($source_name), - parent_domain_model_name => $dm_name, - %$source_opts - ); + } +}; +sub reflect_schema { + my ($self, %opts) = @_; + my $base = delete $opts{base} || Object; + my $model = delete $opts{model_class}; + my $schema = delete $opts{schema_class}; + my $dm_name = delete $opts{domain_model_name}; + my $dm_args = delete $opts{domain_model_args} || {}; + $dm_name ||= $self->dm_name_from_class_name($schema); + + #load all necessary classes + confess("model_class and schema_class are required parameters") + unless($model && $schema); + Class::MOP::load_class( $base ); + Class::MOP::load_class( $schema ); + my $meta = $self->_load_or_create($model, $base); + + # sources => undef, #default to qr/./ + # sources => [], #default to nothing + # sources => qr//, #DWIM, treated as [qr//] + # sources => [{...}] #DWIM, treat as [qr/./, {...} ] + # sources => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] + my $haystack = [ $schema->sources ]; + + my $rules = delete $opts{sources}; + if(!defined $rules){ + $rules = [qr/./]; + } elsif( ref $rules eq 'Regexp'){ + $rules = [ $rules ]; + } elsif( ref $rules eq 'ARRAY' && @$rules){ + #don't add a qr/./ rule if we have at least one match rule + push(@$rules, qr/./) unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') + || !ref $_ || ref $_ eq 'Regexp'} @$rules; + } + + my $sources = $self->parse_reflect_rules($rules, $haystack); + + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; + $meta->make_mutable if $meta->is_immutable; + + $meta->add_domain_model + ($dm_name, is => 'rw', isa => $schema, required => 1, %$dm_args); + + for my $source_name (keys %$sources){ + my $source_opts = $sources->{$source_name} || {}; + $self->reflect_source( + source_name => $source_name, + parent_class => $model, + schema_class => $schema, + source_class => $schema->class($source_name), + parent_domain_model_name => $dm_name, + %$source_opts + ); + } + + $meta->make_immutable if $make_immutable; + return $meta; +}; +sub _compute_source_options { + my ($self, %opts) = @_; + my $schema = delete $opts{schema_class}; + my $source_name = delete $opts{source_name}; + my $source_class = delete $opts{source_class}; + my $parent = delete $opts{parent_class}; + my $parent_dm = delete $opts{parent_domain_model_name}; + + #this is the part where I hate my life for promissing all sorts of DWIMery + confess("parent_class and source_name or source_class are required parameters") + unless($parent && ($source_name || $source_class)); + +OUTER: until( $schema && $source_name && $source_class && $parent_dm ){ + if( $schema && !$source_name){ + next OUTER if $source_name = $source_class->result_source_instance->source_name; + } elsif( $schema && !$source_class){ + next OUTER if $source_class = eval { $schema->class($source_name) }; } - $meta->make_immutable if $make_immutable; - return $meta; - }; - - implements _compute_source_options => as { - my ($self, %opts) = @_; - my $schema = delete $opts{schema_class}; - my $source_name = delete $opts{source_name}; - my $source_class = delete $opts{source_class}; - my $parent = delete $opts{parent_class}; - my $parent_dm = delete $opts{parent_domain_model_name}; - - #this is the part where I hate my life for promissing all sorts of DWIMery - confess("parent_class and source_name or source_class are required parameters") - unless($parent && ($source_name || $source_class)); - - OUTER: until( $schema && $source_name && $source_class && $parent_dm ){ - if( $schema && !$source_name){ - next OUTER if $source_name = $source_class->result_source_instance->source_name; - } elsif( $schema && !$source_class){ - next OUTER if $source_class = eval { $schema->class($source_name) }; + if($source_class && (!$schema || !$source_name)){ + if(!$schema){ + $schema = $source_class->result_source_instance->schema; + next OUTER if $schema && Class::MOP::load_class($schema); } - - if($source_class && (!$schema || !$source_name)){ - if(!$schema){ - $schema = $source_class->result_source_instance->schema; - next OUTER if $schema && Class::MOP::load_class($schema); - } - if(!$source_name){ - $source_name = $source_class->result_source_instance->source_name; - next OUTER if $source_name; - } + if(!$source_name){ + $source_name = $source_class->result_source_instance->source_name; + next OUTER if $source_name; } - my @haystack = $parent_dm ? - $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models; - - #there's a lot of guessing going on, but it should work fine on most cases - INNER: for my $needle (@haystack){ - my $isa = $needle->_isa_metadata; - next INNER unless Class::MOP::load_class( $isa->_isa_metadata ); - next INNER unless $isa->isa('DBIx::Class::Schema'); - if(!$parent_dm && $schema && $isa eq $schema){ - $parent_dm = $needle->name; - next OUTER; - } - - if( $source_name ){ - my $src_class = eval{ $isa->class($source_name) }; - next INNER unless $src_class; - next INNER if($source_class && $source_class ne $src_class); - $schema = $isa; - $parent_dm = $needle->name; - $source_class = $src_class; - next OUTER; - } + } + my @haystack = $parent_dm ? + $parent->meta->find_attribute_by_name($parent_dm) : $parent->domain_models; + + #there's a lot of guessing going on, but it should work fine on most cases + INNER: for my $needle (@haystack){ + my $isa = $needle->_isa_metadata; + next INNER unless Class::MOP::load_class( $isa->_isa_metadata ); + next INNER unless $isa->isa('DBIx::Class::Schema'); + if(!$parent_dm && $schema && $isa eq $schema){ + $parent_dm = $needle->name; + next OUTER; } - #do we even need to go this far? - if( !$parent_dm && $schema ){ - my $tentative = $self->dm_name_from_class_name($schema); - $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack; + if( $source_name ){ + my $src_class = eval{ $isa->class($source_name) }; + next INNER unless $src_class; + next INNER if($source_class && $source_class ne $src_class); + $schema = $isa; + $parent_dm = $needle->name; + $source_class = $src_class; + next OUTER; } - - confess("Could not determine options automatically from: schema " . - "'${schema}', source_name '${source_name}', source_class " . - "'${source_class}', parent_domain_model_name '${parent_dm}'"); } - return { - source_name => $source_name, - schema_class => $schema, - source_class => $source_class, - parent_class => $parent, - parent_domain_model_name => $parent_dm, - }; - }; - - implements _class_to_attribute_name => as { - my ( $self, $str ) = @_; - confess("wrong arguments passed for _class_to_attribute_name") unless $str; - return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str)) - }; - - implements add_source => as { - my ($self, %opts) = @_; - - my $model = delete $opts{model_class}; - my $reader = delete $opts{reader}; - my $source = delete $opts{source_name}; - my $dm_name = delete $opts{domain_model_name}; - my $collection = delete $opts{collection_class}; - my $name = delete $opts{attribute_name} || $source; - - confess("model_class and source_name are required parameters") - unless $model && $source; - my $meta = $model->meta; - - unless( $collection ){ - my $object = $self->class_name_from_source_name($model, $source); - $collection = $self->class_name_for_collection_of($object); + #do we even need to go this far? + if( !$parent_dm && $schema ){ + my $tentative = $self->dm_name_from_class_name($schema); + $parent_dm = $tentative if grep{$_->name eq $tentative} @haystack; } - unless( $reader ){ - $reader = $source; - $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; - $reader = $self->_class_to_attribute_name($reader) . "_collection"; + + confess("Could not determine options automatically from: schema " . + "'${schema}', source_name '${source_name}', source_class " . + "'${source_class}', parent_domain_model_name '${parent_dm}'"); + } + + return { + source_name => $source_name, + schema_class => $schema, + source_class => $source_class, + parent_class => $parent, + parent_domain_model_name => $parent_dm, + }; +}; +sub _class_to_attribute_name { + my ( $self, $str ) = @_; + confess("wrong arguments passed for _class_to_attribute_name") unless $str; + return join('_', map lc, split(/::|(?<=[a-z0-9])(?=[A-Z])/, $str)) +}; +sub add_source { + my ($self, %opts) = @_; + + my $model = delete $opts{model_class}; + my $reader = delete $opts{reader}; + my $source = delete $opts{source_name}; + my $dm_name = delete $opts{domain_model_name}; + my $collection = delete $opts{collection_class}; + my $name = delete $opts{attribute_name} || $source; + + confess("model_class and source_name are required parameters") + unless $model && $source; + my $meta = $model->meta; + + unless( $collection ){ + my $object = $self->class_name_from_source_name($model, $source); + $collection = $self->class_name_for_collection_of($object); + } + unless( $reader ){ + $reader = $source; + $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $reader = $self->_class_to_attribute_name($reader) . "_collection"; + } + unless( $dm_name ){ + my @haystack = $meta->domain_models; + if( @haystack > 1 ){ + @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack; } - unless( $dm_name ){ - my @haystack = $meta->domain_models; - if( @haystack > 1 ){ - @haystack = grep { $_->_isa_metadata->isa('DBIx::Class::Schema') } @haystack; - } - if(@haystack == 1){ - $dm_name = $haystack[0]->name; - } elsif(@haystack > 1){ - confess("Failed to automatically determine domain_model_name. More than one " . - "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")"); - } else { - confess("Failed to automatically determine domain_model_name. No matches."); - } + if(@haystack == 1){ + $dm_name = $haystack[0]->name; + } elsif(@haystack > 1){ + confess("Failed to automatically determine domain_model_name. More than one " . + "possible match (".(join ", ", map{"'".$_->name."'"} @haystack).")"); + } else { + confess("Failed to automatically determine domain_model_name. No matches."); } - - my %attr_opts = - ( - lazy => 1, - required => 1, - isa => $collection, - reader => $reader, - predicate => "has_" . $self->_class_to_attribute_name($name) , - domain_model => $dm_name, - orig_attr_name => $source, - default => sub { - $collection->new - ( - _source_resultset => $_[0]->$dm_name->resultset($source), - _parent => $_[0], - ); - }, - ); - - my $make_immutable = $meta->is_immutable; - $meta->make_mutable if $make_immutable; - my $attr = $meta->add_attribute($name, %attr_opts); - $meta->make_immutable if $make_immutable; - - return $attr; - }; - - implements reflect_source => as { - my ($self, %opts) = @_; - my $collection = delete $opts{collection} || {}; - %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; - - my $obj_meta = $self->reflect_source_object(%opts); - my $col_meta = $self->reflect_source_collection - ( - object_class => $obj_meta->name, - source_class => $opts{source_class}, - %$collection - ); - - $self->add_source( - %opts, - model_class => delete $opts{parent_class}, - domain_model_name => delete $opts{parent_domain_model_name}, - collection_class => $col_meta->name, - ); + } + + my %attr_opts = + ( + lazy => 1, + required => 1, + isa => $collection, + reader => $reader, + predicate => "has_" . $self->_class_to_attribute_name($name) , + domain_model => $dm_name, + orig_attr_name => $source, + default => sub { + $collection->new + ( + _source_resultset => $_[0]->$dm_name->resultset($source), + _parent => $_[0], + ); + }, + ); + + my $make_immutable = $meta->is_immutable; + $meta->make_mutable if $make_immutable; + my $attr = $meta->add_attribute($name, %attr_opts); + $meta->make_immutable if $make_immutable; + + return $attr; +}; +sub reflect_source { + my ($self, %opts) = @_; + my $collection = delete $opts{collection} || {}; + %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; + + my $obj_meta = $self->reflect_source_object(%opts); + my $col_meta = $self->reflect_source_collection + ( + object_class => $obj_meta->name, + source_class => $opts{source_class}, + %$collection + ); + + $self->add_source( + %opts, + model_class => delete $opts{parent_class}, + domain_model_name => delete $opts{parent_domain_model_name}, + collection_class => $col_meta->name, + ); +}; +sub reflect_source_collection { + my ($self, %opts) = @_; + my $base = delete $opts{base} || ResultSet; + my $class = delete $opts{class}; + my $object = delete $opts{object_class}; + my $source = delete $opts{source_class}; + my $action_rules = delete $opts{actions}; + + confess('object_class and source_class are required parameters') + unless $object && $source; + $class ||= $self->class_name_for_collection_of($object); + + Class::MOP::load_class( $base ); + Class::MOP::load_class( $object ); + my $meta = $self->_load_or_create($class, $base); + + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; + $meta->make_mutable if $meta->is_immutable; + $meta->add_method(_build_member_type => sub{ $object } ); + #XXX as a default pass the domain model as a target_model until i come up with something + #better through the coercion method + my $def_act_args = sub { + my $super = shift; + return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } }; }; + $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); - implements reflect_source_collection => as { - my ($self, %opts) = @_; - my $base = delete $opts{base} || ResultSet; - my $class = delete $opts{class}; - my $object = delete $opts{object_class}; - my $source = delete $opts{source_class}; - my $action_rules = delete $opts{actions}; - - confess('object_class and source_class are required parameters') - unless $object && $source; - $class ||= $self->class_name_for_collection_of($object); - - Class::MOP::load_class( $base ); - Class::MOP::load_class( $object ); - my $meta = $self->_load_or_create($class, $base); - - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; - $meta->make_mutable if $meta->is_immutable; - $meta->add_method(_build_member_type => sub{ $object } ); - #XXX as a default pass the domain model as a target_model until i come up with something - #better through the coercion method - my $def_act_args = sub { - my $super = shift; - return { (target_model => $_[0]->_source_resultset), %{ $super->(@_) } }; - }; - $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); - - - { - my $all_actions = $self->_all_collection_actions; - my $action_haystack = [keys %$all_actions]; - if(!defined $action_rules){ - $action_rules = $self->default_collection_actions; - } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ - $action_rules = [ $action_rules ]; - } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ - #don't add a qr/./ rule if we have at least one match rule - push(@$action_rules, qr/./) - unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') - || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; - } - # XXX this is kind of a dirty hack to support custom actions that are not - # previously defined and still be able to use the parse_reflect_rules mechanism - my @custom_actions = grep {!exists $all_actions->{$_}} - map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; - push(@$action_haystack, @custom_actions); - my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); - for my $action (keys %$actions){ - my $action_opts = $self->merge_hashes - ($all_actions->{$action} || {}, $actions->{$action} || {}); - - #NOTE: If the name of the action is not specified in the prototype then use it's - #hash key as the name. I think this is sane beahvior, but I've actually been thinking - #of making Action prototypes their own separate objects - $self->reflect_source_action( - name => $action, - object_class => $object, - source_class => $source, - %$action_opts, - ); - - # XXX i will move this to use the coercion method soon. this will be - # GoodEnough until then. I still need to think a little about the type coercion - # thing so i don't make a mess of it - my $act_args = sub { #override target model for this action - my $super = shift; - return { %{ $super->(@_) }, - ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) }; - }; - $meta->add_around_method_modifier('_default_action_args_for', $act_args); - } + { + my $all_actions = $self->_all_collection_actions; + my $action_haystack = [keys %$all_actions]; + if(!defined $action_rules){ + $action_rules = $self->default_collection_actions; + } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ + $action_rules = [ $action_rules ]; + } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ + #don't add a qr/./ rule if we have at least one match rule + push(@$action_rules, qr/./) + unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') + || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; } - $meta->make_immutable if $make_immutable; - return $meta; - }; - - implements reflect_source_object => as { - my($self, %opts) = @_; - %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; - - my $base = delete $opts{base} || Object; - my $class = delete $opts{class}; - my $dm_name = delete $opts{domain_model_name}; - my $dm_opts = delete $opts{domain_model_args} || {}; - - my $source_name = delete $opts{source_name}; - my $schema = delete $opts{schema_class}; - my $source_class = delete $opts{source_class}; - my $parent = delete $opts{parent_class}; - my $parent_dm = delete $opts{parent_domain_model_name}; - - my $action_rules = delete $opts{actions}; - my $attr_rules = delete $opts{attributes}; - - $class ||= $self->class_name_from_source_name($parent, $source_name); - - Class::MOP::load_class($parent); - Class::MOP::load_class($schema) if $schema; - Class::MOP::load_class($source_class); - - my $meta = $self->_load_or_create($class, $base); - - #create the domain model - $dm_name ||= $self->dm_name_from_source_name($source_name); - - $dm_opts->{isa} = $source_class; - $dm_opts->{is} ||= 'rw'; - $dm_opts->{required} ||= 1; - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; - $meta->make_mutable if $meta->is_immutable; - - my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts); - my $dm_reader = $dm_attr->get_read_method; - - unless( $class->can('inflate_result') ){ - my $inflate_method = sub { - my $class = shift; my ($src) = @_; - $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle'); - $class->new($dm_name, $src->result_class->inflate_result(@_)); + # XXX this is kind of a dirty hack to support custom actions that are not + # previously defined and still be able to use the parse_reflect_rules mechanism + my @custom_actions = grep {!exists $all_actions->{$_}} + map{ $_->[0] } grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; + push(@$action_haystack, @custom_actions); + my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); + for my $action (keys %$actions){ + my $action_opts = $self->merge_hashes + ($all_actions->{$action} || {}, $actions->{$action} || {}); + + #NOTE: If the name of the action is not specified in the prototype then use it's + #hash key as the name. I think this is sane beahvior, but I've actually been thinking + #of making Action prototypes their own separate objects + $self->reflect_source_action( + name => $action, + object_class => $object, + source_class => $source, + %$action_opts, + ); + + # XXX i will move this to use the coercion method soon. this will be + # GoodEnough until then. I still need to think a little about the type coercion + # thing so i don't make a mess of it + my $act_args = sub { #override target model for this action + my $super = shift; + return { %{ $super->(@_) }, + ($_[1] eq $action ? (target_model => $_[0]->_source_resultset) : () ) }; }; - $meta->add_method('inflate_result', $inflate_method); - } - - #XXX this is here to allow action prototypes to work with ListView - # maybe Collections hsould have this kind of thing too to allow you to reconstruct them? - #i like the possibility to be honest... as aset of key/value pairs they could be URId - #XXX move to using 'handles' for this? - $meta->add_method('__id', sub {shift->$dm_reader->id} ) - unless $class->can('__id'); - #XXX this one is for Action, ChooseOne and ChooseMany need this shit - $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} ) - unless $class->can('__ident_condition'); - - #XXX this is just a disaster - $meta->add_method('display_name', sub {shift->$dm_reader->display_name} ) - if( $source_class->can('display_name') && !$class->can('display_name')); - - #XXX as a default pass the domain model as a target_model until i come up with something - #better through the coercion method - my $def_act_args = sub { - my $super = shift; - confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); - return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } }; - }; - $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); - - { - # attributes => undef, #default to qr/./ - # attributes => [], #default to nothing - # attributes => qr//, #DWIM, treated as [qr//] - # attributes => [{...}] #DWIM, treat as [qr/./, {...} ] - # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] - my $attr_haystack = - [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ]; - - if(!defined $attr_rules){ - $attr_rules = [qr/./]; - } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ - $attr_rules = [ $attr_rules ]; - } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){ - #don't add a qr/./ rule if we have at least one match rule - push(@$attr_rules, qr/./) unless - grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') - || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules; - } - - my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); - for my $attr_name (keys %$attributes){ - $self->reflect_source_object_attribute( - class => $class, - source_class => $source_class, - parent_class => $parent, - attribute_name => $attr_name, - domain_model_name => $dm_name, - %{ $attributes->{$attr_name} || {}}, - ); - } - } - - { - my $all_actions = $self->_all_object_actions; - my $action_haystack = [keys %$all_actions]; - if(!defined $action_rules){ - $action_rules = $self->default_object_actions; - } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ - $action_rules = [ $action_rules ]; - } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ - #don't add a qr/./ rule if we have at least one match rule - push(@$action_rules, qr/./) - unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') - || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; - } - - # XXX this is kind of a dirty hack to support custom actions that are not - # previously defined and still be able to use the parse_reflect_rules mechanism - my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] } - grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; - push(@$action_haystack, @custom_actions); - my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); - for my $action (keys %$actions){ - my $action_opts = $self->merge_hashes - ($all_actions->{$action} || {}, $actions->{$action} || {}); - - #NOTE: If the name of the action is not specified in the prototype then use it's - #hash key as the name. I think this is sane beahvior, but I've actually been thinking - #of making Action prototypes their own separate objects - $self->reflect_source_action( - name => $action, - object_class => $class, - source_class => $source_class, - %$action_opts, - ); - - # XXX i will move this to use the coercion method soon. this will be - # GoodEnough until then. I still need to think a little about the type coercion - # thing so i don't make a mess of it - my $act_args = sub { #override target model for this action - my $super = shift; - confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); - return { %{ $super->(@_) }, - ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) }; - }; - $meta->add_around_method_modifier('_default_action_args_for', $act_args); - } + $meta->add_around_method_modifier('_default_action_args_for', $act_args); } + } + $meta->make_immutable if $make_immutable; + return $meta; +}; +sub reflect_source_object { + my($self, %opts) = @_; + %opts = %{ $self->merge_hashes(\%opts, $self->_compute_source_options(%opts)) }; - $meta->make_immutable if $make_immutable; - return $meta; - }; + my $base = delete $opts{base} || Object; + my $class = delete $opts{class}; + my $dm_name = delete $opts{domain_model_name}; + my $dm_opts = delete $opts{domain_model_args} || {}; - # needs class, attribute_name domain_model_name - implements reflect_source_object_attribute => as { - my ($self, %opts) = @_; - unless( $opts{attribute_name} && $opts{class} && $opts{parent_class} - && ( $opts{source_class} || $opts{domain_model_name} ) ){ - confess( "Error: class, parent_class, attribute_name, and either " . - "domain_model_name or source_class are required parameters" ); - } + my $source_name = delete $opts{source_name}; + my $schema = delete $opts{schema_class}; + my $source_class = delete $opts{source_class}; + my $parent = delete $opts{parent_class}; + my $parent_dm = delete $opts{parent_domain_model_name}; - my $meta = $opts{class}->meta; - my $attr_opts = $self->parameters_for_source_object_attribute(%opts); + my $action_rules = delete $opts{actions}; + my $attr_rules = delete $opts{attributes}; - my $make_immutable = $meta->is_immutable; - $meta->make_mutable if $meta->is_immutable; + $class ||= $self->class_name_from_source_name($parent, $source_name); - my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts); + Class::MOP::load_class($parent); + Class::MOP::load_class($schema) if $schema; + Class::MOP::load_class($source_class); - $meta->make_immutable if $make_immutable; - return $attr; - }; + my $meta = $self->_load_or_create($class, $base); - # needs class, attribute_name domain_model_name - implements parameters_for_source_object_attribute => as { - my ($self, %opts) = @_; - - my $class = delete $opts{class}; - my $attr_name = delete $opts{attribute_name}; - my $dm_name = delete $opts{domain_model_name}; - my $source_class = delete $opts{source_class}; - my $parent_class = delete $opts{parent_class}; - confess("parent_class is a required argument") unless $parent_class; - confess("You must supply at least one of domain_model_name and source_class") - unless $dm_name || $source_class; - - my $source; - $source = $source_class->result_source_instance if $source_class; - #puke! dwimery - if( !$source_class ){ - my $dm = $class->meta->find_attribute_by_name($dm_name); - $source_class = $dm->_isa_metadata; - $source = $source_class->result_source_instance; - } elsif( !$dm_name ){ - ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class} - $class->meta->domain_models; - if( !$dm_name ){ #last resort guess - my $tentative = $self->dm_name_from_source_name($source->source_name); - ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models; - } - } + #create the domain model + $dm_name ||= $self->dm_name_from_source_name($source_name); - my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); - my $reader = $from_attr->get_read_method; - - #default options. lazy build but no outsider method - my %attr_opts = ( is => 'ro', lazy => 1, required => 1, - clearer => "_clear_${attr_name}", - predicate => { - "has_${attr_name}" => - sub { defined(shift->$dm_name->$reader) } - }, - domain_model => $dm_name, - orig_attr_name => $attr_name, - ); - - #m2m / has_many - my $m2m_meta; - if(my $coderef = $source->result_class->can('_m2m_metadata')){ - $m2m_meta = $source->result_class->$coderef; - } + $dm_opts->{isa} = $source_class; + $dm_opts->{is} ||= 'rw'; + $dm_opts->{required} ||= 1; - my $constraint_is_ArrayRef = - $from_attr->type_constraint->name eq 'ArrayRef' || - $from_attr->type_constraint->is_subtype_of('ArrayRef'); - - if( my $rel_info = $source->relationship_info($attr_name) ){ - my $rel_accessor = $rel_info->{attrs}->{accessor}; - my $rel_moniker = $rel_info->{class}->result_source_instance->source_name; - - if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { - #has_many - my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker); - #type constraint is a collection, and default builds it - my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); - $attr_opts{default} = eval "sub { - my \$rs = shift->${dm_name}->related_resultset('${attr_name}'); - return ${isa}->new(_source_resultset => \$rs); - }"; - } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter' ) { - #belongs_to - #type constraint is the foreign IM object, default inflates it - my $isa = $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker); - $attr_opts{default} = eval "sub { - if (defined(my \$o = shift->${dm_name}->${reader})) { - return ${isa}->inflate_result(\$o->result_source, { \$o->get_columns }); - } - return undef; - }"; - } - } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) { - #m2m magic - my $mm_name = $1; - my $link_table = "links_to_${mm_name}_list"; - my ($hm_source, $far_side); - eval { $hm_source = $source->related_source($link_table); } - || confess "Can't find ${link_table} has_many for ${mm_name}_list"; - eval { $far_side = $hm_source->related_source($mm_name); } - || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class - ." traversing many-many for ${mm_name}_list"; - - my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name); - my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable;; + $meta->make_mutable if $meta->is_immutable; - #proper collections will remove the result_class uglyness. - $attr_opts{default} = eval "sub { - my \$rs = shift->${dm_name}->related_resultset('${link_table}')->related_resultset('${mm_name}'); - return ${isa}->new(_source_resultset => \$rs); - }"; - } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ - #m2m if using introspectable m2m component - my $rel = $m2m_meta->{$attr_name}->{relation}; - my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; - my $far_source = $source->related_source($rel)->related_source($far_rel); - my $sm = $self->class_name_from_source_name($parent_class, $far_source->source_name); - my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts); + my $dm_reader = $dm_attr->get_read_method; - my $rs_meth = $m2m_meta->{$attr_name}->{rs_method}; - $attr_opts{default} = eval "sub { - return ${isa}->new(_source_resultset => shift->${dm_name}->${rs_meth}); - }"; - } else { - #no rel - $attr_opts{isa} = $from_attr->_isa_metadata; - $attr_opts{default} = eval "sub{ shift->${dm_name}->${reader} }"; - } - return \%attr_opts; + unless( $class->can('inflate_result') ){ + my $inflate_method = sub { + my $class = shift; my ($src) = @_; + $src = $src->resolve if $src->isa('DBIx::Class::ResultSourceHandle'); + $class->new($dm_name, $src->result_class->inflate_result(@_)); + }; + $meta->add_method('inflate_result', $inflate_method); + } + + #XXX this is here to allow action prototypes to work with ListView + # maybe Collections hsould have this kind of thing too to allow you to reconstruct them? + #i like the possibility to be honest... as aset of key/value pairs they could be URId + #XXX move to using 'handles' for this? + $meta->add_method('__id', sub {shift->$dm_reader->id} ) + unless $class->can('__id'); + #XXX this one is for Action, ChooseOne and ChooseMany need this shit + $meta->add_method('__ident_condition', sub {shift->$dm_reader->ident_condition} ) + unless $class->can('__ident_condition'); + + #XXX this is just a disaster + $meta->add_method('display_name', sub {shift->$dm_reader->display_name} ) + if( $source_class->can('display_name') && !$class->can('display_name')); + + #XXX as a default pass the domain model as a target_model until i come up with something + #better through the coercion method + my $def_act_args = sub { + my $super = shift; + confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); + return { (target_model => $_[0]->$dm_reader), %{ $super->(@_) } }; }; + $meta->add_around_method_modifier('_default_action_args_for', $def_act_args); - - implements reflect_source_action => as{ - my($self, %opts) = @_; - my $name = delete $opts{name}; - my $class = delete $opts{class}; - my $base = delete $opts{base} || Action; - my $object = delete $opts{object_class}; - my $source = delete $opts{source_class}; - - confess("name, object_class and source_class are required arguments") - unless $source && $name && $object; - - my $attr_rules = delete $opts{attributes}; - $class ||= $object->_default_action_class_for($name); - - Class::MOP::load_class( $base ); - Class::MOP::load_class( $object ); - Class::MOP::load_class( $source ); - - #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n"; + { # attributes => undef, #default to qr/./ # attributes => [], #default to nothing # attributes => qr//, #DWIM, treated as [qr//] # attributes => [{...}] #DWIM, treat as [qr/./, {...} ] # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] - my $attr_haystack = [ map { $_->name } $object->parameter_attributes ]; + my $attr_haystack = + [ map { $_->name } $source_class->meta->compute_all_applicable_attributes ]; + if(!defined $attr_rules){ $attr_rules = [qr/./]; } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ @@ -775,143 +518,377 @@ class DBIC, which { || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules; } - #print STDERR "${name}\t${class}\t${base}\n"; - #print STDERR "\t${object}\t${source}\n"; - #print STDERR "\t",@$attr_rules,"\n"; + my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); + for my $attr_name (keys %$attributes){ + $self->reflect_source_object_attribute( + class => $class, + source_class => $source_class, + parent_class => $parent, + attribute_name => $attr_name, + domain_model_name => $dm_name, + %{ $attributes->{$attr_name} || {}}, + ); + } + } + + { + my $all_actions = $self->_all_object_actions; + my $action_haystack = [keys %$all_actions]; + if(!defined $action_rules){ + $action_rules = $self->default_object_actions; + } elsif( (!ref $action_rules && $action_rules) || (ref $action_rules eq 'Regexp') ){ + $action_rules = [ $action_rules ]; + } elsif( ref $action_rules eq 'ARRAY' && @$action_rules){ + #don't add a qr/./ rule if we have at least one match rule + push(@$action_rules, qr/./) + unless grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') + || !ref $_ || ref $_ eq 'Regexp'} @$action_rules; + } - my $o_meta = $object->meta; - my $s_meta = $source->meta; - my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); + # XXX this is kind of a dirty hack to support custom actions that are not + # previously defined and still be able to use the parse_reflect_rules mechanism + my @custom_actions = grep {!exists $all_actions->{$_}} map{ $_->[0] } + grep {ref $_ eq 'ARRAY' && $_->[0] ne '-exclude'} @$action_rules; + push(@$action_haystack, @custom_actions); + my $actions = $self->parse_reflect_rules($action_rules, $action_haystack); + for my $action (keys %$actions){ + my $action_opts = $self->merge_hashes + ($all_actions->{$action} || {}, $actions->{$action} || {}); + + #NOTE: If the name of the action is not specified in the prototype then use it's + #hash key as the name. I think this is sane beahvior, but I've actually been thinking + #of making Action prototypes their own separate objects + $self->reflect_source_action( + name => $action, + object_class => $class, + source_class => $source_class, + %$action_opts, + ); + + # XXX i will move this to use the coercion method soon. this will be + # GoodEnough until then. I still need to think a little about the type coercion + # thing so i don't make a mess of it + my $act_args = sub { #override target model for this action + my $super = shift; + confess "no dm reader: $dm_reader on $_[0]" unless $_[0]->can($dm_reader); + return { %{ $super->(@_) }, + ($_[1] eq $action ? (target_model => $_[0]->$dm_reader) : () ) }; + }; + $meta->add_around_method_modifier('_default_action_args_for', $act_args); + } + } - #create the class - my $meta = $self->_load_or_create($class, $base); - my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; - $meta->make_mutable if $meta->is_immutable; + $meta->make_immutable if $make_immutable; + return $meta; +}; - for my $attr_name (keys %$attributes){ - my $attr_opts = $attributes->{$attr_name} || {}; - my $o_attr = $o_meta->find_attribute_by_name($attr_name); - my $s_attr_name = $o_attr->orig_attr_name || $attr_name; - my $s_attr = $s_meta->find_attribute_by_name($s_attr_name); - confess("Unable to find attribute for '${s_attr_name}' via '${source}'") - unless defined $s_attr; - next unless $s_attr->get_write_method - && $s_attr->get_write_method !~ /^_/; #only rw attributes! - - my $attr_params = $self->parameters_for_source_object_action_attribute - ( - object_class => $object, - source_class => $source, - attribute_name => $attr_name - ); - $meta->add_attribute( $attr_name => %$attr_params); - } +# needs class, attribute_name domain_model_name +sub reflect_source_object_attribute { + my ($self, %opts) = @_; + unless( $opts{attribute_name} && $opts{class} && $opts{parent_class} + && ( $opts{source_class} || $opts{domain_model_name} ) ){ + confess( "Error: class, parent_class, attribute_name, and either " . + "domain_model_name or source_class are required parameters" ); + } - $meta->make_immutable if $make_immutable; - return $meta; - }; + my $meta = $opts{class}->meta; + my $attr_opts = $self->parameters_for_source_object_attribute(%opts); - implements parameters_for_source_object_action_attribute => as { - my ($self, %opts) = @_; - - my $object = delete $opts{object_class}; - my $attr_name = delete $opts{attribute_name}; - my $source_class = delete $opts{source_class}; - confess("object_class and attribute_name are required parameters") - unless $attr_name && $object; - - my $o_meta = $object->meta; - my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model; - $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata; - my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); - - #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n"; - - confess("${attr_name} is not writeable and can not be reflected") - unless $from_attr->get_write_method; - - my %attr_opts = ( - is => 'rw', - isa => $from_attr->_isa_metadata, - required => $from_attr->is_required, - ($from_attr->is_required - ? () : (clearer => "clear_${attr_name}")), - predicate => "has_${attr_name}", - ); - - if ($attr_opts{required}) { - if($from_attr->has_default) { - $attr_opts{lazy} = 1; - $attr_opts{default} = $from_attr->default; - } else { - $attr_opts{lazy_fail} = 1; - } - } + my $make_immutable = $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + my $attr = $meta->add_attribute($opts{attribute_name}, %$attr_opts); + $meta->make_immutable if $make_immutable; + return $attr; +}; - my $m2m_meta; - if(my $coderef = $source_class->result_class->can('_m2m_metadata')){ - $m2m_meta = $source_class->result_class->$coderef; +# needs class, attribute_name domain_model_name +sub parameters_for_source_object_attribute { + my ($self, %opts) = @_; + + my $class = delete $opts{class}; + my $attr_name = delete $opts{attribute_name}; + my $dm_name = delete $opts{domain_model_name}; + my $source_class = delete $opts{source_class}; + my $parent_class = delete $opts{parent_class}; + confess("parent_class is a required argument") unless $parent_class; + confess("You must supply at least one of domain_model_name and source_class") + unless $dm_name || $source_class; + + my $source; + $source = $source_class->result_source_instance if $source_class; + #puke! dwimery + if( !$source_class ){ + my $dm = $class->meta->find_attribute_by_name($dm_name); + $source_class = $dm->_isa_metadata; + $source = $source_class->result_source_instance; + } elsif( !$dm_name ){ + ($dm_name) = map{$_->name} grep{$_->_isa_metadata eq $source_class} + $class->meta->domain_models; + if( !$dm_name ){ #last resort guess + my $tentative = $self->dm_name_from_source_name($source->source_name); + ($dm_name) = $tentative if grep{$_->name eq $tentative} $class->domain_models; + } + } + + my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); + my $reader = $from_attr->get_read_method; + + #default options. lazy build but no outsider method + my %attr_opts = ( is => 'ro', lazy => 1, required => 1, + clearer => "_clear_${attr_name}", + predicate => { + "has_${attr_name}" => + sub { defined(shift->$dm_name->$reader) } + }, + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + + #m2m / has_many + my $m2m_meta; + if(my $coderef = $source->result_class->can('_m2m_metadata')){ + $m2m_meta = $source->result_class->$coderef; + } + + my $constraint_is_ArrayRef = + $from_attr->type_constraint->name eq 'ArrayRef' || + $from_attr->type_constraint->is_subtype_of('ArrayRef'); + + if( my $rel_info = $source->relationship_info($attr_name) ){ + my $rel_accessor = $rel_info->{attrs}->{accessor}; + my $rel_moniker = $rel_info->{class}->result_source_instance->source_name; + + if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { + #has_many + my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker); + #type constraint is a collection, and default builds it + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + $attr_opts{default} = eval "sub { + my \$rs = shift->${dm_name}->related_resultset('${attr_name}'); + return ${isa}->new(_source_resultset => \$rs); + }"; + } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter' ) { + #belongs_to + #type constraint is the foreign IM object, default inflates it + my $isa = $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker); + $attr_opts{default} = eval "sub { + if (defined(my \$o = shift->${dm_name}->${reader})) { + return ${isa}->inflate_result(\$o->result_source, { \$o->get_columns }); + } + return undef; + }"; } - #test for relationships - my $constraint_is_ArrayRef = - $from_attr->type_constraint->name eq 'ArrayRef' || - $from_attr->type_constraint->is_subtype_of('ArrayRef'); - - my $source = $source_class->result_source_instance; - if (my $rel_info = $source->relationship_info($attr_name)) { - my $rel_accessor = $rel_info->{attrs}->{accessor}; - - if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { - confess "${attr_name} is a rw has_many, this won't work."; - } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter') { - $attr_opts{valid_values} = sub { - shift->target_model->result_source->related_source($attr_name)->resultset; - }; + } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) { + #m2m magic + my $mm_name = $1; + my $link_table = "links_to_${mm_name}_list"; + my ($hm_source, $far_side); + eval { $hm_source = $source->related_source($link_table); } + || confess "Can't find ${link_table} has_many for ${mm_name}_list"; + eval { $far_side = $hm_source->related_source($mm_name); } + || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class + ." traversing many-many for ${mm_name}_list"; + + my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name); + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + + #proper collections will remove the result_class uglyness. + $attr_opts{default} = eval "sub { + my \$rs = shift->${dm_name}->related_resultset('${link_table}')->related_resultset('${mm_name}'); + return ${isa}->new(_source_resultset => \$rs); + }"; + } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ + #m2m if using introspectable m2m component + my $rel = $m2m_meta->{$attr_name}->{relation}; + my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; + my $far_source = $source->related_source($rel)->related_source($far_rel); + my $sm = $self->class_name_from_source_name($parent_class, $far_source->source_name); + my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm); + + my $rs_meth = $m2m_meta->{$attr_name}->{rs_method}; + $attr_opts{default} = eval "sub { + return ${isa}->new(_source_resultset => shift->${dm_name}->${rs_meth}); + }"; + } else { + #no rel + $attr_opts{isa} = $from_attr->_isa_metadata; + $attr_opts{default} = eval "sub{ shift->${dm_name}->${reader} }"; + } + return \%attr_opts; +}; +sub reflect_source_action { + my($self, %opts) = @_; + my $name = delete $opts{name}; + my $class = delete $opts{class}; + my $base = delete $opts{base} || Action; + my $object = delete $opts{object_class}; + my $source = delete $opts{source_class}; + + confess("name, object_class and source_class are required arguments") + unless $source && $name && $object; + + my $attr_rules = delete $opts{attributes}; + $class ||= $object->_default_action_class_for($name); + + Class::MOP::load_class( $base ); + Class::MOP::load_class( $object ); + Class::MOP::load_class( $source ); + + #print STDERR "\n\t", ref $attr_rules eq 'ARRAY' ? @$attr_rules : $attr_rules,"\n"; + # attributes => undef, #default to qr/./ + # attributes => [], #default to nothing + # attributes => qr//, #DWIM, treated as [qr//] + # attributes => [{...}] #DWIM, treat as [qr/./, {...} ] + # attributes => [[-exclude => ...]] #DWIM, treat as [qr/./, [-exclude => ...]] + my $attr_haystack = [ map { $_->name } $object->parameter_attributes ]; + if(!defined $attr_rules){ + $attr_rules = [qr/./]; + } elsif( (!ref $attr_rules && $attr_rules) || (ref $attr_rules eq 'Regexp') ){ + $attr_rules = [ $attr_rules ]; + } elsif( ref $attr_rules eq 'ARRAY' && @$attr_rules){ + #don't add a qr/./ rule if we have at least one match rule + push(@$attr_rules, qr/./) unless + grep {(ref $_ eq 'ARRAY' && $_->[0] ne '-exclude') + || !ref $_ || ref $_ eq 'Regexp'} @$attr_rules; + } + + #print STDERR "${name}\t${class}\t${base}\n"; + #print STDERR "\t${object}\t${source}\n"; + #print STDERR "\t",@$attr_rules,"\n"; + + my $o_meta = $object->meta; + my $s_meta = $source->meta; + my $attributes = $self->parse_reflect_rules($attr_rules, $attr_haystack); + + #create the class + my $meta = $self->_load_or_create($class, $base); + my $make_immutable = $meta->is_immutable || $self->make_classes_immutable; + $meta->make_mutable if $meta->is_immutable; + + for my $attr_name (keys %$attributes){ + my $attr_opts = $attributes->{$attr_name} || {}; + my $o_attr = $o_meta->find_attribute_by_name($attr_name); + my $s_attr_name = $o_attr->orig_attr_name || $attr_name; + my $s_attr = $s_meta->find_attribute_by_name($s_attr_name); + confess("Unable to find attribute for '${s_attr_name}' via '${source}'") + unless defined $s_attr; + next unless $s_attr->get_write_method + && $s_attr->get_write_method !~ /^_/; #only rw attributes! + + my $attr_params = $self->parameters_for_source_object_action_attribute + ( + object_class => $object, + source_class => $source, + attribute_name => $attr_name + ); + $meta->add_attribute( $attr_name => %$attr_params); + } + + $meta->make_immutable if $make_immutable; + return $meta; +}; +sub parameters_for_source_object_action_attribute { + my ($self, %opts) = @_; + + my $object = delete $opts{object_class}; + my $attr_name = delete $opts{attribute_name}; + my $source_class = delete $opts{source_class}; + confess("object_class and attribute_name are required parameters") + unless $attr_name && $object; + + my $o_meta = $object->meta; + my $dm_name = $o_meta->find_attribute_by_name($attr_name)->domain_model; + $source_class ||= $o_meta->find_attribute_by_name($dm_name)->_isa_metadata; + my $from_attr = $source_class->meta->find_attribute_by_name($attr_name); + + #print STDERR "$attr_name is type: " . $from_attr->meta->name . "\n"; + + confess("${attr_name} is not writeable and can not be reflected") + unless $from_attr->get_write_method; + + my %attr_opts = ( + is => 'rw', + isa => $from_attr->_isa_metadata, + required => $from_attr->is_required, + ($from_attr->is_required + ? () : (clearer => "clear_${attr_name}")), + predicate => "has_${attr_name}", + ); + + if ($attr_opts{required}) { + if($from_attr->has_default) { + $attr_opts{lazy} = 1; + $attr_opts{default} = $from_attr->default; + } else { + $attr_opts{lazy_fail} = 1; } - } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { - my $mm_name = $1; - my $link_table = "links_to_${mm_name}_list"; - $attr_opts{default} = sub { [] }; - $attr_opts{valid_values} = sub { - shift->target_model->result_source->related_source($link_table) - ->related_source($mm_name)->resultset; - }; - } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ - #m2m if using introspectable m2m component - my $rel = $m2m_meta->{$attr_name}->{relation}; - my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; - $attr_opts{default} = sub { [] }; + } + + + my $m2m_meta; + if(my $coderef = $source_class->result_class->can('_m2m_metadata')){ + $m2m_meta = $source_class->result_class->$coderef; + } + #test for relationships + my $constraint_is_ArrayRef = + $from_attr->type_constraint->name eq 'ArrayRef' || + $from_attr->type_constraint->is_subtype_of('ArrayRef'); + + my $source = $source_class->result_source_instance; + if (my $rel_info = $source->relationship_info($attr_name)) { + my $rel_accessor = $rel_info->{attrs}->{accessor}; + + if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { + confess "${attr_name} is a rw has_many, this won't work."; + } elsif( $rel_accessor eq 'single' || $rel_accessor eq 'filter') { $attr_opts{valid_values} = sub { - shift->target_model->result_source->related_source($rel) - ->related_source($far_rel)->resultset; + shift->target_model->result_source->related_source($attr_name)->resultset; }; } - #use Data::Dumper; - #print STDERR "\n" .$attr_name ." - ". $object . "\n"; - #print STDERR Dumper(\%attr_opts); - return \%attr_opts; - }; - - implements _load_or_create => as { - my ($self, $class, $base) = @_; - my $meta = $self->_maybe_load_class($class) ? - $class->meta : $base->meta->create($class, superclasses => [ $base ]); - return $meta; - }; + } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { + my $mm_name = $1; + my $link_table = "links_to_${mm_name}_list"; + $attr_opts{default} = sub { [] }; + $attr_opts{valid_values} = sub { + shift->target_model->result_source->related_source($link_table) + ->related_source($mm_name)->resultset; + }; + } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){ + #m2m if using introspectable m2m component + my $rel = $m2m_meta->{$attr_name}->{relation}; + my $far_rel = $m2m_meta->{$attr_name}->{foreign_relation}; + $attr_opts{default} = sub { [] }; + $attr_opts{valid_values} = sub { + shift->target_model->result_source->related_source($rel) + ->related_source($far_rel)->resultset; + }; + } + #use Data::Dumper; + #print STDERR "\n" .$attr_name ." - ". $object . "\n"; + #print STDERR Dumper(\%attr_opts); + return \%attr_opts; +}; +sub _load_or_create { + my ($self, $class, $base) = @_; + my $meta = $self->_maybe_load_class($class) ? + $class->meta : $base->meta->create($class, superclasses => [ $base ]); + return $meta; +}; +sub _maybe_load_class { + my ($self, $class) = @_; + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + my $ret = eval { Class::MOP::load_class($class) }; + if ($INC{$file} && $@) { + confess "Error loading ${class}: $@"; + } + return $ret; +}; - implements _maybe_load_class => as { - my ($self, $class) = @_; - my $file = $class . '.pm'; - $file =~ s{::}{/}g; - my $ret = eval { Class::MOP::load_class($class) }; - if ($INC{$file} && $@) { - confess "Error loading ${class}: $@"; - } - return $ret; - }; +__PACKAGE__->meta->make_immutable; -}; 1; |