diff options
Diffstat (limited to 'lib/Reaction/InterfaceModel/Action/DBIC')
9 files changed, 598 insertions, 0 deletions
diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ActionReflector.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ActionReflector.pm new file mode 100644 index 0000000..9be6920 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ActionReflector.pm @@ -0,0 +1,189 @@ +package Reaction::InterfaceModel::Action::DBIC::ActionReflector; + +use Reaction::Class; + +use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; + +class ActionReflector which { + + #this will break with immutable. need to port back from dbic::objectclass + implements reflect_action_for => as { + my ($self, $class, $action_class, $action, $super, $attrs ) = @_; + + my $str = "package ${action_class};\nuse Reaction::Class;\n"; + eval $str; + confess "Error making ${action_class} a Reaction class: $@" if $@; + warn $str if $ENV{REACTION_DEBUG}; + my $types = $self->reflect_action_types; + if( exists $types->{$action} ){ #get defaults if action is a builtin + my ($conf_super, $conf_attrs) = @{$types->{$action}}; + $super ||= $conf_super; + $attrs ||= $conf_attrs; + } + $super = [ $super ] unless ref($super) eq 'ARRAY'; + $action_class->can('extends')->(@$super); + warn "extends ".join(', ', map { "'$_'" } @$super).";\n" + if $ENV{REACTION_DEBUG}; + $attrs ||= []; + if ($attrs eq '*') { + $self->reflect_all_writable_attrs($class => $action_class); + } elsif (ref $attrs eq 'ARRAY' && @$attrs) { + $self->reflect_attrs($class => $action_class, @$attrs); + } + $action_class->can('register_inc_entry')->(); + }; + + implements reflect_actions_for => as { + my ($self, $class, $reflected_prefix) = @_; + foreach my $action ( keys %{ $self->reflect_action_types } ) { + my @stem_parts = split('::', $class); + my $last_part = pop(@stem_parts); + my $action_class = "${reflected_prefix}::${action}${last_part}"; + $self->reflect_action_for($class, $action_class, $action); + } + }; + + implements reflect_all_writable_attrs => as { + my ($self, $from_class, $to_class) = @_; + my $from_meta = $from_class->meta; + foreach my $from_attr ($from_meta->compute_all_applicable_attributes) { + next unless $from_attr->get_write_method; + $self->reflect_attribute_to($from_class, $from_attr, $to_class); + } + }; + + implements reflect_attrs => as { + my ($self, $from_class, $to_class, @attrs) = @_; + foreach my $attr_name (@attrs) { + $self->reflect_attribute_to + ($from_class, + $from_class->meta->find_attribute_by_name($attr_name), + $to_class); + } + }; + + implements reflect_attribute_to => as { + my ($self, $from_class, $from_attr, $to_class) = @_; + my $attr_name = $from_attr->name; + my $to_meta = $to_class->meta; + my %opts; # = map { ($_, $from_attr->$_) } qw/isa is required/; + my @extra; + @opts{qw/isa is/} = + map { my $meth = "_${_}_metadata"; $from_attr->$meth; } + qw/isa is/; + if ($from_attr->is_required) { + if(defined $from_attr->default){ + @opts{qw/required default lazy/} = (1, $from_attr->default, 1); + } else { + %opts = (%opts, set_or_lazy_fail($from_attr->name)); + push(@extra, qq!set_or_lazy_fail('@{[$from_attr->name]}')!); + } + } + $opts{predicate} = "has_${attr_name}"; + + if (my $info = $from_class->result_source_instance + ->relationship_info($attr_name)) { + if ($info->{attrs}->{accessor} && $info->{attrs}->{accessor} eq 'multi') { + confess "${attr_name} is multi and rw. we are confoos."; # XXX + } else { + $opts{valid_values} = sub { + $_[0]->target_model + ->result_source + ->related_source($attr_name) + ->resultset; + }; + push(@extra, qq!valid_values => sub { + \$_[0]->target_model + ->result_source + ->related_source('${attr_name}') + ->resultset; + }!); + } + } elsif ($from_attr->type_constraint->name eq 'ArrayRef' + || $from_attr->type_constraint->is_subtype_of('ArrayRef')) { + # it's a many-many. time for some magic. + ($attr_name =~ m/^(.*)_list$/) + || confess "Many-many attr must be called <name>_list for reflection"; + my $mm_name = $1; + my ($hm_source, $far_side); + my $source = $from_class->result_source_instance; + eval { $hm_source = $source->related_source("links_to_${mm_name}_list"); } + || confess "Can't find links_to_${mm_name}_list has_many for ${mm_name}_list"; + eval { $far_side = $hm_source->related_source($mm_name); } + || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class + ." traversing many-many for ${mm_name}_list"; + $opts{default} = sub { [] }; + push(@extra, qq!default => sub { [] }!); + $opts{valid_values} = sub { + $_[0]->target_model + ->result_source + ->related_source("links_to_${mm_name}_list") + ->related_source(${mm_name}) + ->resultset; + }; + push(@extra, qq!valid_values => sub { + \$_[0]->target_model + ->result_source + ->related_source('links_to_${mm_name}_list') + ->related_source('${mm_name}') + ->resultset; + }!); + } + next unless $opts{is} eq 'rw'; + $to_meta->_process_attribute($from_attr->name => %opts); + warn "has '".$from_attr->name."' => (".join(', ', + (map { exists $opts{$_} ? ("$_ => '".$opts{$_}."'") : () } + qw/isa is predicate/), + @extra) + .");\n" if $ENV{REACTION_DEBUG}; + }; + + implements reflect_action_types => as { + return { + 'Create' => [ Create, '*' ], + 'Update' => [ Update, '*' ], + 'Delete' => [ Delete ], + } + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::ActionReflector + +=head1 DESCRIPTION + +=head2 Create + +=head2 Update + +=head2 Delete + +=head1 METHODS + +=head2 reflect_action_for + +=head2 reflect_action_types + +=head2 reflect_actions_for + +=head2 reflect_all_writable_attrs + +=head2 reflect_attribute_to + +=head2 reflect_attrs + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm new file mode 100644 index 0000000..68bd365 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Delete.pm @@ -0,0 +1,36 @@ +package Reaction::InterfaceModel::Action::DBIC::Result::Delete; + +use Reaction::Types::DBIC; +use Reaction::Class; + +class Delete is 'Reaction::InterfaceModel::Action', which { + has '+target_model' => (isa => 'DBIx::Class::Row'); + + sub can_apply { 1 } + + implements do_apply => as { + my $self = shift; + return $self->target_model->delete; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::Result::Delete + +=head1 DESCRIPTION + +=head2 target_model + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm new file mode 100644 index 0000000..a1387ef --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Result/Update.pm @@ -0,0 +1,66 @@ +package Reaction::InterfaceModel::Action::DBIC::Result::Update; + +use Reaction::InterfaceModel::Action; +use Reaction::Types::DBIC; +use Reaction::Class; + +class Update is 'Reaction::InterfaceModel::Action', which { + + does 'Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques'; + + has '+target_model' => (isa => 'DBIx::Class::Row'); + + 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); + } + }; + + 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; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::Result::Update + +=head1 DESCRIPTION + +=head2 target_model + +=head2 error_for_attribute + +=head2 sync_all + +=head2 BUILD + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm new file mode 100644 index 0000000..f67a77c --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/ResultSet/Create.pm @@ -0,0 +1,69 @@ +package Reaction::InterfaceModel::Action::DBIC::ResultSet::Create; + +use Reaction::Types::DBIC; +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 => 'DBIx::Class::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}); + } + } + $new->insert; + foreach my $d (@delay) { + my ($meth, $val) = @$d; + $new->$meth($val); + } + return $new; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::ResultSet::Create + +=head1 DESCRIPTION + +=head2 target_model + +=head2 error_for_attribute + +=head2 sync_all + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm new file mode 100644 index 0000000..e4756fd --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/Role/CheckUniques.pm @@ -0,0 +1,114 @@ +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); + } + } + } + @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; }; + + 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 + +Reaction::InterfaceModel::Action::DBIC::Role::CheckUniques + +=head1 DESCRIPTION + +=head2 check_all_uniques + +=head2 error_for_attribute + +=head2 meta + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm new file mode 100644 index 0000000..3602f86 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ChangePassword.pm @@ -0,0 +1,29 @@ +package Reaction::InterfaceModel::Action::DBIC::User::ChangePassword; + +use Reaction::Class; + +class ChangePassword + is 'Reaction::InterfaceModel::Action::User::ChangePassword', + which { + + does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::User::ChangePassword + +=head1 DESCRIPTION + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm new file mode 100644 index 0000000..6620d30 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/ResetPassword.pm @@ -0,0 +1,29 @@ +package Reaction::InterfaceModel::Action::DBIC::User::ResetPassword; + +use Reaction::Class; + +class ResetPassword + is 'Reaction::InterfaceModel::Action::User::ResetPassword', + which { + + does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::User::ResetPassword + +=head1 DESCRIPTION + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm new file mode 100644 index 0000000..0cd41a8 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/Role/SetPassword.pm @@ -0,0 +1,37 @@ +package Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword; + +use Reaction::Role; + +role SetPassword, which { + + #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; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::User::Role::ChangePassword + +=head1 DESCRIPTION + +=head2 meta + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm new file mode 100644 index 0000000..b15e218 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/DBIC/User/SetPassword.pm @@ -0,0 +1,29 @@ +package Reaction::InterfaceModel::Action::DBIC::User::SetPassword; + +use Reaction::Class; + +class SetPassword + is 'Reaction::InterfaceModel::Action::User::SetPassword', + which { + + does 'Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword'; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::DBIC::User::SetPassword + +=head1 DESCRIPTION + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut |