diff options
author | matthewt <matthewt@03d0b0b2-0e1a-0410-a411-fdb2f4bd65d7> | 2007-09-12 18:11:34 +0000 |
---|---|---|
committer | matthewt <matthewt@03d0b0b2-0e1a-0410-a411-fdb2f4bd65d7> | 2007-09-12 18:11:34 +0000 |
commit | 7adfd53f17f66ffe93763e944ed1d3fc52a369dc (patch) | |
tree | 19e599e74419b41cbbe651fd226b81e8b73551d3 /lib/Reaction | |
parent | c728c97cb1061330e63c7cc048e768ef74988fe6 (diff) | |
download | reaction-7adfd53f17f66ffe93763e944ed1d3fc52a369dc.tar.gz reaction-7adfd53f17f66ffe93763e944ed1d3fc52a369dc.zip |
moved shit to trunk
Diffstat (limited to 'lib/Reaction')
94 files changed, 10046 insertions, 0 deletions
diff --git a/lib/Reaction/Class.pm b/lib/Reaction/Class.pm new file mode 100644 index 0000000..b2c0ad9 --- /dev/null +++ b/lib/Reaction/Class.pm @@ -0,0 +1,324 @@ +package Reaction::Class; + +use Moose qw(confess); +use Sub::Exporter (); +use Sub::Name (); +use Reaction::Types::Core; +use Reaction::Object; + +sub exporter_for_package { + my ($self, $package) = @_; + my %exports_proto = $self->exports_for_package($package); + my %exports = ( + map { my $cr = $exports_proto{$_}; ($_, sub { Sub::Name::subname "${self}::$_" => $cr; }) } + keys %exports_proto + ); + + my $exporter = Sub::Exporter::build_exporter({ + exports => \%exports, + groups => { + default => [':all'] + } + }); + + return $exporter; +} + +sub do_import { + my ($self, $pkg, $args) = @_; + my $exporter = $self->exporter_for_package($pkg, $args); + $exporter->($self, { into => $pkg }, @$args); + if (my @default_base = $self->default_base) { + no strict 'refs'; + @{"${pkg}::ISA"} = @default_base unless @{"${pkg}::ISA"}; + } +} + +sub default_base { ('Reaction::Object'); } + +sub exports_for_package { + my ($self, $package) = @_; + return ( + set_or_lazy_build => sub { + my $name = shift; + my $build = "build_${name}"; + return (required => 1, lazy => 1, + default => sub { shift->$build(); }); + }, + set_or_lazy_fail => sub { + my $name = shift; + my $message = "${name} must be provided before calling reader"; + return (required => 1, lazy => 1, + default => sub { confess($message); }); + }, + trigger_adopt => sub { + my $type = shift; + my @args = @_; + my $adopt = "adopt_${type}"; + return (trigger => sub { shift->$adopt(@args); }); + }, + register_inc_entry => sub { + my $inc = $package; + $inc =~ s/::/\//g; + $inc .= '.pm'; + $INC{$inc} = 1; + }, + #this needs to go away soon. its never used. pollution. + reflect_attributes_from => sub { + my ($from_class, @attrs) = @_; + + #Should we use Class::Inspector to make sure class is loaded? + #unless( Class::Inspector->loaded($from_class) ){ + # eval "require $from_class" || die("Failed to load: $from_class"); + #} + foreach my $attr_name (@attrs){ + my $from_attr = $from_class->meta->get_attribute($attr_name); + confess("$from_attr does not exist in $from_class") + unless $from_attr; + #Not happy + #$package->meta->add_attribute( $from_attr->name, %{$from_attr} ); + $package->meta->add_attribute( bless { %{$from_attr} } => + $package->meta->attribute_metaclass ); + } + }, + class => sub { + $self->do_class_sub($package, @_); + }, + does => sub { + $package->can('with')->(@_); + }, + overrides => sub { + $package->can('override')->(@_) + }, + $self->make_package_sub($package), + implements => sub { confess "implements only valid within class block" }, + $self->make_sugar_sub('is'), + $self->make_code_sugar_sub('which'), + $self->make_code_sugar_sub('as'), + run => sub (;&@) { @_ }, + ); +} + +sub do_class_sub { + my ($self, $package, $class, @args) = @_; + my $error = "Invalid class declaration, should be: class Class (is Superclass)*, which { ... }"; + confess $error if (@args % 1); + my @supers; + while (@args > 2) { + my $should_be_is = shift(@args); + confess $error unless $should_be_is eq 'is'; + push(@supers, shift(@args)); + } + confess $error unless $args[0] eq 'which' && ref($args[1]) eq 'CODE'; + my $setup = $args[1]; + + #this eval is fucked, but I can't fix it + unless ($class->can('meta')) { + print STDERR "** MAKING CLASS $class useing Reaction::Class **\n"; + eval "package ${class}; use Reaction::Class;"; + if ($@) { confess "Couldn't make ${class} a Reaction class: $@"; } + } + if (@supers) { + Class::MOP::load_class($_) for @supers; + $class->meta->_fix_metaclass_incompatability(@supers); + $class->meta->superclasses(@supers); + } + $self->setup_and_cleanup($package, $setup); + + #immutable code + #print STDERR "$package \n"; + #print STDERR $package->meta->blessed, " \n"; + $package->meta->make_immutable; +# (inline_accessor => 0, inline_destructor => 0,inline_constructor => 0,); +} + +sub setup_and_cleanup { + my ($self, $package, $setup) = @_; + my @methods; + my @apply_after; + my %save_delayed; + { + no strict 'refs'; + no warnings 'redefine'; + local *{"${package}::implements"} = + Sub::Name::subname "${self}::implements" => sub { + my $name = shift; + shift if $_[0] eq 'as'; + push(@methods, [ $name, shift ]); + }; + foreach my $meth ($self->delayed_methods) { + $save_delayed{$meth} = $package->can($meth); + local *{"${package}::${meth}"} = + Sub::Name::subname "${self}::${meth}" => sub { + push(@apply_after, [ $meth => @_ ]); + }; + } + # XXX - need additional fuckery to handle multi-class-per-file + $setup->(); # populate up the crap + } + my %exports = $self->exports_for_package($package); + { + no strict 'refs'; + foreach my $nuke (keys %exports) { + delete ${"${package}::"}{$nuke}; + } + } + my $unimport_class = $self->next_import_package; + eval "package ${package}; no $unimport_class;"; + confess "$unimport_class unimport from ${package} failed: $@" if $@; + foreach my $m (@methods) { + $package->meta->add_method(@$m); + } + foreach my $a (@apply_after) { + my $call = shift(@$a); + $save_delayed{$call}->(@$a); + } +} + +sub delayed_methods { + return (qw/has with extends before after around override augment/); +} + +sub make_package_sub { + my ($self, $package) = @_; + my ($last) = (split('::', $package))[-1]; + return $last => sub { + $self->do_package_sub($package => @_); + }; +} + +sub do_package_sub { + my $self = shift; + my $package = shift; + return (@_ ? ($package => @_) : $package); +} + +sub make_sugar_sub { + my ($self, $name) = @_; + return $name => sub { + return ($name => @_); + }; +} + +sub make_code_sugar_sub { + my ($self, $name) = @_; + return $name => sub (;&@) { + return ($name => @_); + }; +} + +sub import { + my $self = shift; + my $pkg = caller; + my @args = @_; + &strict::import; + &warnings::import; + $self->do_import($pkg, \@args); + goto &{$self->next_import}; +} + +sub next_import { + return shift->next_import_package(@_)->can('import'); +} + +sub next_import_package { 'Moose' } + +1; + +#---------#---------#---------#---------#---------#---------#---------#--------# + +=head1 NAME + +Reaction::Class + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=over + +=item * L<Catalyst> + +=item * L<Reaction::Manual> + +=back + +=head1 Unstructured reminders + +(will properly format and stuff later. no time right now) + +C<use>ing C<Reaction::Class> will alias the current package name +see L<aliased>. + + package MyApp::Pretty::Picture + + # Picture expands to 'MyApp::Pretty::Picture' + class Picture, which { ... + +=head2 default_base + +=head2 set_or_lazy_build $attrname + +Will make your attributes lazy and required, if they are not set they +will default to the value returned by C<&build_$attrname> + + has created_d => (isa => 'DateTime', set_or_lazy_build('created_d') ); + sub build_created_d{ DateTime->now } + +=head2 set_or_lazy_fail $attrname + +Will make your attributes lazy and required, if they are not set +and their accessor is called an exception will be thrown + +=head2 trigger_adopt $attrname + +=head2 register_inc_entry + +=head2 reflect_attributes_from $from_class, @attrs + +Create attributes in the local class that mirror the specified C<@attrs> +in C<$from_class> + +=head2 class $name [, is $superclass ], which { + +Sugary class declaration, will create a a package C<$name> with an +optional base class of $superclass. The class declaration, should be placed inside +the brackets using C<implements> to declare a method and C<has> to declare an +attribute. + +=head2 does + +Alias to C<with> for the current package, see C<Moose::Role> + +=head2 implements $method_name [is | which | as] + +Only valid whithin a class block, allows you to declare a method for the class. + + implements 'current_date' => as { DateTime->today }; + +=head2 run + +=head1 AUTHORS + +=over + +=item * Matt S. Trout + +=item * K. J. Cheetham + +=item * Guillermo Roditi + +=item * Jess Robinson (Documentation) + +=item * Kaare Rasmussen (Documentation) + +=item * Andres N. Kievsky (Documentation) + +=back + +=head1 LICENSE + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Reaction/ClassExporter.pm b/lib/Reaction/ClassExporter.pm new file mode 100644 index 0000000..43f2295 --- /dev/null +++ b/lib/Reaction/ClassExporter.pm @@ -0,0 +1,40 @@ +package Reaction::ClassExporter; + +use strict; +use warnings; +use Reaction::Class (); + +sub import { + my $self = shift; + my $pkg = caller; + &strict::import; + &warnings::import; + { + no strict 'refs'; + @{"${pkg}::ISA"} = ('Reaction::Class'); + *{"${pkg}::import"} = \&Reaction::Class::import; + } + goto &Moose::import; +} + +1; + +=head1 NAME + +Reaction::ClassExporter + +=head1 DESCRIPTION + +=head1 SEE ALSO + +L<Reaction::Class> + +=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.pm b/lib/Reaction/InterfaceModel/Action.pm new file mode 100644 index 0000000..68a6e5b --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action.pm @@ -0,0 +1,110 @@ +package Reaction::InterfaceModel::Action; + +use Reaction::Meta::InterfaceModel::Action::Class; +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->predicate; + 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->predicate; + if ($attr->is_required) { + 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); + }; + + implements error_for_attribute => as { + my ($self, $attr) = @_; + if ($attr->is_required) { + my $predicate = $attr->predicate; + unless ($self->$predicate) { + return $attr->name." is required"; + } + } + if ($attr->has_valid_values) { + my $reader = $attr->get_read_method; + unless ($attr->check_valid_value($self, $self->$reader)) { + return "Not a valid value for ".$attr->name; + } + } + return; # ok + }; + + sub sync_all { } + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head2 target_model + +=head2 ctx + +=head2 parameter_attributes + +=head1 SEE ALSO + +L<Reaction::Meta::Attribute> + +=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/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 diff --git a/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm new file mode 100644 index 0000000..fc8ff88 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/User/ChangePassword.pm @@ -0,0 +1,63 @@ +package Reaction::InterfaceModel::Action::User::ChangePassword; + +use Reaction::Class; + +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->(@_); + }; + + implements verify_old_password => as { + my $self = shift; + return unless $self->has_old_password; + + my $user = $self->target_model; + return $user->can("check_password") ? + $user->check_password($self->old_password) : + $self->old_password eq $user->password; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::User::ChangePassword + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 old_password + +=head2 verify_old_password + +=head1 SEE ALSO + +L<Reaction::InterfaceModel::Action::DBIC::User::ChangePassword> + +=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/User/Login.pm b/lib/Reaction/InterfaceModel/Action/User/Login.pm new file mode 100644 index 0000000..781ec0f --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/User/Login.pm @@ -0,0 +1,49 @@ +package Reaction::InterfaceModel::Action::User::Login; + +use Reaction::Class; +use aliased 'Reaction::InterfaceModel::Action'; + +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->predicate; + 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); + }; +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::User::Login + +=head1 DESCRIPTION + +=head2 username + +=head2 password + +=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/User/ResetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm new file mode 100644 index 0000000..3ef645d --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/User/ResetPassword.pm @@ -0,0 +1,63 @@ +package Reaction::InterfaceModel::Action::User::ResetPassword; + +use Reaction::Class; +use Digest::MD5; + +use aliased + 'Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport'; +use aliased 'Reaction::InterfaceModel::Action::User::SetPassword'; + +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); + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::User::ResetPassword + +=head1 DESCRIPTION + +=head2 error_for_attribute + +=head2 confirmation_code + +=head2 verify_confirmation_code + +=head1 SEE ALSO + +L<Reaction::InterfaceModel::Action::DBIC::User::ResetPassword> + +L<Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport> + +=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/User/Role/ConfirmationCodeSupport.pm b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm new file mode 100644 index 0000000..649f76a --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/User/Role/ConfirmationCodeSupport.pm @@ -0,0 +1,44 @@ +package Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport; + +use Reaction::Role; +use Digest::MD5; + +role ConfirmationCodeSupport, which{ + + #requires qw/target_model ctx/; + + 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; + +=head1 NAME + +Reaction::InterfaceModel::Action::User::Role::ConfirmationCodeSupport + +=head1 DESCRIPTION + +=head2 generate_confirmation_code + +=head2 meta + +Need to define confirmation_code_secret in application config. + +=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/User/SetPassword.pm b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm new file mode 100644 index 0000000..fcf922a --- /dev/null +++ b/lib/Reaction/InterfaceModel/Action/User/SetPassword.pm @@ -0,0 +1,69 @@ +package Reaction::InterfaceModel::Action::User::SetPassword; + +use Reaction::Class; +use Reaction::InterfaceModel::Action; + +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); + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Action::User::SetPassword + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +=head2 new_password + +=head2 confirm_new_password + +=head1 METHODS + +=head2 verify_confirm_new_password + +Tests to make sure that C<new_password> and C<confirm_new_password> match. + +=head1 SEE ALSO + +L<Reaction::InterfaceModel::Action::DBIC::User::SetPassword> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection.pm b/lib/Reaction/InterfaceModel/Collection.pm new file mode 100644 index 0000000..05e0c50 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection.pm @@ -0,0 +1,121 @@ +package Reaction::InterfaceModel::Collection; + +use Reaction::InterfaceModel::ObjectClass; +use Scalar::Util qw/refaddr blessed/; + +# WARNING - DANGER: this is just an RFC, please DO NOT USE YET + +class Collection, 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 + domain_model _collection_store => (is => 'rw', isa => 'ArrayRef', + lazy_build => 1, clearer => "_clear_collection_store"); + + 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 }; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Collection - Generic collections of +C<Reaction::InterfaceModel::Object>s + +=head1 DESCRIPTION + +The base class for C<InterfaceModel::Collection>s. The functionality implemented here +is minimal and it is expected that specialized collections be built by sublclassing +this and exploiting the roles system. + +=head1 METHODS + +=head2 members + +Returns a list containing all known members of the collection + +=head2 add_member $object + +Will add the object passed to the collection + +=head2 remove_member $object + +Removed the object passed from the collection, if present + +=head2 count_members + +Returns the number of objects in the collection. + +=head1 ATTRIBUTES + +=head2 _collection_store + +Read-write & lazy_build. Holds the arrayref where the collection of objects is +presently stored. Has a clearer of C<_clear_collection_store> and a predicate of + C<_has_collection_store>. + +=head1 PRIVATE METHODS + +_build_collection_store + +Builder method for attribute_collection_store, returns an empty arrayref + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm new file mode 100644 index 0000000..2da485c --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Base.pm @@ -0,0 +1,130 @@ +package Reaction::InterfaceModel::Collection::DBIC::Role::Base; + +use Reaction::Role; +use Scalar::Util qw/blessed/; +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 '_im_class' => ( + is => 'ro', + isa => 'Str', + lazy_build => 1, + ); + + #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_im_class => as { + my $self = shift; + my $class = blessed $self || $self; + $class =~ s/::Collection$//; + return $class; + }; + + implements _build_collection_store => as { + my $self = shift; + my $im_class = $self->_im_class; + [ $self->_source_resultset->search({}, {result_class => $im_class})->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, + _im_class => $self->_im_class, @_ + ); + }; + + 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"; + }; + +}; + +1; + + +=head1 NAME + +Reaction::InterfaceModel::Collection::DBIC::Role::Base + +=head1 DESCRIPTION + +Provides methods to allow a collection to be populated by a L<DBIx::Class::ResultSet> + +=head1 Attributes + +=head2 _source_resultset + +Required, Read-only. Contains the L<DBIx::Class::ResultSet> used to populate the +collection. + +=head2 _im_class + +Read-only, lazy_build. The name of the IM Object Class that the resultset inside this +collection will inflate to. Predicate: C<_has_im_class> + +=head1 METHODS + +=head2 clone + +Returns a clone of the current collection, complete with a cloned C<_source_resultset> + +=head2 count_members + +Returns the number of items found by the ResultSet + +=head2 add_member + +=head2 remove_member + +These will die as they have not been implemented yet. + +=head1 PRIVATE METHODS + +=head2 _build_im_class + +Will attempt to remove the suffix "Collection" from the current class name and return +that. I.e. C<MyApp::MyIM::Roles::Collection> would return C<MyApp::MyIM::Roles> + +=head2 _build_collection_store + +Replace the default builder to populate the collection with all results returned by the +resultset. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm new file mode 100644 index 0000000..9d789d3 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/DBIC/Role/Where.pm @@ -0,0 +1,58 @@ +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, + _im_class => $self->_im_class + ); + }; + + 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; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Collection::DBIC::Role::Where + +=head1 DESCRIPTION + +Provides methods to allow a ResultSet collection to be restricted + +=head1 METHODS + +=head2 where + +Will return a clone with a restricted C<_source_resultset>. + +=head2 add_where + +Will return itself after restricting C<_source_resultset>. This also clears the +C<_collection_store> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent.pm b/lib/Reaction/InterfaceModel/Collection/Persistent.pm new file mode 100644 index 0000000..d023a6c --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/Persistent.pm @@ -0,0 +1,30 @@ +package Reaction::InterfaceModel::Collection::Persistent; + +use Reaction::Class; +use aliased 'Reaction::InterfaceModel::Collection'; + +class Persistent is Collection, which { + + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Collection::Persistent - Base class for Presistent Collections + +=head1 DESCRIPTION + +A subclass of L<Reaction::InterfaceModel::Collection>s, this class is a base +to Persistent collections. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm new file mode 100644 index 0000000..a73e5cc --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/Persistent/ResultSet.pm @@ -0,0 +1,42 @@ +package Reaction::InterfaceModel::Collection::Persistent::ResultSet; + +use Reaction::Class; + +# WARNING - DANGER: this is just an RFC, please DO NOT USE YET + +class ResultSet is "Reaction::InterfaceModel::Collection::Persistent", which{ + + does "Reaction::InterfaceModel::Collection::DBIC::Role::Base"; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Collection::Persistent::ResultSet + +=head1 DESCRIPTION + +A persistent collection powered by a resultset + +=head1 ROLES CONSUMED + +The following roles are consumed by this class, for more information about the +methods and attributes provided by them please see their respective documentation. + +=over 4 + +=item L<Reaction::InterfaceModel::Collection::DBIC::Role::Base> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual.pm b/lib/Reaction/InterfaceModel/Collection/Virtual.pm new file mode 100644 index 0000000..df81496 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/Virtual.pm @@ -0,0 +1,31 @@ +package Reaction::InterfaceModel::Collection::Virtual; + +use Reaction::Class; +use aliased 'Reaction::InterfaceModel::Collection'; + +class Virtual is Collection, which { + + +}; + +1; + + +=head1 NAME + +Reaction::InterfaceModel::Collection::Virtual - Base class for Virtual Collections + +=head1 DESCRIPTION + +A subclass of L<Reaction::InterfaceModel::Collection>s, this class is a base +to Virtual collections. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm new file mode 100644 index 0000000..3878992 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Collection/Virtual/ResultSet.pm @@ -0,0 +1,55 @@ +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"; + + + implements _build_default_action_class_prefix => as { + shift->_im_class; + }; + +}; + +1; + +=head1 NAME + +Reaction::InterfaceModel::Collection::Virtual::ResultSet + +=head1 DESCRIPTION + +A virtual collection powered by a resultset + +=head1 METHODS + +=head2 _build_default_action_class_prefix + +Returns the classname of the interface model objects contained in this collection. + +=head1 ROLES CONSUMED + +The following roles are consumed by this class, for more information about the +methods and attributes provided by them please see their respective documentation. + +=over 4 + +=item L<Reaction::InterfaceModel::Collection::DBIC::Role::Base> + +=item L<Reaction::InterfaceModel::Collection::DBIC::Role::Where> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/DBIC/Collection.pm b/lib/Reaction/InterfaceModel/DBIC/Collection.pm new file mode 100644 index 0000000..e8f4876 --- /dev/null +++ b/lib/Reaction/InterfaceModel/DBIC/Collection.pm @@ -0,0 +1,56 @@ +package Reaction::InterfaceModel::DBIC::Collection; + +use Reaction::Class; +use aliased 'DBIx::Class::ResultSet'; + +#this will be reworked to isa Reaction::InterfaceModel::Collection as soon as the +#API for that is finalized. + +class Collection is ResultSet, is 'Reaction::Object', which { + + #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 { + my ($self) = @_; + # reset result_class + my $rs = $self->search_rs + ({}, { result_class => $self->result_source->result_class }); + return { target_model => $rs }; + }; + + #feel like it should be an attribute + implements '_action_class_map' => as { {} }; + + #feel like it should be a lazy_build attribute + implements '_default_action_class_prefix' => as { + shift->result_class; + }; + + implements '_default_action_class_for' => as { + my ($self, $action) = @_; + return $self->_default_action_class_prefix.'::Action::'.$action; + }; + + implements '_action_class_for' => as { + my ($self, $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) = @_; + 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); + }; +}; + +1; diff --git a/lib/Reaction/InterfaceModel/DBIC/ModelBase.pm b/lib/Reaction/InterfaceModel/DBIC/ModelBase.pm new file mode 100644 index 0000000..d157769 --- /dev/null +++ b/lib/Reaction/InterfaceModel/DBIC/ModelBase.pm @@ -0,0 +1,111 @@ +package Reaction::InterfaceModel::DBIC::ModelBase; + +use Reaction::Class; + +use Catalyst::Utils; +use Catalyst::Component; +use Class::MOP; + +class ModelBase, is 'Reaction::Object', is 'Catalyst::Component', which { + + has '_schema' => (isa => 'DBIx::Class::Schema', is => 'ro', required => 1); + + implements 'COMPONENT' => as { + my ($class, $app, $args) = @_; + my %cfg = %{ Catalyst::Utils::merge_hashes($class->config, $args) }; + + my $im_class = $cfg{im_class}; + Class::MOP::load_class($im_class); + + my $model_name = $class; + $model_name =~ s/^[\w:]+::(?:Model|M):://; + + #this could be cut out later for a more elegant method + my @domain_models = $im_class->domain_models; + confess "Unable to locate domain model in ${im_class}" + if @domain_models < 1; + confess 'ModelBase does not yet support multiple domain models' + if @domain_models > 1; + my $domain_model = shift @domain_models; + my $schema_class = $domain_model->_isa_metadata; + Class::MOP::load_class($schema_class); + + { + #I should probably MOPize this at some point maybe? nahhhh + no strict 'refs'; + foreach my $collection ( $im_class->parameter_attributes ){ + my $classname = join '::', $class, $collection->name, 'ACCEPT_CONTEXT'; + my $reader = $collection->get_read_method; + *$classname = sub{ $_[1]->model($model_name)->$reader }; + } + } + + my $params = $cfg{db_params} || {}; + my $schema = $schema_class + ->connect($cfg{db_dsn}, $cfg{db_user}, $cfg{db_password}, $params); + + return $class->new(_schema => $schema); + }; + + implements 'ACCEPT_CONTEXT' => as { + my ($self, $ctx) = @_; + return $self->CONTEXTUAL_CLONE($ctx) unless ref $ctx; + return $ctx->stash->{ref($self)} ||= $self->CONTEXTUAL_CLONE($ctx); + }; + + #to do build in support for RestrictByUser natively or by subclass + implements 'CONTEXTUAL_CLONE' => as { + my ($self, $ctx) = @_; + my $schema = $self->_schema->clone; + + my $im_class = $self->config->{im_class}; + + #this could be cut out later for a more elegant method + my @domain_models = $im_class->domain_models; + confess "Unable to locate domain model in ${im_class}" + if @domain_models < 1; + confess 'ModelBase does not yet support multiple domain models' + if @domain_models > 1; + my $domain_model = shift @domain_models; + + return $im_class->new($domain_model->name => $schema); + }; + +}; + + +1; + +=head1 NAME + +Reaction::InterfaceModel::DBIC::ModelBase + +=head1 DESCRIPTION + +=head2 COMPONENT + +=head2 ACCEPT_CONTEXT + +=head2 CONTEXTUAL_CLONE + +=head1 CONFIG OPTIONS + +=head2 db_dsn + +=head2 db_user + +=head2 db_password + +=head2 db_params + +=head2 im_class + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/DBIC/ObjectClass.pm b/lib/Reaction/InterfaceModel/DBIC/ObjectClass.pm new file mode 100644 index 0000000..96c60da --- /dev/null +++ b/lib/Reaction/InterfaceModel/DBIC/ObjectClass.pm @@ -0,0 +1,344 @@ +package Reaction::InterfaceModel::DBIC::ObjectClass; + +use Reaction::ClassExporter; +use Reaction::Class; +use aliased 'Reaction::InterfaceModel::DBIC::Collection'; +use Class::MOP; + +use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; + +use aliased 'Reaction::Meta::InterfaceModel::Action::Class' => 'ActionClass'; + +class ObjectClass, is 'Reaction::InterfaceModel::ObjectClass', which { + override exports_for_package => sub { + my ($self, $package) = @_; + my %exports = $self->SUPER::exports_for_package($package); + + $exports{reflect_actions} = sub { + + my %actions = @_; + my $meta = $package->meta; + my $defaults = { + 'Create' => { base => Create }, + 'Update' => { base => Update }, + 'Delete' => { base => Delete }, + }; + + while (my($name,$opts) = each %actions) { + my $action_class = delete $opts->{class} || + $package->_default_action_class_for($name); + + #support this for now, I don't know about defaults yet though. + #especially, '*' for all writtable attributes. ugh + my $super = delete $opts->{base} || $defaults->{$name}->{base} || []; + my $attrs = delete $opts->{attrs} || []; + $super = (ref($super) ne 'ARRAY' && $super) ? [ $super ] : []; + + $self->reflect_action($meta, $action_class, $super, $attrs); + } + }; + + + my $orig_domain_model = delete $exports{domain_model}; + $exports{domain_model} = sub { + my($dm_name, %opts) = @_; + + my $reflect = delete $opts{reflect}; + my $inflate_result = delete $opts{inflate_result}; + + my @attr_names = map {ref $_ ? $_->[0] : $_ } @$reflect; + $opts{reflect} = [@attr_names]; + $orig_domain_model->($dm_name, %opts); + + #Create an inflate result_method for DBIC objects + my $meta = $package->meta; + if ($inflate_result) { + my $inflate = sub { + my $class = shift; my ($source) = @_; + if($source->isa('DBIx::Class::ResultSourceHandle')) + { + $source = $source->resolve; + } + return $class->new + ($dm_name, $source->result_class->inflate_result(@_)); + }; + $meta->add_method('inflate_result', $inflate); + } + + #relationship magic + my %rel_attrs = map{ @$_ } grep {ref $_} @$reflect; + my $dm_meta = $opts{isa}->meta; + + for my $attr_name ( @attr_names ) { + + my $from_attr = $dm_meta->find_attribute_by_name($attr_name); + confess "Failed to get attribute $attr_name from class $opts{isa}" + unless $from_attr; + + if ( my $info = $opts{isa}->result_source_instance + ->relationship_info($attr_name) ) { + + next unless(my $rel_accessor = $info->{attrs}->{accessor}); + + unless ( $rel_attrs{$attr_name} ) { + my ($im_class) = ($package =~ /^(.*)::\w+$/); + my ($rel_class) = ($attr_name =~ /^(.*?)(_list)?$/); + $rel_class = join '', map{ ucfirst($_) } split '_', $rel_class; + $rel_attrs{$attr_name} = "${im_class}::${rel_class}"; + } + Class::MOP::load_class($rel_attrs{$attr_name}) || + confess "Could not load ".$rel_attrs{$attr_name}; + + #has_many rels + if ($rel_accessor eq 'multi' && + ( $from_attr->type_constraint->name eq 'ArrayRef' || + $from_attr->type_constraint->is_subtype_of('ArrayRef') ) + ) { + + # # remove the old attribute and recreate it with new isa + my %attr_opts = ( is => 'ro', + lazy_build => 1, + isa => Collection, + clearer => "_clear_${attr_name}", + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + $meta->add_attribute( $attr_name, %attr_opts); + + #remove old build and add a better one + #proper collections will remove the result_class uglyness. + my $build_method = sub { + my $rs = shift->$dm_name->search_related_rs + ($attr_name, {}, + { + result_class => $rel_attrs{$attr_name} }); + return bless($rs => Collection); + }; + $meta->remove_method( "build_${attr_name}"); + $meta->add_method( "build_${attr_name}", $build_method); + } elsif ($rel_accessor eq 'single') { + # # remove the old attribute and recreate it with new isa + my %attr_opts = ( is => 'ro', + lazy_build => 1, + isa => $rel_attrs{$attr_name}, + clearer => "_clear_${attr_name}", + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + $meta->add_attribute( $attr_name, %attr_opts); + + #delete and recreate the build method to properly inflate the + #result into an IM::O class instead of the original + #this probably needs some cleaning + #proper collections will remove the result_class uglyness. + my $build_method = sub { + shift->$dm_name->find_related + ($attr_name, {}, + { + result_class => $rel_attrs{$attr_name}}); + }; + $meta->remove_method( "build_${attr_name}"); + $meta->add_method( "build_${attr_name}", $build_method); + } + } elsif ( $from_attr->type_constraint->name eq 'ArrayRef' || + $from_attr->type_constraint->is_subtype_of('ArrayRef') + ) { + #m2m magicness + next unless $attr_name =~ m/^(.*)_list$/; + my $mm_name = $1; + my ($hm_source, $far_side); + # we already get one for the rel info check, unify that?? + my $source = $opts{isa}->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"; + + # # remove the old attribute and recreate it with new isa + my %attr_opts = ( is => 'ro', + lazy_build => 1, + isa => Collection, + clearer => "_clear_${attr_name}", + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + $meta->add_attribute( $attr_name, %attr_opts); + + #proper collections will remove the result_class uglyness. + my $build_method = sub { + my $rs = shift->$dm_name->result_source + ->related_source("links_to_${mm_name}_list") + ->related_source(${mm_name}) + ->resultset->search_rs + ({},{result_class => $rel_attrs{$attr_name} }); + return bless($rs => Collection); + }; + $meta->remove_method( "build_${attr_name}"); + $meta->add_method( "build_${attr_name}", $build_method); + } + } + }; + return %exports; + }; +}; + + +sub reflect_action{ + my($self, $meta, $action_class, $super, $attrs) = @_; + + Class::MOP::load_class($_) for @$super; + + #create the class + my $ok = eval { Class::MOP::load_class($action_class) }; + + confess("Class '${action_class}' does not seem to support method 'meta'") + if $ok && !$action_class->can('meta'); + + my $action_meta = $ok ? + $action_class->meta : ActionClass->create($action_class, superclasses => $super); + + $action_meta->make_mutable if $action_meta->is_immutable; + + foreach my $attr_name (@$attrs){ + my $attr = $meta->find_attribute_by_name($attr_name); + my $dm_isa = $meta->find_attribute_by_name($attr->domain_model)->_isa_metadata; + my $from_attr = $dm_isa->meta->find_attribute_by_name($attr->orig_attr_name); + + #Don't reflect read-only attributes to actions + if ($from_attr->_is_metadata ne 'rw') { + warn("Not relecting read-only attribute ${attr_name} to ${action_class}"); + next; + } + + #add the attribute to the class + $action_class->meta->add_attribute + ( $attr_name => + $self->reflected_attr_opts($meta, $dm_isa, $from_attr) + ); + } + + $action_class->meta->make_immutable; +} + +sub reflected_attr_opts{ + my ($self, $meta, $dm, $attr) = @_; + my $attr_name = $attr->name; + + my %opts = ( + is => 'rw', + isa => $attr->_isa_metadata, + required => $attr->is_required, + predicate => "has_${attr_name}", + ); + + if ($opts{required}) { + $opts{default} = !$attr->has_default ? + sub{confess("${attr_name} must be provided before calling reader")} + : $attr->default; + $opts{lazy} = 1; + } + + #test for relationships + my $source = $dm->result_source_instance; + my $constraint = $attr->type_constraint; + if (my $info = $source->relationship_info($attr_name)) { + if ( $info->{attrs}->{accessor} && + $info->{attrs}->{accessor} eq 'multi') { + confess "${attr_name} is multi and rw. we are confoos."; + } else { + $opts{valid_values} = sub { + $_[0]->target_model->result_source + ->related_source($attr_name)->resultset; + }; + } + } elsif ($constraint->name eq 'ArrayRef' || + $constraint->is_subtype_of('ArrayRef')) { + # it's a many-many. time for some magic. + my $link_rel = "links_to_${attr_name}"; + my ($mm_name) = ($attr_name =~ m/^(.*)_list$/); + confess "Many-many attr must be called <name>_list for reflection" + unless $mm_name; + + my ($hm_source, $far_side); + eval { $hm_source = $source->related_source($link_rel); } + || confess "Can't find ${link_rel} has_many for ${attr_name}"; + 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 ${attr_name}"; + + $opts{default} = sub { [] }; + $opts{valid_values} = sub { + $_[0]->target_model->result_source->related_source($link_rel) + ->related_source($mm_name)->resultset; + }; + } + + return \%opts; +} + +1; + +=head1 NAME + +Reaction::InterfaceModel::DBIC::ObjectClass + +=head1 SYNOPSIS + +=head2 domain_model + + package Prefab::AdminModel::User; + + class User, is Object, which{ + #create an attribute _user_store with type constraint MyApp::DB::User + domain_model '_user_store' => + (isa => 'MyApp::DB::User', + #mirror the following attributes from MyApp::DB::User + #will create collections for rels which use result_classes of: + # Prefab::AdminModel::(Group|ImagedDocument) + # Prefab::AdminModel::DocumentNotes + reflect => [qw/id username password created_d group_list imaged_document/, + [doc_notes_list => 'Prefab::AdminModel::DocumentNotes'] + ], + #automatically add a sub inflate_result that inflates the DBIC obj + #to a Prefab::AdminModel::User with the dbic obj in _user_store + inflate_result => 1, + ); + }; + +=head2 reflect_actions + + reflect_actions + ( + Create => { attrs =>[qw(first_name last_name baz_list)] }, + Update => { attrs =>[qw(first_name last_name baz_list)] }, + Delete => {}, + ); + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +=head2 isa + +=head2 reflect + +=head2 inflate_result + +=head2 handles + +=head1 METHODS + +=head2 reflect_actions + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/DBIC/SchemaClass.pm b/lib/Reaction/InterfaceModel/DBIC/SchemaClass.pm new file mode 100644 index 0000000..3d58b57 --- /dev/null +++ b/lib/Reaction/InterfaceModel/DBIC/SchemaClass.pm @@ -0,0 +1,154 @@ +package Reaction::InterfaceModel::DBIC::SchemaClass; + +use Reaction::ClassExporter; +use Reaction::Class; +use aliased 'Reaction::InterfaceModel::DBIC::Collection'; +use Reaction::InterfaceModel::Object; +use Class::MOP; + +# consider that the schema class should provide it's own connect method, that +# way for single domain_models we could just let handles => take care of it +# and for many domain_models we could iterate through them and connect.. or something +# similar. is that crossing layers?? I think it seems reasonable TBH + +class SchemaClass which { + + overrides default_base => sub { ('Reaction::InterfaceModel::Object') }; + + override exports_for_package => sub { + my ($self, $package) = @_; + my %exports = $self->SUPER::exports_for_package($package); + + $exports{domain_model} = sub{ + my($dm_name, %opts) = @_; + my $meta = $package->meta; + + my $isa = $opts{isa}; + confess 'no isa declared!' unless defined $isa; + + unless( ref $isa || Moose::Util::TypeConstraints::find_type_constraint($isa) ){ + eval{ Class::MOP::load_class($isa) }; + warn "'${isa}' is not a valid Moose type constraint. Moose will treat it as ". + "a class name and create an anonymous constraint for you. This class is ". + "not currently load it and ObjectClass failed to load it. ($@)" + if $@; + } + + my $reflect = delete $opts{reflect}; + confess("parameter 'reflect' must be an array reference") + unless ref $reflect eq 'ARRAY'; + + $meta->add_domain_model($dm_name, is => 'ro', required => 1, %opts); + + for ( @$reflect ){ + my ($moniker,$im_class,$reader) = ref $_ eq 'ARRAY' ? @$_ : ($_); + + my $clearer = "_clear_${moniker}"; + $im_class ||= "${package}::${moniker}"; + Class::MOP::load_class($im_class) || confess "Could not load ${im_class}"; + + unless($reader){ + $reader = $moniker; + $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $reader = lc($moniker) . "_collection"; + } + # problem: we should have fresh resultsets every time the reader is called + # solution 1: override reader to return fresh resultsets each time. + # solution 2: uing an around modifier on the reader,call clearer after + # getting the collection from the $super->(), but before returning it. + # #1 seems more efficient, but #2 seems more correct. + my %args = (isa => Collection, domain_model => $dm_name, + lazy_build => 1, reader => $reader, clearer => $clearer); + my $attr = $meta->add_attribute($moniker, %args); + + # blessing into a collection is very dirty, but it'll have to do until I + # create a proper collection object. This should happen as soon as me and mst + # can deisgn a common API for Collections. + my $build_method = sub { + my $collection = shift->$dm_name->resultset( $moniker ); + $collection = $collection->search_rs({}, {result_class => $im_class}); + return bless($collection => Collection); + }; + + $meta->add_method( "build_${moniker}", $build_method); + + my $reader_method = sub{ + my ($super, $self) = @_; + my $result = $super->($self); + $self->$clearer; + return $result; + }; + $meta->add_around_method_modifier($attr->reader, $reader_method); + } + }; + + return %exports; + }; +}; + +1; + +__END__; + +=head1 NAME + +Reaction::InterfaceModel::DBIC::SchemaClass + +=head1 SYNOPSYS + + package MyApp::AdminModel; + + use Reaction::InterfaceModel::DBIC::ObjectClass; + + #unless specified, the superclass will be Reaction::InterfaceModel::Object + class AdminModel, which{ + domain_model'my_db_schema' => + ( isa => 'MyApp::Schema', + reflect => [ + 'ResultSetA', # same as ['ResultSetA'] + [ResultSetB => 'MyApp::AdminModel::RSB'], + [ResultSetC => 'MyApp::AdminModel::RSC', 'resultset_c_collection'], + ], + ); + +=head1 DESCRIPTION + +Each item in reflect may be either a string or an arrayref. If a string, it should be +the name of the ResultSet, ie what you would put inside + $schema->resultset( 'rs_name' ); As an array it must contain the resultset name, +and may optionally provide the proper InterfaceModel class and the name of the method +used to obtain a collection. + +The example shown will generate reflects 3 resultsets from MyApp::Schema, +a DBIC::Schema file which will be stored as attribute 'my_db_schema', which is +an attribute of type Reaction::InterfaceModel::Object::DomainModelAttribute. + +ResultSetA will be reflected as an attribute named 'ResultSetA', will inflate to the +IM Class 'MyApp::AdminModel::ResultSetA' and a collection can be obtained through +MyApp::AdminModel->resultseta_collection + +ResultSetB will be reflected as an attribute named 'ResultSetB', will inflate to the +IM Class 'MyApp::AdminModel::RSB' and a collection can be obtained through +MyApp::AdminModel->resultsetb_collection + +ResultSetC will be reflected as an attribute named 'ResultSetC', will inflate to the +IM Class 'MyApp::AdminModel::RSC' and a collection can be obtained through +MyApp::AdminModel->resultset_c_collection + +=head1 METHODS + +=head2 default_base + +Specifies the superclass, the default being L<Reaction::InterfaceModel::Object>. + +=head2 exports_for_package + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Object.pm b/lib/Reaction/InterfaceModel/Object.pm new file mode 100644 index 0000000..7c5ec23 --- /dev/null +++ b/lib/Reaction/InterfaceModel/Object.pm @@ -0,0 +1,151 @@ +package Reaction::InterfaceModel::Object; + +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) = @_; + + #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) = @_; + 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) = @_; + 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 { {} }; + +}; + +1; + +__END__; + + +=head1 NAME + +Reaction::Class::InterfaceModel::Object + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +InterfaceModel Object base class. + +=head1 Attributes + +=head2 _action_class_map + +RW, isa HashRef - Returns an empty hashref by default. It will hold a series of actions +as keys with their corresponding action classes as values. + +=head2 _default_action_class_prefix + +RO, isa Str - Default action class prefix. Lazy build by default to the value +returned by C<_build_default_action_class_prefix> which is C<ref $self || $self>. + +=head1 Methods + +=head2 parameter_attributes + +=head2 domain_models + +Shortcuts for these same subs in meta. They will return attribute objects that are of +the correct type, L<Reaction::Meta::InterfaceModel::Object::ParameterAttribute> and +L<Reaction::Meta::InterfaceModel::Object::DomainModelAttribute> + +=head2 _default_action_class_for $action + +Provides the default package name for the C<$action> action-class. +It defaults to the value of C<_default_action_class_prefix> followed by +C<::Action::$action> + + #for MyApp::Foo, returns MyApp::Foo::Action::Create + $obj->_default_action_class_for('Create'); + +=head2 _action_class_for $action + +Return the action class for an action name. Will search +C<_action_class_map> or, if not found, use the value of +C<_default_action_class_for> + +=head2 action_for $action, %args + +Will return a new instance of C<$action>. If specified, + %args will be passed through to C<new> as is. + +=head2 _default_action_args_for + +By default will return an empty hashref + +=head2 _override_action_args_for + +Returns empty hashref by default. + +=head1 SEE ALSO + +L<Reaction::InterfaceModel::ObjectClass> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/ObjectClass.pm b/lib/Reaction/InterfaceModel/ObjectClass.pm new file mode 100644 index 0000000..e6c413e --- /dev/null +++ b/lib/Reaction/InterfaceModel/ObjectClass.pm @@ -0,0 +1,148 @@ +package Reaction::InterfaceModel::ObjectClass; + +use Reaction::ClassExporter; +use Reaction::Class; +use Class::MOP; + +#use Reaction::InterfaceModel::Object; +use Moose::Util::TypeConstraints (); +use Reaction::InterfaceModel::Object; + +class ObjectClass which { + + overrides default_base => sub { ('Reaction::InterfaceModel::Object') }; + + overrides exports_for_package => sub { + my ($self, $package) = @_; + my %exports = $self->SUPER::exports_for_package($package); + + $exports{domain_model} = sub { + my($dm_name, %opts)= @_; + + my $isa = $opts{isa}; + confess 'no isa declared!' unless defined $isa; + + unless( ref $isa || Moose::Util::TypeConstraints::find_type_constraint($isa) ){ + eval{ Class::MOP::load_class($isa) }; + warn "'${isa}' is not a valid Moose type constraint. Moose will treat it as ". + "a class name and create an anonymous constraint for you. This class is ". + "not currently load it and ObjectClass failed to load it. ($@)" + if $@; + } + + my $attrs = delete $opts{reflect}; + my $meta = $package->meta; + + #let opts override is and required as needed + my $dm_attr = $meta->add_domain_model($dm_name, is => 'ro', required => 1, %opts); + + return unless ref $attrs && @$attrs; + my $dm_meta = eval{ $isa->meta }; + confess "Reflection requires that the argument to isa ('${isa}') be a class ". + " supporting introspection e.g a Moose-based class." if $@; + + foreach my $attr_name (@$attrs) { + my $from_attr = $dm_meta->find_attribute_by_name($attr_name); + my $reader = $from_attr->get_read_method; + + my %attr_opts = ( is => 'ro', + lazy_build => 1, + isa => $from_attr->_isa_metadata, + clearer => "_clear_${attr_name}", + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + + $meta->add_attribute( $attr_name, %attr_opts); + $meta->add_method( "build_${attr_name}", sub{ shift->$dm_name->$reader }); + } + + my $clearer = sub{ $_[0]->$_ for map { "_clear_${_}" } @$attrs }; + + $package->can('_clear_reflected') ? + $meta->add_before_method_modifier('_clear_reflected', $clearer) : + $meta->add_method('_clear_reflected', $clearer); + + #i dont like this, this needs reworking, maybe pass + # target_models => [$self->meta->domain_models?] + # or maybe this should be done by reflect_actions ? + # what about non-reflected actions then though? + # maybe a has_action => ('Action_Name' => ActionClass) keyword? + #it'd help in registering action_for .... + #UPDATE: this is going away very very soon + my $dm_reader = $dm_attr->get_read_method; + if($package->can('_default_action_args_for')){ + my $act_args = sub { + my $super = shift; + my $self = shift; + return { %{ $super->($self, @_) }, target_model => $self->$dm_reader }; + }; + $meta->add_around_method_modifier('_default_action_args_for', $act_args); + } else { + $meta->add_method('_default_action_args_for', sub { + return {target_model => shift->$dm_reader}; + } + ); + } + }; + + return %exports; + }; + +}; + +1; + +__END__; + +=head1 NAME + +Reaction::Class::InterfaceModel::ObjectClass + +=head1 SYNOPSIS + + package MyApp::AdminModel::Foo; + use Reaction::Class::InterfaceModel::ObjectClass; + + #will default to be a Reaction::InterfaceModel::Object unless otherwise specified + class Foo, which{ + #create an attribute _user_store with type constraint MyApp::Data::User + domain_model '_user_store' => + (isa => 'MyApp::Data::User', + #mirror the following attributes from MyApp::Data::User + reflect => [qw/id username password created_d/], + ... + }; + +=head1 DESCRIPTION + +Extends C<Reaction::Class> to provide new sugar for InterfaceModel Objects. + +=head1 Extended methods / new functionality + +=head2 exports_for_package + +Overridden to add exported methods C<proxies> and C<_clear_proxied> + +=head2 domain_model $name => ( isa => 'Classname' reflect => [qw/attr names/] ) + +Will create a read-only required attribute $name of type C<isa> which will +reflect the attributes named in C<reflect>, to the local class as +read-only attributes that will build lazily. + +It will also override C<_default_action_args_for> to pass the domain model +as C<target_model> + +=head2 _clear_reflected + +Will clear all reflected attributes. + +=head2 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm new file mode 100644 index 0000000..ca4f8ad --- /dev/null +++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm @@ -0,0 +1,774 @@ +package Reaction::InterfaceModel::Reflector::DBIC; + +use aliased 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; +use aliased 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; + +use aliased 'Reaction::InterfaceModel::Collection::Virtual::ResultSet'; +use aliased 'Reaction::InterfaceModel::Object'; +use aliased 'Reaction::InterfaceModel::Action'; +use Reaction::Class; +use Class::MOP; + +class DBIC, which { + + has model_class => (isa => "Str", is => 'ro', required => 1); + has debug_mode => + (isa => 'Bool', is => 'rw', required => 1, default => '0'); + has make_classes_immutable => + (isa => 'Bool', is => 'rw', required => 1, default => '0'); + + has default_object_actions => + ( isa => "ArrayRef", is => "rw", required => 1, + default => sub{ + [ { name => 'Update', base => Update }, + { name => 'Delete', base => Delete, + attributes => [], + }, + ]; + } ); + + has default_collection_actions => + ( isa => "ArrayRef", is => "rw", required => 1, + default => sub{ + [{name => 'Create', base => Create}], + } ); + + implements BUILD => as{ + my $self = shift; + my $ok = eval {Class::MOP::load_class( $self->model_class ); }; + + unless ($ok){ + print STDERR "Creating target class ". $self->model_class . "\n" + if $self->debug_mode; + Object->meta->create($self->model_class, superclasses => [ Object ]); + } + }; + + implements submodel_classname_from_source_name => as { + my ($self, $moniker) = @_; + return join "::", $self->model_class, $moniker; + }; + + implements classname_for_collection_of => as { + my ($self, $object_class) = @_; + return "${object_class}::Collection"; + }; + + #requires domain_model everything else optional + implements reflect_model => as { + my ($self, %opts) = @_; + my $meta = $self->model_class->meta; + my $source = delete $opts{domain_model_class}; + my $dm_name = delete $opts{domain_model_name}; + my $dm_args = delete $opts{domain_model_args} || {}; + + my $reflect_submodels = delete $opts{reflect_submodels}; + my %exclude_submodels = map {$_ => 1} + ref $opts{exclude_submodels} ? @{$opts{exclude_submodels}} : (); + + Class::MOP::load_class($source); + my $make_immutable = $self->make_classes_immutable || $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + unless( $dm_name ){ + $dm_name = "_".$source; + $dm_name =~ s/::/_/g; + } + + print STDERR "Reflecting model '$source' with domain model '$dm_name'\n" + if $self->debug_mode; + $meta->add_domain_model($dm_name, is => 'rw', required => 1, %$dm_args); + + #reflect all applicable submodels on undef + @$reflect_submodels = $source->sources unless ref $reflect_submodels; + @$reflect_submodels = grep { !$exclude_submodels{$_} } @$reflect_submodels; + + for my $moniker (@$reflect_submodels){ + my $source_class = $source->class($moniker); + print STDERR "... and submodel '$source_class'\n" if $self->debug_mode; + my $sub_meta = $self->reflect_submodel(domain_model_class => $source_class); + my $col_meta = $self->reflect_collection_for(object_class => $sub_meta->name); + + $self->add_submodel_to_model( + source_name => $moniker, + domain_model_name => $dm_name, + collection_class => $col_meta->name, + ); + } + + $meta->make_immutable if $make_immutable; + return $meta; + }; + + #XXX I could make domain_model_name by exploiting the metadata in the + #DomainModelAttribute, I'm just waiting to properly redesign DMAttr, + #it'll be good, I promise. + + implements add_submodel_to_model => as { + my($self, %opts) = @_; + my $reader = $opts{reader}; + my $moniker = $opts{source_name}; + my $dm_name = $opts{domain_model_name}; + my $c_class = $opts{collection_class}; + my $name = $opts{attribute_name} || $moniker; + my $meta = $self->model_class->meta; + + my $make_immutable = $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + unless ($reader){ + $reader = $moniker; + $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $reader = lc($reader) . "_collection"; + } + + my %attr_opts = + ( + lazy => 1, + isa => $c_class, + required => 1, + reader => $reader, + predicate => "has_${moniker}", + domain_model => $dm_name, + orig_attr_name => $moniker, + default => sub { + $c_class->new(_source_resultset => shift->$dm_name->resultset($moniker) ); + }, + ); + print STDERR "... linking submodel '$c_class' through method '$reader'\n" + if $self->debug_mode; + + my $attr = $meta->add_attribute($moniker, %attr_opts); + $meta->make_immutable if $make_immutable; + return $attr; + }; + + # requires #object_class, everything else optional + implements reflect_collection_for => as { + my ($self, %opts) = @_; + my $object = delete $opts{object_class}; + my $base = delete $opts{base} || ResultSet; + my $actions = delete $opts{reflect_actions} || $self->default_collection_actions; + my $class = $opts{class} || $self->classname_for_collection_of($object); + + Class::MOP::load_class($base); + my $meta = eval { Class::MOP::load_class($class) } ? + $class->meta : $base->meta->create($class, superclasses =>[ $base ]); + my $make_immutable = $self->make_classes_immutable || $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + $meta->add_method(_build_im_class => sub{ $object } ); + print STDERR "... Reflecting collection of $object as $class\n" + if $self->debug_mode; + + for my $action (@$actions){ + unless (ref $action){ + my $default = grep {$_->{name} eq $action} @{ $self->default_collection_actions }; + confess("unable to reflect action $action") unless $default; + $action = $default; + } + $self->reflect_submodel_action(submodel_class => $object, %$action); + my $act_args = sub { #override target model for this action + my $super = shift; + return { %{$super->(@_)},($_[1] eq $action->{name} ? + (target_model => $_[0]->_source_resultset) : () )}; + }; + $meta->add_around_method_modifier('_default_action_args_for', $act_args); + } + + $meta->make_immutable if $make_immutable; + return $meta; + }; + + #requires domain_model_class everything else optional + implements reflect_submodel => as { + my ($self, %opts) = @_; + my $source = delete $opts{domain_model_class}; + my $base = delete $opts{base} || Object; + my $dm_name = delete $opts{domain_model_name}; + my $dm_opts = delete $opts{domain_model_args} || {}; + my $inflate = exists $opts{inflate} ? delete $opts{inflate} : 1; + my $class = delete $opts{class} || + $self->submodel_classname_from_source_name($source->source_name); + my $actions = delete $opts{reflect_actions} || $self->default_object_actions; + + #create the custom class + Class::MOP::load_class($base); + my $meta = eval { Class::MOP::load_class($class) } ? + $class->meta : $base->meta->create($class, superclasses =>[ $base ]); + my $make_immutable = $self->make_classes_immutable || $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + #create the domain model + unless( $dm_name ){ + ($dm_name) = ($source =~ /::([\w_\-]+)$/); #XXX be smarter at some point + $dm_name =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $dm_name = "_" . lc($dm_name) . "_store"; + } + + $dm_opts->{isa} = $source; + $dm_opts->{is} ||= 'rw'; + $dm_opts->{required} ||= 1; + my $dm_attr = $meta->add_domain_model($dm_name, %$dm_opts); + + #Inflate the row into an IM object directly from DBIC + if( $inflate ){ + 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); + } + + #attribute reflection + my $reflect_attrs = delete $opts{reflect_attributes}; + my %exclude_attrs = + map {$_ => 1} ref $opts{exclude_attributes} ? @{$opts{exclude_attributes}} : (); + + #reflect all applicable attributes on undef + $reflect_attrs = [map {$_->name} $source->meta->compute_all_applicable_attributes] + unless ref $reflect_attrs; + @$reflect_attrs = grep { !$exclude_attrs{$_} } @$reflect_attrs; + + for my $attr_name (@$reflect_attrs){ + $self->reflect_submodel_attribute( + class => $class, + attribute_name => $attr_name, + domain_model_name => $dm_name + ); + } + + for my $action (@$actions){ + unless (ref $action){ + my $default = grep {$_->{name} eq $action} @{ $self->default_object_actions }; + confess("unable to reflect action $action") unless $default; + $action = $default; + } + $self->reflect_submodel_action(submodel_class => $class, %$action); + my $dm = $dm_attr->get_read_method; + my $act_args = sub { #override target model for this action + my $super = shift; + return { %{ $super->(@_) }, + ($_[1] eq $action->{name} ? (target_model => $_[0]->$dm) : () ) }; + }; + $meta->add_around_method_modifier('_default_action_args_for', $act_args); + } + + $meta->make_immutable if $make_immutable; + return $meta; + }; + + # needs class, attribute_name domain_model_name + implements reflect_submodel_attribute => as { + my ($self, %opts) = @_; + my $meta = $opts{class}->meta; + my $attr_opts = $self->parameters_for_submodel_attr(%opts); + + 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; + }; + + # needs class, attribute_name domain_model_name + implements parameters_for_submodel_attr => as { + my ($self, %opts) = @_; + + my $attr_name = $opts{attribute_name}; + my $dm_name = $opts{domain_model_name}; + my $domain = $opts{domain_model_class}; + $domain ||= $opts{class}->meta->find_attribute_by_name($dm_name)->_isa_metadata; + my $from_attr = $domain->meta->find_attribute_by_name($attr_name); + my $source = $domain->result_source_instance; + + #default options. lazy build but no outsider method + my %attr_opts = ( is => 'ro', lazy => 1, required => 1, + clearer => "_clear_${attr_name}", + predicate => "has_${attr_name}", + domain_model => $dm_name, + orig_attr_name => $attr_name, + ); + + #m2m / has_many + my $constraint_is_ArrayRef = + $from_attr->type_constraint->name eq 'ArrayRef' || + $from_attr->type_constraint->is_subtype_of('ArrayRef'); + + if( my $rel_info = $source->relationship_info($attr_name) ){ + my $rel_accessor = $rel_info->{attrs}->{accessor}; + my $rel_moniker = $rel_info->{class}->source_name; + + if($rel_accessor eq 'multi' && $constraint_is_ArrayRef) { + #has_many + my $sm = $self->submodel_classname_from_source_name($rel_moniker); + #type constraint is a collection, and default builds it + $attr_opts{isa} = $self->classname_for_collection_of($sm); + $attr_opts{default} = sub { + my $rs = shift->$dm_name->related_resultset($attr_name); + return $attr_opts{isa}->new(_source_resultset => $rs); + }; + } elsif( $rel_accessor eq 'single') { + #belongs_to + #type constraint is the foreign IM object, default inflates it + $attr_opts{isa} = $self->submodel_classname_from_source_name($rel_moniker); + $attr_opts{default} = sub { + shift->$dm_name + ->find_related($attr_name, {},{result_class => $attr_opts{isa}}); + }; + } + } 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->submodel_classname_from_source_name($far_side->source_name); + $attr_opts{isa} = $self->classname_for_collection_of($sm); + + #proper collections will remove the result_class uglyness. + $attr_opts{default} = sub { + my $rs = shift->$dm_name->result_source->related_source($link_table) + ->related_source($mm_name)->resultset; + return $attr_opts{isa}->new(_source_resultset => $rs); + }; + } else { + #no rel + my $reader = $from_attr->get_read_method; + $attr_opts{isa} = $from_attr->_isa_metadata; + $attr_opts{default} = sub{ shift->$dm_name->$reader }; + } + return \%attr_opts; + }; + + + #XXX change superclasses to "base" ? + implements reflect_submodel_action => as{ + my($self, %opts) = @_; + my $im_class = delete $opts{submodel_class}; + my $base = delete $opts{base} || Action; + my $attrs = delete $opts{attributes}; + my $name = delete $opts{name}; + my $class = delete $opts{class} || $im_class->_default_action_class_for($name); + + print STDERR "... Reflecting action $name for $im_class as $class\n" + if $self->debug_mode; + + Class::MOP::load_class($_) for($base, $im_class); + $attrs = [ map{$_->name} $im_class->parameter_attributes] unless ref $attrs; + my $im_meta = $im_class->meta; + + #create the class + my $meta = eval { Class::MOP::load_class($class) } ? + $class->meta : $base->meta->create($class, superclasses => [$base]); + my $make_immutable = $self->make_classes_immutable || $meta->is_immutable; + $meta->make_mutable if $meta->is_immutable; + + foreach my $attr_name (@$attrs){ + my $im_attr = $im_meta->find_attribute_by_name($attr_name); + my $dm_attr = $im_meta->find_attribute_by_name($im_attr->domain_model); + my $dm_meta = $dm_attr->_isa_metadata->meta; + my $from_attr = $dm_meta->find_attribute_by_name($im_attr->orig_attr_name); + + #Don't reflect read-only attributes to actions + unless( $from_attr->get_write_method ) { + print STDERR "..... not relecting read-only attribute ${attr_name} to ${class}" + if $self->debug_mode; + next; + } + + my $attr_params = $self->parameters_for_submodel_action_attribute + ( submodel_class => $im_class, attribute_name => $attr_name ); + + #add the attribute to the class + $meta->add_attribute( $attr_name => %$attr_params); + } + + $meta->make_immutable if $make_immutable; + return $meta; + }; + + + implements parameters_for_submodel_action_attribute => as { + my ($self, %opts) = @_; + + #XXX we need the domain model name so we can do valid_values correcty.... + #otherwise we could do away with submodel_class and use domain_model_class instead + #we need for domain_model to be set on the attr which we may not be sure of + my $submodel = delete $opts{submodel_class}; + my $sm_meta = $submodel->meta; + my $attr_name = delete $opts{attribute_name}; + my $dm_name = $sm_meta->find_attribute_by_name($attr_name)->domain_model; + my $domain = $sm_meta->find_attribute_by_name($dm_name)->_isa_metadata; + my $from_attr = $domain->meta->find_attribute_by_name($attr_name); + my $source = $domain->result_source_instance; + + 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, + predicate => "has_${attr_name}", + ); + + if ($attr_opts{required}) { + $attr_opts{lazy} = 1; + $attr_opts{default} = $from_attr->has_default ? $from_attr->default : + sub{confess("${attr_name} must be provided before calling reader")}; + } + + #test for relationships + 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}; + + 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') { + $attr_opts{valid_values} = sub { + shift->target_model->result_source->related_source($attr_name)->resultset; + }; + } + } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) { + my $mm_name = $1; + my $link_table = "links_to_${mm_name}_list"; + my ($hm_source, $far_side); + eval { $hm_source = $source->related_source($link_table); } + || confess "Can't find ${link_table} has_many for ${mm_name}_list"; + eval { $far_side = $hm_source->related_source($mm_name); } + || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class + ." traversing many-many for ${mm_name}_list"; + + $attr_opts{default} = sub { [] }; + $attr_opts{valid_values} = sub { + shift->$dm_name->result_source->related_source($link_table) + ->related_source($mm_name)->resultset; + }; + } + return \%attr_opts; + }; + +}; + +1; + + +=head1 NAME + +Reaction::InterfaceModel::Reflector::DBIC - Autogenerate an Interface Model from +a DBIx::Class Schema. + +=head1 DESCRIPTION + +This class will reflect a L<DBIx::Class::Schema> to a C<Reaction::InterfaceModel::Object>. +It can aid you in creating interface models, collections, and associated actions rooted +in DBIC storage. + +=head1 SYNOPSYS + + #model_class is the namespace where our reflected interface model will be created + my $reflector = Reaction::InterfaceModel::Reflector::DBIC + ->new(model_class => 'RTest::TestIM'); + + #Example 1: Reflect all submodels (result sources / tables) + #domain_model_class ISA DBIx::Class::Schema + $reflector->reflect_model(domain_model_class => 'RTest::TestDB'); + #the '_RTest_TestDB' attribute is created automatically to store the domain model + RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) ); + + #Example 2: Don't reflect the FooBaz submodel + $reflector->reflect_model( + domain_model_class => 'RTest::TestDB', + exclude_submodels => ['FooBaz'], + ); + RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) ); + + #Example 3: Only reflect Foo, Bar, and Baz + $reflector->reflect_model( + domain_model_class => 'RTest::TestDB', + reflect_submodels => [qw/Foo Bar Baz/], + ); + RTest::TestIM->new(_RTest_TestDB => RTest::TestDB->connect(...) ); + + #Example 4: Explicit domain_model_name + $reflector->reflect_model( + domain_model_class => 'RTest::TestDB', + domain_model_name => '_rtest_testdb', + ); + RTest::TestIM->new(_rtest_testdb => RTest::TestDB->connect(...) ); + +=head1 A NOTE ABOUT REFLECTION + +This class is meant as an aid in rapid prototyping and CRUD functionality creation. +While parts of it should be useful for projects of any size, any non-trivial +application will likely require some hand-coding or tweaking to get the most out of +this tool. Reflection, like CRUD, is not a magic bullet. It's just a way to help you +eliminate repetitive and unnecessary coding. + +=head1 OVERVIEW & DEFAULT NAMING CONVENTIONS + +By default (you can override this behavior later), The top-level model (the one +corresponding to your schema) will be reflected to the class name you provide at +instantiation, submodels to the model name plus the name of the source, and collections +to the name of the submodel plus "Collection". Action names, if not specified directly +will be determined by using the submodel's "_action_name_for" method. + +=head2 A Note about Immutable + +The methods that modify classes will check for class immutability and unlock classes +for modification if they are immutable. Classes will be locked again after they are +modified if they were locked at the start. + +=head1 ATTRIBUTES + +=head2 model_class + +Required, Read-only. This is the name of the class where your top model will be created +and the namespace under which all your submodels, actions, collections will be +created. + +=head2 make_classes_immutable + +Read-Write boolean, defaults to false. If this is set to true, after classes are +created they will be made immutable. + +=head2 default_object_actions + +=head2 default_collection_actions + +These hold an ArrayRef of action prototypes. An Action prototype is a hashref +with at least 2 keys, "name" and "base" the latter which is an otional superclass +for this action. By default a "Create" action is reflected for Collections and +"Update" and "Delete" actions for IM Objects. You may add here any +attribute that reflect_submodel_action takes, i.e. for an action that doesn't need +any reflected attributes, like Delete, use C<attributes =E<gt> []>. + +=head2 debug_mode + +Read-Write boolean, defaults to false. In the future this will provide valuable +information at runtime, however that has not yet been implemented. + +=head1 METHODS + +=head2 submodel_classname_from_source_name $source_name + +Generate the classname for a submodel from the result source's name. + +=head2 classname_for_collection_for $object_class + +Returns the classname for a collection of a certain submodel. Currently it just appends +"::Collection" + +=head2 reflect_model %args + +=over 4 + +=item C<domain_model_class> - Required, this is the classname of your Schema + +=item C<domain_model_name> - The name to use when creating the domain model attribute +If you don't supply this one will automatically be generated by prefacing the domain_model_class +with an underscore and replacing all instances of "::", with "_" + +=item C<domain_model_args> - Any other optional arguments suitable for passing to C<add_attribute> + +=item C<reflect_submodels> - An ArrayRef of the source names of the submodels to reflect. +If the value is not a reference it will attempt to reflect all sources. In the future +there may be regex support + +=item C<exclude_submodels> - ArrayRef of submodels to exclude from reflection. In the +future there may be regex support + +=back + +This method will query the schema given to it and reflect all appropriate submodels as +well as calling C<add_submodel_to_model> to create an attribute in the reflected model +which returns an appropriate collection. + +=head2 add_submodel_to_model %args + +=over 4 + +=item C<source_name> - The DBIC source name for this submodel + +=item C<collection_class> - The classname for the collection type for this submodel. + +=item C<attribute_name> - The name of the attribute to create in the model to represent +this submodel. If one is not supplied the source name will be used. + +=item C<domain_model_name> - The attribute name of the domain model where the schema is +located. In the future this may be optional since it can be detected, but it needs to +wait until some changes are made to the attribute metaclasses. + +=item C<reader> - The read method for the submodel attribute. If one is not provided, +a lower case version of the source name with underscores separating previous cases +of a camel-case word change and "_collection" appended will be used. Examples: +"FooBar" becomes C<foo_bar_collection> and "Foo" becomes C<foo_collection>. + +=back + +This will create a read-only attribute in your main model that will return a +collection of the submodel type when the reader is called. This will return the same +collection every time, not a fresh one. This may change in the future, but I really +see no need for it right now. + +=head2 reflect_collection_for \%args + +=over 4 + +=item C<object_class> - Required. The class ob objects this collection will be representing + +=item C<base> - Optional, if you'd like to use a different base for the Collection other +than L<Reaction::InterfaceModel::Collection::Virtual::ResultSet> you can set it here + +=item C<reflect_actions> - Action prototypes for the actions you wish to reflect for +this collection. If nothing is specified then C<default_collection_actions> is used. +An Action prototype is a hashref with at least 2 keys, "name" and "base" the latter +is the superclass for this action. Using an empty array reference would reflect nothing. + +=item C<class> - The desired classname for this collection. If none is provided, then +the value returned by C<classname_for_collection_of> is used. + +=back + +This method will create a new collection class that inherits from C<base> and overrides +C<_build_im_class> to return C<object_class>. Additionally it will automatically +override C<_default_action_args_for> as needed for reflected actions. + +=head2 reflect_submodel \%args + +=over 4 + +=item C<domain_model_class> - The class from which the submodel will be created, or your +source class, e.g. MyApp::Schema::Foo + +=item C<base> - Optional, if you'd like to use a different base other than +L<Reaction::InterfaceModel::Object> + +=item C<domain_model_name> - the name to use for your domain model attribute. If one +is not provided, a lower case version of the source name begining with an underscore +and with underscores separating previous cases of a camel-case word change and +"_store" appended will be used. +Examples: "FooBar" becomes C<_foo_bar_store> and "Foo" becomes C<_foo_store>. + +=item C<domain_model_args> - Any additional arguments you may want to pass to the domain +model when it is created e.g. C<handles> + +=item C<inflate> - unless this is set to zero an inflate_result method will be created. + +=item C<class> - the name of the submodel class created, if you don't specify it the +value returned by C<submodel_classname_from_source_name> will be used + +=item C<reflect_actions> - Action prototypes for the actions you wish to reflect for +this collection. If nothing is specified then C<default_object_actions> is used. +An Action prototype is a hashref with at least 2 keys, "name" and "base" the latter +is the superclass for this action. Using an empty array reference would reflect nothing. + +=item C<reflect_attributes> - an arrayref of the names of the attributes you want to +reflect, if this is not an arrayref it will attempt to reflect all attributes, +if you wish to not reflect anything pass it an empty arrayref + +=item C<exclude_attributes> - an arrayref of the names of the attributes to exclude. + +=back + +This method will create the submodel class, copy the applicable attributes and create +the appropriate domain model attribute as well as create the necessary actions and +perform the necessary overrides to C<_default_action_args_for> + +=head2 reflect_submodel_attribute \%args + +Takes the same arguments as C<parameters_for_submodel_attribute>. + +Reflect this attribute and add it to the submodel class. + +=head2 parameters_for_submodel_attribute \%args + +=over 4 + +=item C<class> - the submodel class + +=item C<attribute_name> - the name of the attribute you want to reflect + +=item C<domain_model_class> - the class where we are copying the attribute from. +If not specified, the type constraint on the domain model attribute will be used + +=item C<domain_model_name> - the name of the domain model attribute. + +=back + +This method determines the parameters necessary for reflecting the argument. Most +of the magic here is so that relations can be accurately reflected so that many-to-one +relationships can return submodel objects and one-to-many and many-to-many +relationships can return collections. By default all reflected attributes will be built +lazily from their parent domain model. + +=head2 reflect_submodel_action \%args + +=over 4 + +=item C<submodel_class> - the submodel class this action will be associated with + +=item C<base> - superclass for the action class created + +=item C<attributes> - a list of the names of attributes to mirror from the submodel. +A blank list signifies nothing, and a non list value will cause it to reflect all +writeable parameter attributes from the submodel. + +=item C<name> - the name of the action, required. + +=item C<class> - optional, the name of the action class. By default it will query the +submodel class through the method C<_default_action_class_for> + +=back + +Create an action class that acts on the submodel from a base class. This is most useful +for CRUD and similar actions. + +=head2 parameters_for_submodel_action_attribute \ %args + +=over 4 + +=item C<attribute_name> - name of the attribute being reflected + +=item C<submodel_class> - the submodel where this attribute is located + +=back + +Create the correct parameters for the attribute being created in the action, including +valid_values, and correct handling of relationships and defaults. + +=head1 PRIVATE METHODS + +=head2 BUILD + +Load the C<model_class> if it exists or create one if it does not. + +=head1 TODO + +Allow reflect_* and exclude_* methods to take compiled regular expressions, tidy up +argument names and method names, mace docs decent, make more tests, try to figure out +more through introspection to require less arguments, proper checking of values passed +and throwing of errors when garbage is passed in. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual.pod b/lib/Reaction/Manual.pod new file mode 100644 index 0000000..ab366cc --- /dev/null +++ b/lib/Reaction/Manual.pod @@ -0,0 +1,47 @@ +=head1 NAME + +Reaction::Manual - The Index of The Manual + +=head1 DESCRIPTON + +Reaction is basically an extended MVC framework built upon L<Catalyst>. + +=head1 SECTIONS + +=head2 L<Reaction::Manual::Intro> + +=head2 L<Reaction::Manual::Example> + +=head2 L<Reaction::Manual::Cookbook> + +=head2 L<Reaction::Manual::Internals> + +=head2 L<Reaction::Manual::FAQ> + +=head1 SEE ALSO + +=over + +=item * L<Catalyst::Manual> + +=item * L<DBIx::Class::Manual> + +=item * L<Moose> + +=item * L<Template::Toolkit> + +=back + +=head1 SUPPORT + +IRC: Join #reaction on irc.perl.org + +=head1 AUTHORS + +See L<Reaction::Class> for authors for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual/Cookbook.pod b/lib/Reaction/Manual/Cookbook.pod new file mode 100644 index 0000000..e04c6ee --- /dev/null +++ b/lib/Reaction/Manual/Cookbook.pod @@ -0,0 +1,74 @@ +=head1 NAME + +Reaction::Manual::Cookbook - Miscellaneous recipes + +=head1 RECIPES + +These should include some hopefully useful tips and tricks! + +=head2 Display + +These would typically go in your /root directory along with your other +templates. + +=head3 Alternating listview row styles with CSS + +Filename: listview + + [% + + PROCESS base/listview; + + row_block = 'listview_row_fancy'; + + BLOCK listview_row_fancy; + + IF loop.count % 2 == 1; + attrs.class = 'dark'; + ELSE; + attrs.class = 'light'; + END; + + INCLUDE listview_row; + + END; + + %] + +=head3 Displaying heading on action forms + +Filename: form_base + + [% + + PROCESS base/form_base; + + main_block = 'form_base_control_fancy'; + + BLOCK form_base_control_fancy; + + action_class = self.action.meta.name.split('::').pop; + '<h3>'; action_class.split('(?=[A-Z])').join(' '); '</h3>'; + INCLUDE form_base_control; + + END; + + %] + +=head2 Controllers + +Things + +=head2 Models + +Stuff + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual/Example.pod b/lib/Reaction/Manual/Example.pod new file mode 100644 index 0000000..02a55fe --- /dev/null +++ b/lib/Reaction/Manual/Example.pod @@ -0,0 +1,304 @@ +=head1 NAME + +Reaction::Manual::Example - Simple Reaction example + +=head1 DESCRIPTION + +This tutorial will guide you through the process of setting up and testing a +very basic CRUD application based on the database from +L<DBIx::Class::Manual::Example>. + +You need at least a fairly basic understanding of L<DBIx::Class::Schema> for +this example to have value for you. + +=head2 Installation + +Install L<DBIx::Class> via CPAN. + +Install Reaction from http://code2.0beta.co.uk/reaction/svn via SVN or SVK. + +Set up the database as mentioned in L<DBIx::Class::Manual::Example>. Don't do +any of the DBIx::Class related stuff, only the SQLite database. + +=head2 Create the application + + catalyst.pl Test::Reaction + cd Test-Reaction + script/test_reaction_create.pl Model Test::Reaction DBIC::Schema Test::Reaction::DB + +Also, remember to include Catalyst::Plugin::I18N in your plugin list, like +this: + + use Catalyst qw/-Debug ConfigLoader Static::Simple I18N/; + +=head2 Set up DBIx::Class::Schema + +In addition to the normal DBIC stuff, you need to moosify your DBIC classes. + +Change directory back from db to the directory app: + + cd lib/Test/Reaction + mkdir DB + +Then, create the following DBIx::Class::Schema classes: + +DB.pm: + + package Test::Reaction::DB; + + use base 'DBIx::Class::Schema'; + + __PACKAGE__->load_classes; + + 1; + +DB/Artist.pm: + + package Test::Reaction::DB::Artist; + + use base 'DBIx::Class'; + use Reaction::Class; + + has 'artistid' => ( isa => 'Int', is => 'ro', required => 1 ); + has 'name' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 ); + + sub display_name { + my $self = shift; + return $self->name; + } + + __PACKAGE__->load_components(qw/PK::Auto Core/); + __PACKAGE__->table('artist'); + __PACKAGE__->add_columns(qw/ artistid name /); + __PACKAGE__->set_primary_key('artistid'); + __PACKAGE__->has_many( 'cds' => 'Test::Reaction::DB::Cd' ); + + 1; + +DB/Cd.pm: + + package Test::Reaction::DB::Cd; + + use base 'DBIx::Class'; + use Reaction::Class; + + has 'cdid' => ( isa => 'Int', is => 'ro', required => 1 ); + has 'artist' => + ( isa => 'Test::Reaction::DB::Artist', is => 'rw', required => 1 ); + has 'title' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 ); + + sub display_name { + my $self = shift; + return $self->title; + } + + __PACKAGE__->load_components(qw/PK::Auto Core/); + __PACKAGE__->table('cd'); + __PACKAGE__->add_columns(qw/ cdid artist title/); + __PACKAGE__->set_primary_key('cdid'); + __PACKAGE__->belongs_to( 'artist' => 'Test::Reaction::DB::Artist' ); + __PACKAGE__->has_many( 'tracks' => 'Test::Reaction::DB::Track' ); + + 1; + +DB/Track.pm: + + package Test::Reaction::DB::Track; + + use base 'DBIx::Class'; + use Reaction::Class; + + has 'trackid' => ( isa => 'Int', is => 'ro', required => 1 ); + has 'cd' => ( isa => 'Test::Reaction::DB::Cd', is => 'rw', required => 1 ); + has 'title' => ( isa => 'NonEmptySimpleStr', is => 'rw', required => 1 ); + + __PACKAGE__->load_components(qw/PK::Auto Core/); + __PACKAGE__->table('track'); + __PACKAGE__->add_columns(qw/ trackid cd title/); + __PACKAGE__->set_primary_key('trackid'); + __PACKAGE__->belongs_to( 'cd' => 'Test::Reaction::DB::Cd' ); + + 1; + +=head3 Reaction attributes + +See L<Reaction::Types::Core> + +=head3 The rest + +Reaction will use I<sub display_name> for displaying when there is a 1:Many or +Many:Many relation. It will return a suitable text representation. + +=head2 Models + +=head3 Create Test::Reaction::Model::Action + +Still in lib/Test/Reaction, create + +Model/Action.pm: + + package Test::Reaction::Model::Action; + + use Reaction::Class; + + use Test::Reaction::DB; + + use aliased 'Reaction::InterfaceModel::Action::DBIC::ActionReflector'; + + my $r = ActionReflector->new; + + $r->reflect_actions_for( 'Test::Reaction::DB::Artist' => __PACKAGE__ ); + $r->reflect_actions_for( 'Test::Reaction::DB::Cd' => __PACKAGE__ ); + $r->reflect_actions_for( 'Test::Reaction::DB::Track' => __PACKAGE__ ); + + 1; + +=head2 Controllers + +Reaction controllers inherit from Reaction::UI::CRUDController, like this: + +Controller/Artist.pm + + package Test::Reaction::Controller::Artist; + + use strict; + use warnings; + use base 'Reaction::UI::CRUDController'; + use Reaction::Class; + + __PACKAGE__->config( + model_base => 'Test::Reaction', + model_name => 'Artist', + action => { base => { Chained => '/base', PathPart => 'artist' } } + ); + + 1; + +Controller/Cd.pm + + package Test::Reaction::Controller::Cd; + + use strict; + use warnings; + use base 'Reaction::UI::CRUDController'; + use Reaction::Class; + + __PACKAGE__->config( + model_base => 'Test::Reaction', + model_name => 'Cd', + action => { base => { Chained => '/base', PathPart => 'cd' } } + ); + + 1; + +Controller/Track.pm + + package Test::Reaction::Controller::Track; + + use strict; + use warnings; + use base 'Reaction::UI::CRUDController'; + use Reaction::Class; + + __PACKAGE__->config( + model_base => 'Test::Reaction', + model_name => 'Track', + action => { base => { Chained => '/base', PathPart => 'track' } } + ); + + 1; + +Finally, change Controller/Root.pm to + + package Test::Reaction::Controller::Root; + + use strict; + use warnings; + use base 'Reaction::UI::RootController'; + use Reaction::Class; + + use aliased 'Reaction::UI::ViewPort'; + use aliased 'Reaction::UI::ViewPort::ListView'; + use aliased 'Reaction::UI::ViewPort::ActionForm'; + + __PACKAGE__->config->{namespace} = ''; + + sub base :Chained('/') :PathPart('') :CaptureArgs(0) { + my ($self, $c) = @_; + + $self->push_viewport(ViewPort, layout => 'xhtml'); + } + + sub root :Chained('base') :PathPart('') :Args(0) { + my ($self, $c) = @_; + + $self->push_viewport(ViewPort, layout => 'index'); + } + + 1; + +=head2 View + +View/XHTML.pm looks like this + + package Test::Reaction::View::XHTML; + + use Reaction::Class; + + extends 'Reaction::UI::Renderer::XHTML'; + + 1; + +This is all the perly stuff. Now return to the base Test-Reaction directory and +create root/index: + + [% + + main_block = 'index'; + + BLOCK index; + + %]<p><a href="[% ctx.uri_for('/artist') %]">artist</a></p> + <p><a href="[% ctx.uri_for('/cd') %]">cd</a></p> + <p><a href="[% ctx.uri_for('/track') %]">track</a></p>[% + + END; + + %] + +=head2 Running + +Now all that remains is to tell catalyst about the root and the model. Let +test_reaction.yml look like this: + + --- + name: Test::Reaction + Controller::Root: + view_name: 'XHTML' + window_title: 'Reaction Test App' + Model::Test::Reaction: + schema_class: 'Test::Reaction::DB' + connect_info: + - 'dbi:SQLite:dbname=database/example.db' + +The finals step for this example is to link to Reaction's templates: + + ln -s <path to reaction install directory>/root/base/ root/base + +At last you're now ready to run the server + + script/test_reaction_server.pl + +=head1 Notes + +=head1 TODO + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual/FAQ.pod b/lib/Reaction/Manual/FAQ.pod new file mode 100644 index 0000000..96f20fd --- /dev/null +++ b/lib/Reaction/Manual/FAQ.pod @@ -0,0 +1,101 @@ +=head1 NAME + +Reaction::Manual::FAQ + +=head2 INTRODUCTION + +=head3 What is Reaction? + +Reaction is an MVCish framework that is designed with two goals in mind: +"don't repeat yourself" and "components rule." + +=head3 How is it different from other MVC frameworks? + +Reaction is more flexible and abstract. Web development is only a specialized +set of what Reaction is designed to provide - the inner classes are general +enough to be used in many different environments and for solving non-web +problems. + +It is planned to go a lot further than just the web - we want to develop GUIs +and CLIs as easily and painlessly as possible, using Reaction. How about +writing your web application and instantly getting a CLI to go with it? That's +only part of the flexibility we have in mind. + +=head3 How is it different from Catalyst? + +Catalyst is MVC-based whereas Reaction splits the Model into 2 parts: The +"Domain Model" and the "Interface Model." Web development is only a sample of +what Reaction can do - but it already comes bundled with the basic components +that you would have to program in Catalyst. At the moment, Reaction runs on +Catalyst for web development. + +=head3 What's a Domain? + +A domain is the field where an abstraction makes sense. For example, to build +a web site a programmer may come up with an abstraction of a User, Products, +User roles, etc. These concepts are just one particular implementation of all +the possible abstractions for that web site -- the set of all these possible +abstractions make up the Domain. + +=head3 What's a Domain Model? + +A Domain Model is an actual computational model of an abstraction. In most +cases these models are business-based, as in the set of objects that make up +the representation for a particular domain, such as Users, Products, User +Roles, etc. + +=head3 What's an Interface Model? + +A well defined model for the common operations involved in a particular mode +of interaction with the domain. In other words, it's a layer around the Domain +Model that provides interaction with it. One example would be an authorization +procedure for different views of the same data, based on user's credentials. + +=head3 I'm lost! What does "Model" mean? + +The term "model" can mean two things: "model as in Computer Model" and "Model +as in MVC". For this document, the former will be written as just "Model" +whereas the latter will be referred to as "Model as in MVC." + +=head3 Haven't I seen these definitions elsewhere? +Yes, similar terms have been used in Java-land and Smalltalk-ville. Note that +for the sake of simplicity we are not giving rigorous (and more complex) +definitions. + +=head3 What's a View? + +=head3 What's a Viewport? + +ListView and ActionForm are subclasses of ViewPort. + +=head3 What's a Focus Stack? + +=head3 What are Tangents? + +=head3 Can I have a pony? + +=head2 USING REACTION + +=head3 Where do I put my HTML? + +Packages involved + ComponentUI + ComponentUI::Controller::Bar + ComponentUI::Controller::Baz + ComponentUI::Controller::Foo + ComponentUI::Controller::Root + ComponentUI::Model::TestDB + ComponentUI::Model::Action + ComponentUI::View::XHTML + +CRUD + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual/Internals.pod b/lib/Reaction/Manual/Internals.pod new file mode 100644 index 0000000..720608c --- /dev/null +++ b/lib/Reaction/Manual/Internals.pod @@ -0,0 +1,270 @@ +=head1 NAME + +Reaction::Manual::Internals + +=head2 Hacking on Reaction + +=head3 What is a component? + +=head3 What component types are there? + +=head3 How do I create a new component? + +=head3 How does it work with a database? + +=head3 What about Moose? + +L<Moose> + +=head3 Type system + +=head3 What Perl modules should I be familiar with, in order to hack on Reaction's +internals? + +=over + +=item L<Moose> + +A complete modern object system for Perl 5. + +=item L<aliased> + +Use shorter package names, i.e., "X::Y::Z" as "Z". + +=item L<Catalyst> + +The MVC application framework Reaction uses. + +=over + +=item * L<Catalyst::Controller::BindLex> + +=item * L<Catalyst::Model::DBIC::Schema> + +=item * L<Catalyst::Plugin::ConfigLoader> + +=item * L<Catalyst::Plugin::I18N> + +=item * L<Catalyst::Plugin::Static::Simple> + +=item * L<Catalyst::View::TT> + +=back + +=item TT + +Template Toolkit + +=item L<Config::General> + +Generic config file module. + +=item L<DBIx::Class> + +Object/Relational mapper. + +=item L<DateTime> + +=item L<DateTime::Format::MySQL> + +=item L<Digest::MD5> + +=item L<Email::MIME> + +=item L<Email::MIME::Creator> + +=item L<Email::Send> + +=item L<Email::Valid> + +=item L<SQL::Translator> + +=item L<Test::Class> + +=item L<Test::Memory::Cycle> + +=item L<Time::ParseDate> + +=back + +=head3 Packages involved + +=over + +=item L<Reaction::Class> + +Utility class, sets up to export a few methods that return parameters for use +within Moose's C<has> (as new parameters) in other packages. It also C<use>s +Moose itself. + +The methods it injects are: + +=over + +=item set_or_lazy_build($field_name) + +The attribute is required, if not provided beforehand the build_${name} method +will be called on the object when the attribute's getter is first called. If +the method does not exist, or returns undef, an error will be thrown. + +=item set_or_lazy_fail() + +The attribute is required, if not provided beforehand the 'lazy' parameter of +Moose will make it fail. + +=item trigger_adopt() + +Calls adopt_${type} after the attribute value is set to $type. + +=item register_inc_entry() + +Will mark the calling package as already included, using %INC. + +=back + +=item Reaction::InterfaceModel::Action + +=item Reaction::InterfaceModel::Action::DBIC::ResultSet::Create; + +=item Reaction::InterfaceModel::Action::DBIC::ActionReflector; + +A method "adaptor" that creates the needed objects to support CRUD DBIC +actions. In the future the code could be moved to a class higher in the +hierarchy and only contain the operations to adapt. + +Sample run: + +Reaction::InterfaceModel::Action::DBIC::ActionReflector->reflect_actions_for( +Reaction::InterfaceModel::Action::DBIC::ActionReflector=HASH(0x93cb2f0) +RTest::TestDB::Foo +ComponentUI::Model::Action +) + +Generates and evaluates: + +package ComponentUI::Model::Action::DeleteFoo; +use Reaction::Class; +extends 'Reaction::InterfaceModel::Action::DBIC::Result::Delete'; +package ComponentUI::Model::Action::UpdateFoo; +use Reaction::Class; +extends 'Reaction::InterfaceModel::Action::DBIC::Result::Update'; +has 'baz_list' => (isa => 'ArrayRef', is => 'rw', set_or_lazy_fail('baz_list'), default => sub { [] }, valid_values => sub { +$_[0]->target_model +->result_source +->related_source('links_to_baz_list') +->related_source('baz') +->resultset; +}); +has 'last_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('last_name')); +has 'first_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('first_name')); +package ComponentUI::Model::Action::CreateFoo; +use Reaction::Class; +extends 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create'; +has 'baz_list' => (isa => 'ArrayRef', is => 'rw', set_or_lazy_fail('baz_list'), default => sub { [] }, valid_values => sub { +$_[0]->target_model +->result_source +->related_source('links_to_baz_list') +->related_source('baz') +->resultset; +}); +has 'last_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('last_name')); +has 'first_name' => (isa => 'NonEmptySimpleStr', is => 'rw', set_or_lazy_fail('first_name')); + +=item Reaction::InterfaceModel::Action::DBIC::Result::Delete + +=item Reaction::InterfaceModel::Action::DBIC::Result::Update + +=item Reaction::InterfaceModel::Action::DBIC::User::ResetPassword + +=item Reaction::InterfaceModel::Action::DBIC::User::Role::SetPassword + +=item Reaction::InterfaceModel::Action::DBIC::User::ChangePassword + +=item Reaction::InterfaceModel::Action::User::ResetPassword + +=item Reaction::InterfaceModel::Action::User::ChangePassword + +=item Reaction::InterfaceModel::Action::User::SetPassword + +=item Reaction::Meta::InterfaceModel::Action::ParameterAttribute + +=item Reaction::Meta::InterfaceModel::Action::Class + +=item Reaction::Types::Email + +=item Reaction::Types::Core + +=item Reaction::Types::DateTime + +=item Reaction::Types::File + +=item Reaction::Types::DBIC + +=item Reaction::UI::ViewPort::ListView + +=item Reaction::UI::ViewPort::Field::Text + +=item Reaction::UI::ViewPort::Field::ChooseMany + +=item Reaction::UI::ViewPort::Field::String + +=item Reaction::UI::ViewPort::Field::Number + +=item Reaction::UI::ViewPort::Field::HiddenArray + +=item Reaction::UI::ViewPort::Field::DateTime + +=item Reaction::UI::ViewPort::Field::File + +=item Reaction::UI::ViewPort::Field::ChooseOne + +=item Reaction::UI::ViewPort::Field::Password + +=item Reaction::UI::ViewPort::ActionForm + +=item Reaction::UI::ViewPort::Field + +=item Reaction::UI::FocusStack + +=item Reaction::UI::RootController + +=item Reaction::UI::Window + +=item Reaction::UI::Renderer::XHTML + +=item Reaction::UI::ViewPort + +=item Reaction::UI::CRUDController + +=item Reaction::UI::Controller + +=back + +=head3 Remarks about POD + +Don't use C<=over N>. POD assumes that the indent level is 4 if you leave +it out. Most POD renderers ignore your indent level anyway. + +=head2 UNSORTED + +Packages involved + +t/lib/Rtest/TestDB*: TestDB DBIC declarations. +t/lib/RTest/TestDB.pm: does DBIC populate for t/. +t/lib/RTest/UI/ XXX + +Reaction::Test::WithDB; +Reaction::Test; +Reaction::Test::Mock::Context; +Reaction::Test::Mock::Request; +Reaction::Test::Mock::Response; + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Manual/Intro.pod b/lib/Reaction/Manual/Intro.pod new file mode 100644 index 0000000..73d3846 --- /dev/null +++ b/lib/Reaction/Manual/Intro.pod @@ -0,0 +1,62 @@ +=head1 NAME + +Reaction::Manual::Intro - Introduction to Reaction + +=head1 INTRODUCTION + +Reaction is basically an extended MVC: + +=over + +=item Domain Model + +DBIC schema, etc. + +=item Interface Model + +Model::DBIC::Schema and Action classes. + +=item Controller + +Mediation and navigation. + +=item ViewPort + +View logic and event handling encapsulation. + +=item Renderer + +View:: classes, handed viewports. + +=back + +=head1 THE REACTION WAY + +The idea is you separate your domain model, which encapsulates the domain +itself from your interface model, which is a model of how a particular app or +class of apps interact with that domain and provides objects/methods to +encapsulate the common operations it does. + +=head2 Basic usage + +XXX TODO + +=head1 SEE ALSO + +=over + +=item * L<Reaction::Manual::Cookbook> + +=item * L<Reaction::Manual::FAQ> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Meta/Attribute.pm b/lib/Reaction/Meta/Attribute.pm new file mode 100644 index 0000000..38035d5 --- /dev/null +++ b/lib/Reaction/Meta/Attribute.pm @@ -0,0 +1,101 @@ +package Reaction::Meta::Attribute; + +use Moose; + +extends 'Moose::Meta::Attribute'; + +#is => 'Bool' ? or leave it open +has lazy_fail => + (is => 'ro', reader => 'is_lazy_fail', required => 1, default => 0); +has lazy_build => + (is => 'ro', reader => 'is_lazy_build', required => 1, default => 0); + +around _process_options => sub { + my $super = shift; + my ($class, $name, $options) = @_; + + my $fail = $options->{lazy_fail}; #will this autovivify? + my $build = $options->{lazy_build}; + + if ( $fail || $build) { + confess("You may not use both lazy_build and lazy_fail for one attribute") + if $fail && $build; + confess("You may not supply a default value when using lazy_build or lazy_fail") + if exists $options->{default}; + + $options->{lazy} = 1; + $options->{required} = 1; + + my $builder = ($name =~ /^_/) ? "_build${name}" : "build_${name}"; + $options->{default} = $fail ? + sub { confess "${name} must be provided before calling reader" } : + sub{ shift->$builder }; + } + + #we are using this everywhere so might as well move it here. + $options->{predicate} ||= ($name =~ /^_/) ? "_has${name}" : "has_${name}" + if !$options->{required} || $options->{lazy}; + + + $super->($class, $name, $options); +}; + +1; + +__END__; + +=head1 NAME + +Reaction::Meta::Attribute + +=head1 SYNOPSIS + + has description => (is => 'rw', isa => 'Str', lazy_fail => 1); + + # OR + has description => (is => 'rw', isa => 'Str', lazy_build => 1); + sub build_description{ "My Description" } + + # OR + has _description => (is => 'rw', isa => 'Str', lazy_build => 1); + sub _build_description{ "My Description" } + +=head1 Method-naming conventions + +Reaction::Meta::Attribute will never override the values you set for method names, +but if you do not it will follow these basic rules: + +Attributes with a name that starts with an underscore will default to using +builder and predicate method names in the form of the attribute name preceeded by +either "_has" or "_build". Otherwise the method names will be in the form of the +attribute names preceeded by "has_" or "build_". e.g. + + #auto generates "_has_description" and expects "_build_description" + has _description => (is => 'rw', isa => 'Str', lazy_build => 1); + + #auto generates "has_description" and expects "build_description" + has description => (is => 'rw', isa => 'Str', lazy_build => 1); + +=head2 Predicate generation + +All non-required or lazy attributes will have a predicate automatically +generated for them if one is not already specified. + +=head2 lazy_fail + +=head2 lazy_build + +lazy_build will lazily build to the return value of a user-supplied builder sub + The builder sub will recieve C<$self> as the first argument. + +lazy_fail will simply fail if it is called without first having set the value. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Meta/Class.pm b/lib/Reaction/Meta/Class.pm new file mode 100644 index 0000000..e963586 --- /dev/null +++ b/lib/Reaction/Meta/Class.pm @@ -0,0 +1,15 @@ +package Reaction::Meta::Class; + +use Moose; +use Reaction::Meta::Attribute; + +extends 'Moose::Meta::Class'; + +around initialize => sub { + my $super = shift; + my $class = shift; + my $pkg = shift; + $super->($class, $pkg, 'attribute_metaclass' => 'Reaction::Meta::Attribute', @_ ); +}; + +1; diff --git a/lib/Reaction/Meta/InterfaceModel/Action/Class.pm b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm new file mode 100644 index 0000000..0c83353 --- /dev/null +++ b/lib/Reaction/Meta/InterfaceModel/Action/Class.pm @@ -0,0 +1,41 @@ +package Reaction::Meta::InterfaceModel::Action::Class; + +use Reaction::Class; +use aliased 'Reaction::Meta::InterfaceModel::Action::ParameterAttribute'; + +class Class is 'Reaction::Meta::Class', which { + + around initialize => sub { + my $super = shift; + my $class = shift; + my $pkg = shift; + $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); + }; + + implements parameter_attributes => as { + my $self = shift; + return grep { $_->isa(ParameterAttribute) } + $self->compute_all_applicable_attributes; + }; + +}; + +1; + +=head1 NAME + +Reaction::Meta::InterfaceModel::Action::Class + +=head1 DESCRIPTION + +=head2 parameter_attributes + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm new file mode 100644 index 0000000..8a52409 --- /dev/null +++ b/lib/Reaction/Meta/InterfaceModel/Action/ParameterAttribute.pm @@ -0,0 +1,102 @@ +package Reaction::Meta::InterfaceModel::Action::ParameterAttribute; + +use Reaction::Class; +use Scalar::Util 'blessed'; + +class ParameterAttribute is 'Reaction::Meta::Attribute', which { + has valid_values => ( + isa => 'CodeRef', + is => 'rw', # hack since clone_and_inherit hates me. + predicate => 'has_valid_values' + ); + + implements new => as { shift->SUPER::new(@_); }; # work around immutable + + implements check_valid_value => as { + my ($self, $object, $value) = @_; + confess "Can't check_valid_value when no valid_values set" + unless $self->has_valid_values; + my $valid = $self->valid_values->($object, $self); + if ($self->type_constraint + && ($self->type_constraint->name eq 'ArrayRef' + || $self->type_constraint->is_subtype_of('ArrayRef'))) { + confess "Parameter type is array ref but passed value isn't" + unless ref($value) eq 'ARRAY'; + return [ map { $self->_check_single_valid($valid => $_) } @$value ]; + } else { + return $self->_check_single_valid($valid => $value); + } + }; + + implements _check_single_valid => as { + my ($self, $valid, $value) = @_; + if (ref $valid eq 'ARRAY') { + return $value if grep { $_ eq $value } @$valid; + } else { + $value = $value->ident_condition if blessed($value); + return $valid->find($value); + } + return undef; # XXX this is an assumption that undef is never valid + }; + + implements all_valid_values => as { + my ($self, $object) = @_; + confess "Can't call all_valid_values on an attribute without valid_values" + unless $self->has_valid_values; + my $valid = $self->valid_values->($object, $self); + return ((ref $valid eq 'ARRAY') + ? @$valid + : $valid->all); + }; + + implements valid_value_collection => as { + my ($self, $object) = @_; + confess "Can't call valid_value_collection on an attribute without valid_values" + unless $self->has_valid_values; + my $valid = $self->valid_values->($object, $self); + confess "valid_values returned an arrayref, not a collection" + if (ref $valid eq 'ARRAY'); + return $valid; + }; + +}; + +1; + +=head1 NAME + +Reaction::Meta::InterfaceModel::Action::ParamterAttribute + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 new + +=head2 valid_values + +=head2 has_valid_values + +=head2 check_valid_value + +=head2 all_valid_values + +=head2 valid_value_collection + +=head2 reader + +=head2 writer + +=head1 SEE ALSO + +L<Reaction::Meta::Attribute> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Meta/InterfaceModel/Object/Class.pm b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm new file mode 100644 index 0000000..77fbbe4 --- /dev/null +++ b/lib/Reaction/Meta/InterfaceModel/Object/Class.pm @@ -0,0 +1,60 @@ +package Reaction::Meta::InterfaceModel::Object::Class; + +use aliased 'Reaction::Meta::InterfaceModel::Object::ParameterAttribute'; +use aliased 'Reaction::Meta::InterfaceModel::Object::DomainModelAttribute'; + +use Reaction::Class; + +class Class is 'Reaction::Meta::Class', which { + + around initialize => sub { + my $super = shift; + my $class = shift; + my $pkg = shift; + $super->($class, $pkg, attribute_metaclass => ParameterAttribute, @_); + }; + + implements add_domain_model => as{ + my $self = shift; + $self->add_attribute( DomainModelAttribute->new(@_) ); + }; + + implements parameter_attributes => as { + my $self = shift; + return grep { $_->isa(ParameterAttribute) } + $self->compute_all_applicable_attributes; + }; + + implements domain_models => as { + my $self = shift; + return grep { $_->isa(DomainModelAttribute) } + $self->compute_all_applicable_attributes; + }; + +}; + +1; + +=head1 NAME + +Reaction::Meta::InterfaceModel::Object::Class + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 add_domain_model + +=head2 domain_models + +=head2 parameter_attributes + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm new file mode 100644 index 0000000..ba1e9cc --- /dev/null +++ b/lib/Reaction/Meta/InterfaceModel/Object/DomainModelAttribute.pm @@ -0,0 +1,28 @@ +package Reaction::Meta::InterfaceModel::Object::DomainModelAttribute; + +use Reaction::Class; + +class DomainModelAttribute is 'Reaction::Meta::Attribute', which { + #i feel like something should happen here, but i aint got nothin. + + implements new => as { shift->SUPER::new(@_); }; # work around immutable + +}; + +1; + +=head1 NAME + +Reaction::Meta::InterfaceModel::Action::DomainModelAttribute + +=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/Meta/InterfaceModel/Object/ParameterAttribute.pm b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm new file mode 100644 index 0000000..835fa09 --- /dev/null +++ b/lib/Reaction/Meta/InterfaceModel/Object/ParameterAttribute.pm @@ -0,0 +1,43 @@ +package Reaction::Meta::InterfaceModel::Object::ParameterAttribute; + +use Reaction::Class; + +class ParameterAttribute is 'Reaction::Meta::Attribute', which { + has domain_model => ( + isa => 'Str', + is => 'ro', + predicate => 'has_domain_model' + ); + + has orig_attr_name => ( + isa => 'Str', + is => 'ro', + predicate => 'has_orig_attr_name' + ); + + implements new => as { shift->SUPER::new(@_); }; # work around immutable +}; + +1; + +=head1 NAME + +Reaction::Meta::InterfaceModel::Object::ParameterAttribute + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +=head2 domain_model + +=head2 orig_attr_name + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Object.pm b/lib/Reaction/Object.pm new file mode 100644 index 0000000..7440bd3 --- /dev/null +++ b/lib/Reaction/Object.pm @@ -0,0 +1,28 @@ +package Reaction::Object; + +use Reaction::Meta::Class; +use metaclass 'Reaction::Meta::Class'; + +use Moose qw(extends); + +extends 'Moose::Object'; + +no Moose; + +1; + +=head1 NAME + +Reaction::Object + +=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/Role.pm b/lib/Reaction/Role.pm new file mode 100644 index 0000000..ea5b948 --- /dev/null +++ b/lib/Reaction/Role.pm @@ -0,0 +1,55 @@ +package Reaction::Role; + +use Moose::Role (); +use Reaction::ClassExporter; +use Reaction::Class; +use Moose::Meta::Class; +#TODO: review for Reaction::Object switch / Reaction::Meta::Class +*Moose::Meta::Role::add_method = sub { + Moose::Meta::Class->can("add_method")->(@_); +}; + +class Role which { + + override exports_for_package => sub { + my ($self, $package) = @_; + my %exports = $self->SUPER::exports_for_package($package); + delete $exports{class}; + $exports{role} = sub { $self->do_role_sub($package, @_); }; + return %exports; + }; + + override next_import_package => sub { 'Moose::Role' }; + + override default_base => sub { () }; + + implements do_role_sub => as { + my ($self, $package, $role, $which, $setup) = @_; + confess "Invalid role declaration, should be: role Role which { ... }" + unless ($which eq 'which' && ref($setup) eq 'CODE'); + $self->setup_and_cleanup($role, $setup); + }; + +}; + +1; + +=head1 NAME + +Reaction::Role + +=head1 DESCRIPTION + +=head1 SEE ALSO + +L<Moose::Role> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Test.pm b/lib/Reaction/Test.pm new file mode 100644 index 0000000..0d046c7 --- /dev/null +++ b/lib/Reaction/Test.pm @@ -0,0 +1,100 @@ +package Reaction::Test; + +use base qw/Test::Class Reaction::Object/; +use Reaction::Class; + +sub simple_mock_context { + my ($q_p, $b_p, $path) = ({}, {}, 'test/path'); + my $req = bless({ + query_parameters => sub { $q_p }, body_parameters => sub { $b_p }, + path => sub { shift; $path = shift if @_; $path; }, + }, 'Reaction::Test::Mock::Request'); + my %res_info = (content_type => '', body => '', status => 200, headers => {}); + my $res = bless({ + (map { + my $key = $_; + ($key => sub { shift; $res_info{$key} = shift if @_; $res_info{$key} }); + } keys %res_info), + header => sub { + shift; my $h = shift; + $res_info{headers}{$h} = shift if @_; + $res_info{headers}{$h}; + }, + }, 'Reaction::Test::Mock::Response'); + return bless({ + req => sub { $req }, res => sub { $res }, + }, 'Reaction::Test::Mock::Context'); +} + +=head1 NAME + +Reaction::Test + +=head1 DESCRIPTION + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut + + +package Reaction::Test::Mock::Context; + +sub isa { + shift; return 1 if (shift eq 'Catalyst'); +} + +sub view { + return $_[0]->{view}->(@_); +} + +sub req { + return $_[0]->{req}->(@_); +} + +sub res { + return $_[0]->{res}->(@_); +} + +package Reaction::Test::Mock::Request; + +sub query_parameters { + return $_[0]->{query_parameters}->(@_); +} + +sub body_parameters { + return $_[0]->{body_parameters}->(@_); +} + +sub path { + return $_[0]->{path}->(@_); +} + +package Reaction::Test::Mock::Response; + +sub body { + return $_[0]->{body}->(@_); +} + +sub content_type { + return $_[0]->{content_type}->(@_); +} + +sub status { + return $_[0]->{status}->(@_); +} + +sub headers { + return $_[0]->{headers}->(@_); +} + +sub header { + return $_[0]->{header}->(@_); +} + +1; diff --git a/lib/Reaction/Test/WithDB.pm b/lib/Reaction/Test/WithDB.pm new file mode 100644 index 0000000..465a4a0 --- /dev/null +++ b/lib/Reaction/Test/WithDB.pm @@ -0,0 +1,72 @@ +package Reaction::Test::WithDB; + +use base qw/Reaction::Test/; +use Reaction::Class; + +has 'schema' => ( + isa => 'DBIx::Class::Schema', is => 'rw', + set_or_lazy_build('schema') +); + +has 'schema_class' => ( + isa => 'Str', is => 'rw', set_or_lazy_fail('schema_class') +); + +has 'connect_info' => ( + isa => 'ArrayRef', is => 'rw', required => 1, lazy => 1, + default => sub { [ 'dbi:SQLite:t/var/reaction_test_withdb.db' ] }, +); + +override 'new' => sub { + my $self = super(); + $self->BUILDALL; + return $self; +}; + +sub BUILD { + my ($self) = @_; + my $schema = $self->schema_class->connect(@{$self->connect_info}); + $schema->deploy({ add_drop_table => 1 }); + $schema->setup_test_data if $schema->can('setup_test_data'); + $self->schema($schema); +} + +1; + +=head1 NAME + +Reaction::Test::WithDB + +=head1 DESCRIPTION + +=head2 new + +=head2 BUILD + +Deploys database schema, dropping tables if they already exist. + +=head1 ATTRIBUTES + +=head2 schema + +L<DBIx::Class::Schema> + +=head2 schema_class + +=head2 connect_info + +Uses C<[ dbi:SQLite:t/var/reaction_test_withdb.db ]> by default. + +=head1 SEE ALSO + +L<Reaction::Test> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Types/Core.pm b/lib/Reaction/Types/Core.pm new file mode 100644 index 0000000..cb904a3 --- /dev/null +++ b/lib/Reaction/Types/Core.pm @@ -0,0 +1,107 @@ +package Reaction::Types::Core; + +use Moose::Util::TypeConstraints; + +subtype 'SimpleStr' + => as 'Str' + => where { (length($_) <= 255) && ($_ !~ m/\n/) } + => message { "Must be a single line of no more than 255 chars" }; + +subtype 'NonEmptySimpleStr' + => as 'SimpleStr' + => where { length($_) > 0 } + => message { "Must be a non-empty single line of no more than 255 chars" }; + +# XXX duplicating constraint msges since moose only uses last message + +subtype 'Password' + => as 'NonEmptySimpleStr' + => where { length($_) > 3 } + => message { "Must be between 4 and 255 chars" }; + +subtype 'StrongPassword' + => as 'Password' + => where { (length($_) > 7) && (m/[^a-zA-Z]/) } + => message { "Must be between 8 and 255 chars, and contain a non-alpha char" }; + +subtype 'NonEmptyStr' + => as 'Str' + => where { length($_) > 0 } + => message { "Must not be empty" }; + +subtype 'PositiveNum' + => as 'Num' + => where { $_ >= 0 } + => message { "Must be a positive number" }; + +subtype 'PositiveInt' + => as 'Int' + => where { $_ >= 0 } + => message { "Must be a positive integer" }; + +subtype 'SingleDigit' + => as 'PositiveInt' + => where { $_ <= 9 } + => message { "Must be a single digit" }; + +1; + +=head1 NAME + +Reaction::Types::Core + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Reaction uses the L<Moose> attributes as a base and adds a few of it's own. + +=over + +=item * SimpleStr + +A Str with no new-line characters. + +=item * NonEmptySimpleStr + +Does what it says on the tin. + +=item * Password + +=item * StrongPassword + +=item * NonEmptyStr + +=item * PositiveNum + +=item * PositiveInt + +=item * SingleDigit + +=back + +=head1 SEE ALSO + +=over + +=item * L<Moose::Util::TypeConstraints> + +=item * L<Reaction::Types::DBIC> + +=item * L<Reaction::Types::DateTime> + +=item * L<Reaction::Types::Email> + +=item * L<Reaction::Types::File> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Types/DBIC.pm b/lib/Reaction/Types/DBIC.pm new file mode 100644 index 0000000..279e191 --- /dev/null +++ b/lib/Reaction/Types/DBIC.pm @@ -0,0 +1,50 @@ +package Reaction::Types::DBIC; + +use Moose::Util::TypeConstraints; + +use DBIx::Class::ResultSet; + +subtype 'DBIx::Class::ResultSet' + => as 'Object' + => where { $_->isa('DBIx::Class::ResultSet') }; + +use DBIx::Class::Core; +use DBIx::Class::Row; + +subtype 'DBIx::Class::Row' + => as 'Object' + => where { $_->isa('DBIx::Class::Row') }; + +1; + +=head1 NAME + +Reaction::Types::DBIC + +=head1 DESCRIPTION + +=over + +=item * DBIx::Class::ResultSet + +=item * DBIx::Class::Row + +=back + +=head1 SEE ALSO + +=over + +=item * L<Reaction::Types::Core> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Types/DateTime.pm b/lib/Reaction/Types/DateTime.pm new file mode 100644 index 0000000..60fbabd --- /dev/null +++ b/lib/Reaction/Types/DateTime.pm @@ -0,0 +1,55 @@ +package Reaction::Types::DateTime; + +use Moose::Util::TypeConstraints; + +use DateTime; + +subtype 'DateTime' + => as 'Object' + => where { $_->isa('DateTime') } + => message { "Must be of the form YYYY-MM-DD HH:MM:SS" }; + +use DateTime::SpanSet; + +subtype 'DateTime::SpanSet' + => as 'Object' + => where { $_->isa('DateTime::SpanSet') }; + +subtype 'TimeRangeCollection' + => as 'ArrayRef'; + +1; + +=head1 NAME + +Reaction::Types::DateTime + +=head1 DESCRIPTION + +=over + +=item * DateTime + +=item * DateTime::SpanSet + +=item * TimeRangeCollection + +=back + +=head1 SEE ALSO + +=over + +=item * L<Reaction::Types::Core> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Types/Email.pm b/lib/Reaction/Types/Email.pm new file mode 100644 index 0000000..0bf9adc --- /dev/null +++ b/lib/Reaction/Types/Email.pm @@ -0,0 +1,41 @@ +package Reaction::Types::Email; + +use Moose::Util::TypeConstraints; +use Email::Valid; + +subtype 'EmailAddress' + => as 'NonEmptySimpleStr' + => where { Email::Valid->address($_) } + => message { "Must be a valid e-mail address" }; + +1; + +=head1 NAME + +Reaction::Types::Email + +=head1 DESCRIPTION + +=over + +=item * EmailAddress + +=back + +=head1 SEE ALSO + +=over + +=item * L<Reaction::Types::Core> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/Types/File.pm b/lib/Reaction/Types/File.pm new file mode 100644 index 0000000..dc17e36 --- /dev/null +++ b/lib/Reaction/Types/File.pm @@ -0,0 +1,42 @@ +package Reaction::Types::File; + +use Moose::Util::TypeConstraints; + +use Catalyst::Request::Upload; + +subtype 'File' + => as 'Object' + => where { $_->isa('Catalyst::Request::Upload') } + => message { "Must be a file" }; + +1; + +=head1 NAME + +Reaction::Types::File + +=head1 DESCRIPTION + +=over + +=item * File + +=back + +=head1 SEE ALSO + +=over + +=item * L<Reaction::Types::Core> + +=back + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/CRUDController.pm b/lib/Reaction/UI/CRUDController.pm new file mode 100644 index 0000000..8841281 --- /dev/null +++ b/lib/Reaction/UI/CRUDController.pm @@ -0,0 +1,115 @@ +package Reaction::UI::CRUDController; + +use strict; +use warnings; +use base 'Reaction::UI::Controller'; +use Reaction::Class; + +use aliased 'Reaction::UI::ViewPort::ListView'; +use aliased 'Reaction::UI::ViewPort::ActionForm'; +use aliased 'Reaction::UI::ViewPort::ObjectView'; + +has 'model_base' => (isa => 'Str', is => 'rw', required => 1); +has 'model_name' => (isa => 'Str', is => 'rw', required => 1); + +has 'ActionForm_class' => (isa => 'Str', is => 'rw', required => 1, + lazy => 1, default => sub{ ActionForm }); +has 'ListView_class' => (isa => 'Str', is => 'rw', required => 1, + lazy => 1, default => sub{ ListView }); +has 'ObjectView_class' => (isa => 'Str', is => 'rw', required => 1, + lazy => 1, default => sub{ ObjectView }); + +sub base :Action :CaptureArgs(0) { + my ($self, $c) = @_; +} + +sub get_collection { + my ($self, $c) = @_; + return $c->model(join('::', $self->model_base, $self->model_name)); +} + +sub get_model_action { + my ($self, $c, $name, $target) = @_; + + if ($target->can('action_for')) { + return $target->action_for($name, ctx => $c); + } + + my $model_name = "Action::${name}".$self->model_name; + my $model = $c->model($model_name); + confess "no such Model $model_name" unless $model; + return $model->new(target_model => $target, ctx => $c); +} + +sub list :Chained('base') :PathPart('') :Args(0) { + my ($self, $c) = @_; + + $self->push_viewport( + $self->ListView_class, + collection => $self->get_collection($c) + ); +} + +sub create :Chained('base') :PathPart('create') :Args(0) { + my ($self, $c) = @_; + my $action = $self->get_model_action($c, 'Create', $self->get_collection($c)); + $self->push_viewport( + $self->ActionForm_class, + action => $action, + next_action => 'list', + on_apply_callback => sub { $self->after_create_callback($c => @_); }, + ); +} + +sub after_create_callback { + my ($self, $c, $vp, $result) = @_; + return $self->redirect_to( + $c, 'update', [ @{$c->req->captures}, $result->id ] + ); +} + +sub object :Chained('base') :PathPart('id') :CaptureArgs(1) { + my ($self, $c, $key) = @_; + my $object :Stashed = $self->get_collection($c) + ->find($key); + confess "Object? what object?" unless $object; # should be a 404. +} + +sub update :Chained('object') :Args(0) { + my ($self, $c) = @_; + my $object :Stashed; + my $action = $self->get_model_action($c, 'Update', $object); + my @cap = @{$c->req->captures}; + pop(@cap); # object id + $self->push_viewport( + $self->ActionForm_class, + action => $action, + next_action => [ $self, 'redirect_to', 'list', \@cap ] + ); +} + +sub delete :Chained('object') :Args(0) { + my ($self, $c) = @_; + my $object :Stashed; + my $action = $self->get_model_action($c, 'Delete', $object); + my @cap = @{$c->req->captures}; + pop(@cap); # object id + $self->push_viewport( + $self->ActionForm_class, + action => $action, + next_action => [ $self, 'redirect_to', 'list', \@cap ] + ); +} + +sub view :Chained('object') :Args(0) { + my ($self, $c) = @_; + my $object :Stashed; + my @cap = @{$c->req->captures}; + pop(@cap); # object id + $self->push_viewport( + $self->ObjectView_class, + object => $object + ); +} + +1; diff --git a/lib/Reaction/UI/Controller.pm b/lib/Reaction/UI/Controller.pm new file mode 100644 index 0000000..e0e1423 --- /dev/null +++ b/lib/Reaction/UI/Controller.pm @@ -0,0 +1,73 @@ +package Reaction::UI::Controller; + +use base qw/Catalyst::Controller::BindLex Reaction::Object/; +use Reaction::Class; + +sub push_viewport { + my $self = shift; + my $focus_stack :Stashed; + my ($class, @proto_args) = @_; + my %args; + my $c = Catalyst::Controller::BindLex::_get_c_obj(4); + if (my $vp_attr = $c->stack->[-1]->attributes->{ViewPort}) { + if (ref($vp_attr) eq 'ARRAY') { + $vp_attr = $vp_attr->[0]; + } + if (ref($vp_attr) eq 'HASH') { + if (my $conf_class = delete $vp_attr->{class}) { + $class = $conf_class; + } + %args = (%$vp_attr, @proto_args); + } else { + $class = $vp_attr; + %args = @proto_args; + } + } else { + %args = @proto_args; + } + + $args{ctx} = $c; + + if (exists $args{next_action} && !ref($args{next_action})) { + $args{next_action} = [ $self, 'redirect_to', $args{next_action} ]; + } + $focus_stack->push_viewport($class, %args); +} + +sub pop_viewport { + my $focus_stack :Stashed; + return $focus_stack->pop_viewport; +} + +sub pop_viewports_to { + my ($self, $vp) = @_; + my $focus_stack :Stashed; + return $focus_stack->pop_viewports_to($vp); +} + +sub redirect_to { + my ($self, $c, $to, $cap, $args, $attrs) = @_; + + #the confess calls could be changed later to $c->log ? + my $action; + if(!ref $to){ + $action = $self->action_for($to); + confess("Failed to locate action ${to} in " . $self->blessed) unless $action; + } + elsif( blessed $to && $to->isa('Catalyst::Action') ){ + $action = $to; + } elsif(ref $action eq 'ARRAY' && @$action == 2){ #is that overkill / too strict? + $action = $c->controller($to->[0])->action_for($to->[1]); + confess("Failed to locate action $to->[1] in $to->[0]" ) unless $action; + } else{ + confess("Failed to locate action from ${to}"); + } + + $cap ||= $c->req->captures; + $args ||= $c->req->args; + $attrs ||= {}; + my $uri = $c->uri_for($action, $cap, @$args, $attrs); + $c->res->redirect($uri); +} + +1; diff --git a/lib/Reaction/UI/FocusStack.pm b/lib/Reaction/UI/FocusStack.pm new file mode 100644 index 0000000..5a458fa --- /dev/null +++ b/lib/Reaction/UI/FocusStack.pm @@ -0,0 +1,241 @@ +package Reaction::UI::FocusStack; + +use Reaction::Class; + +class FocusStack which { + + has vp_head => (isa => 'Reaction::UI::ViewPort', is => 'rw'); + has vp_tail => (isa => 'Reaction::UI::ViewPort', is => 'rw'); + has vp_count => ( + isa => 'Int', is => 'rw', required => 1, default => sub { 0 } + ); + has loc_prefix => (isa => 'Str', is => 'rw', predicate => 'has_loc_prefix'); + + implements push_viewport => as { + my ($self, $class, %create) = @_; + my $tail = $self->vp_tail; + my $loc = $self->vp_count; + if ($self->has_loc_prefix) { + $loc = join('.', $self->loc_prefix, $loc); + } + my $vp = $class->new( + %create, + location => $loc, + focus_stack => $self, + (defined $tail ? ( outer => $tail ) : ()), # XXX possibly a bug in + #immutable? + ); + if ($tail) { # if we already have a tail (non-empty vp stack) + $tail->inner($vp); # set the current tail's inner vp to the new vp + } else { # else we're currently an empty stack + $self->vp_head($vp); # so set the head to the new vp + } + $self->vp_count($self->vp_count + 1); + $self->vp_tail($vp); + return $vp; + }; + + implements pop_viewport => as { + my ($self) = @_; + my $head = $self->vp_head; + confess "Can't pop from empty focus stack" unless defined($head); + my $vp = $self->vp_tail; + if ($vp eq $head) { + $self->vp_head(undef); + } + $self->vp_tail($vp->outer); + $self->vp_count($self->vp_count - 1); + return $vp; + }; + + implements pop_viewports_to => as { + my ($self, $vp) = @_; + 1 while ($self->pop_viewport ne $vp); + return $vp; + }; + + implements apply_events => as { + my $self = shift; + my $vp = $self->vp_tail; + while (defined $vp) { + $vp->apply_events(@_); + $vp = $vp->outer; + } + }; + + +}; + +1; + +=head1 NAME + +Reaction::UI::FocusStack - A linked list of ViewPort-based objects + +=head1 SYNOPSIS + + my $stack = Reaction::UI::FocusStack->new(); + + # Or more commonly, in a Reaction::UI::RootController based + # Catalyst Controller: + my $stack = $ctx->focus_stack; + + # Add a new basic viewport inside the last viewport on the stack: + my $vp = $stack->push_viewport('Reaction::UI::ViewPort' => + layout => 'xhtml' + ); + + # Fetch the innermost viewport from the stack: + my $vp = $stack->pop_viewport(); + + # Remove all viewports inside a given viewport: + $stack->pop_viewports_to($vp); + + # Create a named stack as a tangent to an existing viewport: + my $newstack = $vp->create_tangent('somename'); + + # Resolve current events using your stack: + # This is called by Reaction::UI::RootController in the end action. + $stack->apply_events($ctx, $param_hash); + +=head1 DESCRIPTION + +A FocusStack represents a list of related L<ViewPort|Reaction::UI::ViewPort> +objects. The L<Reaction::UI::RootController> creates an empty stack for you in +it's begin action, which represents the main thread/container of the page. +Typically you add new ViewPorts to this stack as the main parts of your page. +To add multiple parallel page subparts, create a tangent from the outer +viewport, and add more viewports as normal. + +=head1 METHODS + +=head2 new + +=over + +=item Arguments: none + +=back + +Create a new empty FocusStack. This is done for you in +L<Reaction::UI::RootController>. + +=head2 push_viewport + +=over + +=item Arguments: $class, %options + +=back + +Creates a new L<Reaction::UI::ViewPort> based object and adds it to the stack. + +The following attributes of the new ViewPort are set: + +=over + +=item outer + +Is set to the preceding ViewPort in the stack. + +=item focus_stack + +Is set to the FocusStack object that created the ViewPort. + +=item location + +Is set to the location of the ViewPort in the stack. + +=back + +=head2 pop_viewport + +=over + +=item Arguments: none + +=back + +Removes the last/innermost ViewPort from the stack and returns it. + +=head2 pop_viewports_to + +=over + +=item Arguments: $viewport + +=back + +Pops all ViewPorts off the stack until the given ViewPort object +remains as the last item. If passed a $viewport not on the stack, this +will empty the stack completely (and then die complainingly). + +TODO: Should pop_viewports_to check $vp->focus_stack eq $self first? + +=head2 vp_head + +=over + +=item Arguments: none + +=back + +Retrieve the first ViewPort in this stack. Useful for calling +L<Reaction::UI::Window/render_viewport> on a +L<Reaction::UI::ViewPort/focus_tangent>. + +=head2 vp_head + +=over + +=item Arguments: none + +=back + +Retrieve the first ViewPort in this stack. Useful for calling +L<Reaction::UI::Window/render_viewport> on a +L<Reaction::UI::ViewPort/focus_tangent>. + +=head2 vp_tail + +=over + +=item Arguments: none + +=back + +Retrieve the last ViewPort in this stack. Useful for calling +L<Reaction::UI::Window/render_viewport> on a +L<Reaction::UI::ViewPort/focus_tangent>. + +=head2 vp_count + +=over + +=item Arguments: none + +=back + +=head2 loc_prefix + +=head2 apply_events + +=over + +=item Arguments: $ctx, $params_hashref + +=back + +Instruct each of the ViewPorts in the stack to apply the given events +to each of it's tangent stacks, and then to itself. These are applied +starting with the last/innermost ViewPort first. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/LayoutSet.pm b/lib/Reaction/UI/LayoutSet.pm new file mode 100644 index 0000000..793568f --- /dev/null +++ b/lib/Reaction/UI/LayoutSet.pm @@ -0,0 +1,52 @@ +package Reaction::UI::LayoutSet; + +use Reaction::Class; +use File::Spec; + +class LayoutSet which { + + has 'fragments' => (is => 'ro', default => sub { {} }); + + has 'name' => (is => 'ro', required => 1); + + has 'source_file' => (is => 'rw', lazy_fail => 1); + + implements 'BUILD' => as { + my ($self, $args) = @_; + my @path = @{$args->{search_path}||[]}; + confess "No search_path provided" unless @path; + my $found; + SEARCH: foreach my $path (@path) { + my $cand = $path->file($self->name); + if ($cand->stat) { + $self->_load_file($cand); + $found = 1; + last SEARCH; + } + } + confess "Unable to load file for LayoutSet ".$self->name unless $found; + }; + + implements '_load_file' => as { + my ($self, $file) = @_; + my $data = $file->slurp; + my $fragments = $self->fragments; + # cheesy match for "=for layout fragmentname ... =something" + # final split group also handles last in file, (?==) is lookahead + # assertion for '=' so "=for layout fragment1 ... =for layout fragment2" + # doesn't have the match pos go past the latter = and lose fragment2 + while ($data =~ m/=for layout (.*?)\n(.+?)(?:\n(?==)|$)/sg) { + my ($fname, $text) = ($1, $2); + $fragments->{$fname} = $text; + } + $self->source_file($file); + }; + + implements 'widget_type' => as { + my ($self) = @_; + return join('', map { ucfirst($_) } split('_', $self->name)); + }; + +}; + +1; diff --git a/lib/Reaction/UI/LayoutSet/TT.pm b/lib/Reaction/UI/LayoutSet/TT.pm new file mode 100644 index 0000000..72d3fad --- /dev/null +++ b/lib/Reaction/UI/LayoutSet/TT.pm @@ -0,0 +1,44 @@ +package Reaction::UI::LayoutSet::TT; + +use Reaction::Class; +use aliased 'Reaction::UI::LayoutSet'; +use aliased 'Template::View'; + +class TT is LayoutSet, which { + + has 'tt_view' => (is => 'rw', isa => View, lazy_fail => 1); + + implements 'BUILD' => as { + my ($self, $args) = @_; + + # Do this at build time rather than on demand so any exception if it + # goes wrong gets thrown sometime sensible + + $self->tt_view($self->_build_tt_view($args)); + }; + + implements '_build_tt_view' => as { + my ($self, $args) = @_; + my $tt_object = $args->{tt_object} + || confess "tt_object not provided to new()"; + my $tt_args = { data => {} }; + my $name = $self->name; + my $fragments = $self->fragments; + my $tt_source = qq{[% VIEW ${name};\n\n}. + join("\n\n", + map { + qq{BLOCK $_; -%]\n}.$fragments->{$_}.qq{\n[% END;}; + } keys %$fragments + ).qq{\nEND; # End view\ndata.view = ${name};\n %]}; + $tt_object->process(\$tt_source, $tt_args) + || confess "Template processing error: ".$tt_object->error + ." processing:\n${tt_source}"; + confess "View template processed but no view object found" + ." after processing:\n${tt_source}" + unless $tt_args->{data}{view}; + return $tt_args->{data}{view}; + }; + +}; + +1; diff --git a/lib/Reaction/UI/Renderer/XHTML.pm b/lib/Reaction/UI/Renderer/XHTML.pm new file mode 100644 index 0000000..af98521 --- /dev/null +++ b/lib/Reaction/UI/Renderer/XHTML.pm @@ -0,0 +1,89 @@ +package Reaction::UI::Renderer::XHTML; + +use strict; +use base qw/Catalyst::View::TT Reaction::Object/; +use Reaction::Class; + +use HTML::Entities; + +__PACKAGE__->config({ + CATALYST_VAR => 'ctx', + RECURSION => 1, +}); + +sub render_window { + my ($self, $window) = @_; + my $root_vp = $window->focus_stack->vp_head; + confess "Can't flush view for window with empty focus stack" + unless defined($root_vp); + $self->render_viewport($window, $root_vp); +} + +sub render_viewport { + my ($self, $window, $vp) = @_; + my $ctx = $window->ctx; + my %args = ( + self => $vp, + ctx => $ctx, + window => $window, + type => $vp->layout + ); + unless (length $args{type}) { + my $type = (split('::', ref($vp)))[-1]; + $args{type} = lc($type); + } + return $self->render($ctx, 'component', \%args); +} + +around 'render' => sub { + my $super = shift; + my ($self,$args) = @_[0,3]; + local $self->template->{SERVICE}{CONTEXT}{BLKSTACK}; + local $self->template->{SERVICE}{CONTEXT}{BLOCKS}; + $args->{process_attrs} = \&process_attrs; + return $super->(@_); +}; + +sub process_attrs{ + my $attrs = shift; + return $attrs unless ref $attrs eq 'HASH'; + + my @processed_attrs; + while( my($k,$v) = each(%$attrs) ){ + my $enc_v = $v; + next if ($enc_v eq ""); + if ($k eq 'class' && ref $v eq 'ARRAY'){ + $enc_v = join ' ', map { encode_entities($_) } @$v; + } elsif ($k eq 'style' && ref $v eq 'HASH'){ + $enc_v = join '; ', map{ "${_}: ".encode_entities($v->{$_}) } keys %{$v}; + } + push(@processed_attrs, "${k}=\"${enc_v}\""); + } + + return ' '.join ' ', @processed_attrs if (scalar(@processed_attrs) > 0); + return; +} + +1; + +=head1 NAME + +Reaction::UI::Renderer::XHTML + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 render + +=head2 process_attrs + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/RenderingContext.pm b/lib/Reaction/UI/RenderingContext.pm new file mode 100644 index 0000000..1c990b9 --- /dev/null +++ b/lib/Reaction/UI/RenderingContext.pm @@ -0,0 +1,13 @@ +package Reaction::UI::RenderingContext; + +use Reaction::Class; + +class RenderingContext which { + + implements 'render' => as { + confess "abstract method"; + }; + +}; + +1; diff --git a/lib/Reaction/UI/RenderingContext/TT.pm b/lib/Reaction/UI/RenderingContext/TT.pm new file mode 100644 index 0000000..07c700b --- /dev/null +++ b/lib/Reaction/UI/RenderingContext/TT.pm @@ -0,0 +1,91 @@ +package Reaction::UI::RenderingContext::TT; + +use Reaction::Class; +use aliased 'Reaction::UI::RenderingContext'; +use aliased 'Template::View'; + +class TT is RenderingContext, which { + + has 'tt_view' => ( is => 'ro', required => 1, isa => View); + + has 'iter_class' => ( + is => 'ro', required => 1, + default => sub { 'Reaction::UI::Renderer::TT::Iter'; }, + ); + + implements 'render' => as { + my ($self, $fname, $args) = @_; + + # foreach non-_ prefixed key in the args + # build a subref for this key that passes self so the generator has a + # rendering context when [% key %] is evaluated by TT as $val->() + # (assuming it's a subref - if not just pass through) + + my $tt_args = { + map { + my $arg = $args->{$_}; + ($_ => (ref $arg eq 'CODE' ? sub { $arg->($self) } : $arg)) + } grep { !/^_/ } keys %$args + }; + + # if there's an _ key that's our current topic (decalarative syntax + # sees $_ as $_{_}) so build an iterator around it. + + # There's possibly a case for making everything an iterator but I think + # any fragment should only have a single multiple arg + + # we also create a 'pos' shortcut to content.pos for brevity + + if (my $topic = $args->{_}) { + my $iter = $self->iter_class->new( + $topic, $self + ); + $tt_args->{content} = $iter; + $tt_args->{pos} = sub { $iter->pos }; + } + $self->tt_view->include($fname, $tt_args); + }; + +}; + +package Reaction::UI::Renderer::TT::Iter; + +use overload ( + q{""} => 'stringify', + fallback => 1 +); + +sub pos { shift->{pos} } + +sub new { + my ($class, $cr, $rctx) = @_; + bless({ rctx => $rctx, cr => $cr, pos => 0 }, $class); +} + +sub next { + my $self = shift; + $self->{pos}++; + my $next = $self->{cr}->(); + return unless $next; + return sub { $next->($self->{rctx}) }; +} + +sub all { + my $self = shift; + my @all; + while (my $e = $self->next) { + push(@all, $e); + } + \@all; +} + +sub stringify { + my $self = shift; + my $res = ''; + foreach my $e (@{$self->all}) { + $res .= $e->(); + } + $res; +} + +1; diff --git a/lib/Reaction/UI/RootController.pm b/lib/Reaction/UI/RootController.pm new file mode 100644 index 0000000..89f1a0f --- /dev/null +++ b/lib/Reaction/UI/RootController.pm @@ -0,0 +1,97 @@ +package Reaction::UI::RootController; + +use base qw/Reaction::UI::Controller/; +use Reaction::Class; +use Reaction::UI::Window; + +__PACKAGE__->config( + view_name => 'XHTML', + content_type => 'text/html', +); + +has 'view_name' => (isa => 'Str', is => 'rw'); +has 'content_type' => (isa => 'Str', is => 'rw'); +has 'window_title' => (isa => 'Str', is => 'rw'); + +sub begin :Private { + my ($self, $ctx) = @_; + my $window :Stashed = Reaction::UI::Window->new( + ctx => $ctx, + view_name => $self->view_name, + content_type => $self->content_type, + title => $self->window_title, + ); + my $focus_stack :Stashed = $window->focus_stack; +} + +sub end :Private { + my $window :Stashed; + $window->flush; +} + +1; + +=head1 NAME + +Reaction::UI::RootController - Base component for the Root Controller + +=head1 SYNOPSIS + + package MyApp::Controller::Root; + use base 'Reaction::UI::RootController'; + + # Create UI elements: + $c->stash->{focus_stack}->push_viewport('Reaction::UI::ViewPort'); + + # Access the window title in a template: + [% window.title %] + +=head1 DESCRIPTION + +Using this module as a base component for your L<Catalyst> Root +Controller provides automatic creation of a L<Reaction::UI::Window> +object containing an empty L<Reaction::UI::FocusStack> for your UI +elements. The stack is also resolved and rendered for you in the +C<end> action. + +=head1 METHODS + +=head2 view_name + +=over + +=item Arguments: $viewname? + +=back + +Set or retrieve the classname of the view used to render the UI. + +=head2 content_type + +=over + +=item Arguments: $contenttype? + +=back + +Set or retrieve the content type of the page created. + +=head2 window_title + +=over + +=item Arguments: $windowtitle? + +=back + +Set or retrieve the title of the page created. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/View.pm b/lib/Reaction/UI/View.pm new file mode 100644 index 0000000..4fc40c6 --- /dev/null +++ b/lib/Reaction/UI/View.pm @@ -0,0 +1,133 @@ +package Reaction::UI::View; + +use Reaction::Class; + +# declaring dependencies + +use Reaction::UI::LayoutSet; +use Reaction::UI::RenderingContext; + +class View which { + + has '_layout_set_cache' => (is => 'ro', default => sub { {} }); + + has 'app' => (is => 'ro', required => 1); + + has 'skin_name' => (is => 'ro', required => 1); + + has 'layout_set_class' => (is => 'ro', lazy_build => 1); + + has 'rendering_context_class' => (is => 'ro', lazy_build => 1); + + implements 'COMPONENT' => as { + my ($class, $app, $args) = @_; + return $class->new(%{$args||{}}, app => $app); + }; + + implements 'render_window' => as { + my ($self, $window) = @_; + my $root_vp = $window->focus_stack->vp_head; + $self->render_viewport(undef, $root_vp); + }; + + implements 'render_viewport' => as { + my ($self, $outer_rctx, $vp) = @_; + my $layout_set = $self->layout_set_for($vp); + my $rctx = $self->create_rendering_context( + layouts => $layout_set, + outer => $outer_rctx, + ); + my $widget = $self->widget_for($vp, $layout_set); + $widget->render($rctx); + }; + + implements 'widget_for' => as { + my ($self, $vp, $layout_set) = @_; + return $self->widget_class_for($layout_set) + ->new(view => $self, viewport => $vp); + }; + + implements 'widget_class_for' => as { + my ($self, $layout_set) = @_; + my $base = ref($self); + my $tail = $layout_set->widget_type; + my $class = join('::', $base, 'Widget', $tail); + Class::MOP::load_class($class); + return $class; + }; + + implements 'layout_set_for' => as { + my ($self, $vp) = @_; + my $lset_name = eval { $vp->layout }; + confess "Couldn't call layout method on \$vp arg ${vp}: $@" if $@; + unless (length($lset_name)) { + my $last = (split('::',ref($vp)))[-1]; + $lset_name = join('_', map { lc($_) } split(/(?=[A-Z])/, $last)); + } + my $cache = $self->_layout_set_cache; + return $cache->{$lset_name} ||= $self->create_layout_set($lset_name); + }; + + implements 'create_layout_set' => as { + my ($self, $name) = @_; + return $self->layout_set_class->new( + $self->layout_set_args_for($name), + ); + }; + + implements 'find_related_class' => as { + my ($self, $rel) = @_; + my $own_class = ref($self)||$self; + confess View." is abstract, you must subclass it" if $own_class eq View; + foreach my $super ($own_class->meta->class_precedence_list) { + next if $super eq View; + if ($super =~ /::View::/) { + (my $class = $super) =~ s/::View::/::${rel}::/; + if (eval { Class::MOP::load_class($class) }) { + return $class; + } + } + } + confess "Unable to find related ${rel} class for ${own_class}"; + }; + + implements 'build_layout_set_class' => as { + my ($self) = @_; + return $self->find_related_class('LayoutSet'); + }; + + implements 'layout_set_args_for' => as { + my ($self, $name) = @_; + return (name => $name, search_path => $self->layout_search_path); + }; + + implements 'layout_search_path' => as { + my ($self) = @_; + return $self->search_path_for_type('layout'); + }; + + implements 'search_path_for_type' => as { + my ($self, $type) = @_; + return [ $self->app->path_to('share','skin',$self->skin_name,$type) ]; + }; + + implements 'create_rendering_context' => as { + my ($self, @args) = @_; + return $self->rendering_context_class->new( + $self->rendering_context_args_for(@args), + @args, + ); + }; + + implements 'build_rendering_context_class' => as { + my ($self) = @_; + return $self->find_related_class('RenderingContext'); + }; + + implements 'rendering_context_args_for' => as { + return (); + }; + +}; + +1; diff --git a/lib/Reaction/UI/View/TT.pm b/lib/Reaction/UI/View/TT.pm new file mode 100644 index 0000000..d57b522 --- /dev/null +++ b/lib/Reaction/UI/View/TT.pm @@ -0,0 +1,41 @@ +package Reaction::UI::View::TT; + +use Reaction::Class; +use aliased 'Reaction::UI::View'; +use Template; + +class TT is View, which { + + has '_tt' => (isa => 'Template', is => 'rw', lazy_fail => 1); + + implements 'BUILD' => as { + my ($self, $args) = @_; + my $tt_args = $args->{tt}||{}; + $self->_tt(Template->new($tt_args)); + }; + + overrides 'layout_set_args_for' => sub { + my ($self) = @_; + return (super(), tt_object => $self->_tt); + }; + + overrides 'rendering_context_args_for' => sub { + my ($self, %args) = @_; + return (super(), tt_view => $args{layouts}->tt_view); + }; + + implements 'serve_static_file' => as { + my ($self, $c, $args) = @_; + foreach my $path (@{$self->search_path_for_type('web')}) { + my $cand = $path->file(@$args); + if ($cand->stat) { + $c->serve_static_file($cand); + return 1; + } + } + return 0; + }; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort.pm b/lib/Reaction/UI/ViewPort.pm new file mode 100644 index 0000000..4c5ac5a --- /dev/null +++ b/lib/Reaction/UI/ViewPort.pm @@ -0,0 +1,389 @@ +package Reaction::UI::ViewPort; + +use Reaction::Class; + +class ViewPort which { + + has location => (isa => 'Str', is => 'rw', required => 1); + has layout => (isa => 'Str', is => 'rw', lazy_build => 1); + has outer => (isa => 'Reaction::UI::ViewPort', is => 'rw', weak_ref => 1); + has inner => (isa => 'Reaction::UI::ViewPort', is => 'rw'); + has focus_stack => ( + isa => 'Reaction::UI::FocusStack', is => 'rw', weak_ref => 1 + ); + has _tangent_stacks => ( + isa => 'HashRef', is => 'ro', default => sub { {} } + ); + has ctx => (isa => 'Catalyst', is => 'ro', required => 1); + has column_order => (is => 'rw'); + + implements build_layout => as { + ''; + }; + + implements create_tangent => as { + my ($self, $name) = @_; + my $t_map = $self->_tangent_stacks; + if (exists $t_map->{$name}) { + confess "Can't create tangent with already existing name ${name}"; + } + my $loc = join('.', $self->location, $name); + my $tangent = Reaction::UI::FocusStack->new(loc_prefix => $loc); + $t_map->{$name} = $tangent; + return $tangent; + }; + + implements focus_tangent => as { + my ($self, $name) = @_; + if (my $tangent = $self->_tangent_stacks->{$name}) { + return $tangent; + } else { + return; + } + }; + + implements focus_tangents => as { + return keys %{shift->_tangent_stacks}; + }; + + implements child_event_sinks => as { + my $self = shift; + return values %{$self->_tangent_stacks}; + }; + + implements apply_events => as { + my ($self, $ctx, $events) = @_; + $self->apply_child_events($ctx, $events); + $self->apply_our_events($ctx, $events); + }; + + implements apply_child_events => as { + my ($self, $ctx, $events) = @_; + foreach my $child ($self->child_event_sinks) { + $child->apply_events($ctx, $events); + } + }; + + implements apply_our_events => as { + my ($self, $ctx, $events) = @_; + my $loc = $self->location; + my %our_events; + foreach my $key (keys %$events) { + if ($key =~ m/^${loc}:(.*)$/) { + $our_events{$1} = $events->{$key}; + } + } + if (keys %our_events) { + #warn "$self: events ".join(', ', %our_events)."\n"; + $self->handle_events(\%our_events); + } + }; + + implements handle_events => as { + my ($self, $events) = @_; + foreach my $event ($self->accept_events) { + if (exists $events->{$event}) { + $self->$event($events->{$event}); + } + } + }; + + implements accept_events => as { () }; + + implements event_id_for => as { + my ($self, $name) = @_; + return join(':', $self->location, $name); + }; + + implements sort_by_spec => as { + my ($self, $spec, $items) = @_; + return $items if not defined $spec; + + my @order; + if (ref $spec eq 'ARRAY') { + @order = @$spec; + } + elsif (not ref $spec) { + return $items unless length $spec; + @order = split /\s+/, $spec; + } + + my %order_map = map {$_ => 0} @$items; + for my $order_num (0..$#order) { + $order_map{ $order[$order_num] } = ($#order - $order_num) + 1; + } + + return [sort {$order_map{$b} <=> $order_map{$a}} @$items]; + }; + +}; + +1; + + +=head1 NAME + +Reaction::UI::ViewPort - Page layout building block + +=head1 SYNOPSIS + + # Create a new ViewPort: + # $stack isa Reaction::UI::FocusStack object + my $vp = $stack->push_viewport('Reaction::UI::ViewPort', layout => 'xthml'); + + # Fetch ViewPort higher up the stack (further out) + my $outer = $vp->outer(); + + # Fetch ViewPort lower down (further in) + my $inner = $vp->inner(); + + # Create a named tangent stack for this ViewPort + my $substack = $vp->create_tangent('name'); + + # Retrieve a tangent stack for this ViewPort + my $substack = $vp->forcus_tangent('name'); + + # Get the names of all the tangent stacks for this ViewPort + my @names = $vp->focus_tangents(); + + # Fetch all the tangent stacks for this ViewPort + # This is called by apply_events + my $stacks = $vp->child_event_sinks(); + + + ### The following methods are all called automatically when using + ### Reaction::UI::Controller(s) + # Resolve current events with this ViewPort + $vp->apply_events($ctx, $param_hash); + + # Apply current events to all tangent stacks + # This is called by apply_events + $vp->apply_child_events($ctx, $params_hash); + + # Apply current events to this ViewPort + # This is called by apply_events + $vp->apply_our_events($ctx, $params_hash); + +=head1 DESCRIPTION + +A ViewPort describes part of a page, it can be a field, a form or +an entire page. ViewPorts are created on a +L<Reaction::UI::FocusStack>, usually belonging to a controller or +another ViewPort. Each ViewPort knows it's own position in the stack +it is in, as well as the stack containing it. + +Each ViewPort has a specific location in the heirarchy of viewports +making up a page. The hierarchy is determined as follows: The first +ViewPort in a stack is labeled C<0>, the second is C<1> and so on. If +a ViewPort is in a named tangent, it's location will contain the name +of the tangent in it's location. + +For example, the first ViewPort in the 'left' tangent of the main +ViewPort has location C<0.left.0>. + +Several ViewPort attributes are set by +L<Reaction::UI::FocusStack/push_viewport> when new ViewPorts are +created, these are as follows: + +=over + +=item Automatic: + +=over + +=item outer + +The outer attribute is set to the previous ViewPort in the stack when +creating a ViewPort, if the ViewPort is the first in the stack, it +will be undef. + +=item inner + +The inner attribute is set to the next ViewPort down in the stack when +it is created, if this is the last ViewPort in the stack, it will be +undef. + +=item focus_stack + +The focus_stack attribute is set to the L<Reaction::UI::FocusStack> +object that created the ViewPort. + +=item ctx + +The ctx attribute will be passed automatically when using +L<Reaction::UI::Controller/push_viewport> to create a ViewPort in the +base stack of a controller. When creating tangent stacks, you may have +to pass it in yourself. + +=back + +=item Optional: + +=over + +=item location + +=item layout + +The layout attribute can either be specifically passed when calling +C<push_viewport>, or it will be determined using the last part of the +ViewPorts classname. + +=item column_order + +This is generally used by more specialised ViewPorts such as the +L<ListView|Reaction::UI::ViewPort::ListView> or +L<ActionForm|Reaction::UI::ViewPort::ActionForm>. It can be either a +space separated list of column names, or an arrayref of column names. + +=back + +=back + +=head1 METHODS + +=head2 outer + +=over + +=item Arguments: none + +=back + +Fetch the ViewPort outside this one in the page hierarchy. + +=head2 inner + +=over + +=item Arguments: none + +=back + +Fetch the ViewPort inside this one in the page hierarchy. + +=head2 create_tangent + +=over + +=item Arguments: $tangent_name + +=back + +Create a new named L<Reaction::UI::FocusStack> inside this +ViewPort. The created FocusStack is returned. + +=head2 focus_tangent + +=over + +=item Arguments: $tangent_name + +=back + +Fetch a named FocusStack from this ViewPort. + +=head2 focus_tangents + +=over + +=item Arguments: none + +=back + +Returns a list of names of all the known tangents in this ViewPort. + +=head2 focus_stack + +Return the L<Reaction::UI::FocusStack> object that this ViewPort is in. + +=head2 apply_events + +=over + +=item Arguments: $ctx, $params_hashref + +=back + +This method is called by the FocusStack object to resolve all events +for the ViewPort. + +=head2 apply_child_events + +=over + +=item Arguments: $ctx, $params_hashref + +=back + +Resolve the given events for all the tangents of this ViewPort. Called +by L<apply_events>. + +=head2 apply_our_events + +=over + +=item Arguments: $ctx, $events + +=back + +Resolve the given events that match the location of this +ViewPort. Called by L<apply_events>. + +=head2 handle_events + +=over + +=item Arguments: $events + +=back + +Actually call the event handlers for this ViewPort. Called by +L<apply_our_events>. By default this will do nothing, subclass +ViewPort and implement L<accept_events>. + +=head2 accept_events + +=over + +=item Arguments: none + +=back + +Implement this method in a subclass and return a list of events that +your ViewPort is accepting. + +=head2 event_id_for + +=over + +=item Arguments: $name + +=back + +Create an id for the given event name and this ViewPort. Generally +returns the location and the name, joined with a colon. + +=head2 sort_by_spec + +=over + +=item Arguments: $spec, $items + +=back + +Sorts the given list of items such that the ones that also appear in +the spec are at the beginning. This is called by +L<Reaction::UI::ViewPort::ActionForm> and +L<Reaction::UI::ViewPort::ListView>, and gets passed L<column_order> +as the spec argument. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/ActionForm.pm b/lib/Reaction/UI/ViewPort/ActionForm.pm new file mode 100644 index 0000000..0a413db --- /dev/null +++ b/lib/Reaction/UI/ViewPort/ActionForm.pm @@ -0,0 +1,400 @@ +package Reaction::UI::ViewPort::ActionForm; + +use Reaction::Class; + +use aliased 'Reaction::UI::ViewPort::Field::Text'; +use aliased 'Reaction::UI::ViewPort::Field::Number'; +use aliased 'Reaction::UI::ViewPort::Field::Boolean'; +use aliased 'Reaction::UI::ViewPort::Field::File'; +use aliased 'Reaction::UI::ViewPort::Field::String'; +use aliased 'Reaction::UI::ViewPort::Field::Password'; +use aliased 'Reaction::UI::ViewPort::Field::DateTime'; +use aliased 'Reaction::UI::ViewPort::Field::ChooseOne'; +use aliased 'Reaction::UI::ViewPort::Field::ChooseMany'; +use aliased 'Reaction::UI::ViewPort::Field::HiddenArray'; +use aliased 'Reaction::UI::ViewPort::Field::TimeRange'; + +class ActionForm is 'Reaction::UI::ViewPort', which { + has action => ( + isa => 'Reaction::InterfaceModel::Action', is => 'ro', required => 1 + ); + + has field_names => (isa => 'ArrayRef', is => 'rw', lazy_build => 1); + + has _field_map => ( + isa => 'HashRef', is => 'rw', init_arg => 'fields', + predicate => '_has_field_map', set_or_lazy_build('field_map'), + ); + + has changed => ( + isa => 'Int', is => 'rw', reader => 'is_changed', default => sub { 0 } + ); + + has next_action => ( + isa => 'ArrayRef', is => 'rw', required => 0, predicate => 'has_next_action' + ); + + has on_apply_callback => ( + isa => 'CodeRef', is => 'rw', required => 0, + predicate => 'has_on_apply_callback' + ); + + has ok_label => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'ok' } + ); + + has apply_label => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'apply' } + ); + + has close_label => (isa => 'Str', is => 'rw', lazy_fail => 1); + + has close_label_close => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'close' } + ); + + has close_label_cancel => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'cancel' } + ); + + sub fields { shift->_field_map } + + implements BUILD => as { + my ($self, $args) = @_; + unless ($self->_has_field_map) { + my @field_map; + my $action = $self->action; + foreach my $attr ($action->parameter_attributes) { + push(@field_map, $self->build_fields_for($attr => $args)); + } + + my %field_map = @field_map; + my @field_names = @{ $self->sort_by_spec( + $args->{column_order}, [keys %field_map] )}; + + $self->_field_map(\%field_map); + $self->field_names(\@field_names); + } + $self->close_label($self->close_label_close); + }; + + implements build_fields_for => as { + my ($self, $attr, $args) = @_; + my $attr_name = $attr->name; + #TODO: DOCUMENT ME!!!!!!!!!!!!!!!!! + my $builder = "build_fields_for_name_${attr_name}"; + my @fields; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); # re-use coderef from can() + } elsif ($attr->has_type_constraint) { + my $constraint = $attr->type_constraint; + my $base_name = $constraint->name; + my $tried_isa = 0; + CONSTRAINT: while (defined($constraint)) { + my $name = $constraint->name; + if (eval { $name->can('meta') } && !$tried_isa++) { + foreach my $class ($name->meta->class_precedence_list) { + my $mangled_name = $class; + $mangled_name =~ s/:+/_/g; + my $builder = "build_fields_for_type_${mangled_name}"; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); + last CONSTRAINT; + } + } + } + if (defined($name)) { + unless (defined($base_name)) { + $base_name = "(anon subtype of ${name})"; + } + my $mangled_name = $name; + $mangled_name =~ s/:+/_/g; + my $builder = "build_fields_for_type_${mangled_name}"; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); + last CONSTRAINT; + } + } + $constraint = $constraint->parent; + } + if (!defined($constraint)) { + confess "Can't build field ${attr_name} of type ${base_name} without $builder method or build_fields_for_type_<type> method for type or any supertype"; + } + } else { + confess "Can't build field ${attr} without $builder method or type constraint"; + } + return @fields; + }; + + implements build_field_map => as { + confess "Lazy field map building not supported by default"; + }; + + implements can_apply => as { + my ($self) = @_; + foreach my $field (values %{$self->_field_map}) { + return 0 if $field->needs_sync; + # if e.g. a datetime field has an invalid value that can't be re-assembled + # into a datetime object, the action may be in a consistent state but + # not synchronized from the fields; in this case, we must not apply + } + return $self->action->can_apply; + }; + + implements do_apply => as { + my $self = shift; + return $self->action->do_apply; + }; + + implements ok => as { + my $self = shift; + if ($self->apply(@_)) { + $self->close(@_); + } + }; + + implements apply => as { + my $self = shift; + if ($self->can_apply && (my $result = $self->do_apply)) { + $self->changed(0); + $self->close_label($self->close_label_close); + if ($self->has_on_apply_callback) { + $self->on_apply_callback->($self => $result); + } + return 1; + } else { + $self->changed(1); + $self->close_label($self->close_label_cancel); + return 0; + } + }; + + implements close => as { + my $self = shift; + my ($controller, $name, @args) = @{$self->next_action}; + $controller->pop_viewport; + $controller->$name($self->action->ctx, @args); + }; + + sub can_close { 1 } + + override accept_events => sub { + (($_[0]->has_next_action ? ('ok', 'close') : ()), 'apply', super()); + }; # can't do a close-type operation if there's nowhere to go afterwards + + override child_event_sinks => sub { + my ($self) = @_; + return ((grep { ref($_) =~ 'Hidden' } values %{$self->_field_map}), + (grep { ref($_) !~ 'Hidden' } values %{$self->_field_map}), + super()); + }; + + after apply_child_events => sub { + # interrupt here because fields will have been updated + my ($self) = @_; + $self->sync_action_from_fields; + }; + + implements sync_action_from_fields => as { + my ($self) = @_; + my $field_map = $self->_field_map; + my @fields = values %{$field_map}; + foreach my $field (@fields) { + $field->sync_to_action; # get the field to populate the $action if possible + } + $self->action->sync_all; + foreach my $field (@fields) { + $field->sync_from_action; # get errors from $action if applicable + } + }; + + implements build_simple_field => as { + my ($self, $class, $attr, $args) = @_; + my $attr_name = $attr->name; + my %extra; + if (my $config = $args->{Field}{$attr_name}) { + %extra = %$config; + } + my $field = $class->new( + action => $self->action, + attribute => $attr, + name => $attr->name, + location => join('-', $self->location, 'field', $attr->name), + ctx => $self->ctx, + %extra + ); + return ($attr_name => $field); + }; + + implements build_fields_for_type_Num => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Number, $attr, $args); + }; + + implements build_fields_for_type_Int => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Number, $attr, $args); + }; + + implements build_fields_for_type_Bool => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Boolean, $attr, $args); + }; + + implements build_fields_for_type_File => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(File, $attr, $args); + }; + + implements build_fields_for_type_Str => as { + my ($self, $attr, $args) = @_; + if ($attr->has_valid_values) { # There's probably a better way to do this + return $self->build_simple_field(ChooseOne, $attr, $args); + } + return $self->build_simple_field(Text, $attr, $args); + }; + + implements build_fields_for_type_SimpleStr => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(String, $attr, $args); + }; + + implements build_fields_for_type_Password => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Password, $attr, $args); + }; + + implements build_fields_for_type_DateTime => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(DateTime, $attr, $args); + }; + + implements build_fields_for_type_Enum => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(ChooseOne, $attr, $args); + }; + + implements build_fields_for_type_DBIx_Class_Row => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(ChooseOne, $attr, $args); + }; + + implements build_fields_for_type_ArrayRef => as { + my ($self, $attr, $args) = @_; + if ($attr->has_valid_values) { + return $self->build_simple_field(ChooseMany, $attr, $args) + } else { + return $self->build_simple_field(HiddenArray, $attr, $args) + } + }; + + implements build_fields_for_type_DateTime_Spanset => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(TimeRange, $attr, $args); + }; + + no Moose; + + no strict 'refs'; + delete ${__PACKAGE__ . '::'}{inner}; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::ActionForm + +=head1 SYNOPSIS + + use aliased 'Reaction::UI::ViewPort::ActionForm'; + + $self->push_viewport(ActionForm, + layout => 'register', + action => $action, + next_action => [ $self, 'redirect_to', 'accounts', $c->req->captures ], + ctx => $c, + column_order => [ + qw / contact_title company_name email address1 address2 address3 + city country post_code telephone mobile fax/ ], + ); + +=head1 DESCRIPTION + +This subclass of viewport is used for rendering a collection of +L<Reaction::UI::ViewPort::Field> objects for user editing. + +=head1 ATTRIBUTES + +=head2 action + +L<Reaction::InterfaceModel::Action> + +=head2 ok_label + +Default: 'ok' + +=head2 apply_label + +Default: 'apply' + +=head2 close_label_close + +Default: 'close' + +=head2 close_label_cancel + +This label is only shown when C<changed> is true. + +Default: 'cancel' + +=head2 fields + +=head2 field_names + +Returns: Arrayref of field names. + +=head2 can_apply + +=head2 can_close + +=head2 changed + +Returns true if a field has been edited. + +=head2 next_action + +=head2 on_apply_callback + +CodeRef. + +=head1 METHODS + +=head2 ok + +Calls C<apply>, and then C<close> if successful. + +=head2 close + +Pop viewport and proceed to C<next_action>. + +=head2 apply + +Attempt to save changes and update C<changed> attribute if required. + +=head1 SEE ALSO + +L<Reaction::UI::ViewPort> + +L<Reaction::InterfaceModel::Action> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/DisplayField.pm b/lib/Reaction/UI/ViewPort/DisplayField.pm new file mode 100644 index 0000000..9f9f727 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField.pm @@ -0,0 +1,90 @@ +package Reaction::UI::ViewPort::DisplayField; + +use Reaction::Class; + +class DisplayField is 'Reaction::UI::ViewPort', which { + + has name => ( + isa => 'Str', is => 'rw', required => 1 + ); + + has object => ( + isa => 'Reaction::InterfaceModel::Object', + is => 'ro', required => 0, predicate => 'has_object', + ); + + has attribute => ( + isa => 'Reaction::Meta::InterfaceModel::Object::ParameterAttribute', + is => 'ro', predicate => 'has_attribute', + ); + + has value => ( + is => 'rw', lazy_build => 1, trigger_adopt('value'), + clearer => 'clear_value', + ); + + has label => (isa => 'Str', is => 'rw', lazy_build => 1); + + implements BUILD => as { + my ($self) = @_; + if (!$self->has_attribute != !$self->has_object) { + confess "Should have both object and attribute or neither"; } + }; + + implements build_label => as { + my ($self) = @_; + return join(' ', map { ucfirst } split('_', $self->name)); + }; + + implements build_value => as { + my ($self) = @_; + if ($self->has_attribute) { + my $reader = $self->attribute->get_read_method; + return $self->object->$reader; + } + return ''; + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::DisplayField + +=head1 DESCRIPTION + +Base class for displaying non user-editable fields. + +=head1 ATTRIBUTES + +=head2 name + +=head2 object + +L<Reaction::InterfaceModel::Object> + +=head2 attribute + +L<Reaction::Meta::InterfaceModel::Object::ParameterAttribute> + +=head2 value + +=head2 label + +User friendly label, by default is based on the name. + +=head1 SEE ALSO + +L<Reaction::UI::ViewPort> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/DisplayField/Boolean.pm b/lib/Reaction/UI/ViewPort/DisplayField/Boolean.pm new file mode 100644 index 0000000..9389436 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/Boolean.pm @@ -0,0 +1,31 @@ +package Reaction::UI::ViewPort::DisplayField::Boolean; + +use Reaction::Class; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class Boolean, is DisplayField, which { + has '+value' => (isa => 'Bool'); + has '+layout' => (default => 'displayfield/value_string'); + + has value_string => (isa => 'Str', is => 'rw', lazy_build => 1); + + has value_string_format => + (isa => 'HashRef', is => 'rw', required => 1, + default => sub { {true => 'Yes', false => 'No'} } + ); + + implements build_value_string => as { + my $self = shift; + my $val = $self->value; + if(!defined $val || $val eq "" || "$val" eq '0'){ + return $self->value_string_format->{false}; + } elsif("$val" eq '1'){ + return $self->value_string_format->{true}; + } else{ #this will hopefully never happen + confess "Not supporting some type of Bool value"; + } + }; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/Collection.pm b/lib/Reaction/UI/ViewPort/DisplayField/Collection.pm new file mode 100644 index 0000000..0c06d4b --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/Collection.pm @@ -0,0 +1,29 @@ +package Reaction::UI::ViewPort::DisplayField::Collection; + +use Reaction::Class; +use Scalar::Util 'blessed'; + +class Collection is 'Reaction::UI::ViewPort::DisplayField', which { + has '+value' => (isa => 'ArrayRef'); + has '+layout' => (default => 'displayfield/list'); + + has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, + ); + + override build_value => sub { + return [super()->all]; + }; + + implements build_value_names => as { + my $self = shift; + my @all = @{$self->value||[]}; + my $meth = $self->value_map_method; + my @names = map { blessed $_ ? $_->$meth : $_ } @all; + return [ sort @names ]; + }; +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/DateTime.pm b/lib/Reaction/UI/ViewPort/DisplayField/DateTime.pm new file mode 100644 index 0000000..92d5b81 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/DateTime.pm @@ -0,0 +1,28 @@ +package Reaction::UI::ViewPort::DisplayField::DateTime; + +use Reaction::Class; +use Reaction::Types::DateTime; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class DateTime is DisplayField, which { + has '+value' => (isa => 'DateTime'); + has '+layout' => (default => 'displayfield/value_string'); + + has value_string => (isa => 'Str', is => 'rw', lazy_build => 1); + + has value_string_default_format => ( + isa => 'Str', is => 'rw', required => 1, default => sub { "%F %H:%M:%S" } + ); + + implements build_value_string => as { + my $self = shift; + my $value = eval { $self->value }; + return '' unless $self->has_value; + my $format = $self->value_string_default_format; + return $value->strftime($format) if $value; + return ''; + }; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/List.pm b/lib/Reaction/UI/ViewPort/DisplayField/List.pm new file mode 100644 index 0000000..d70f1ed --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/List.pm @@ -0,0 +1,31 @@ +package Reaction::UI::ViewPort::DisplayField::List; + +use Reaction::Class; +use Scalar::Util 'blessed'; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class List is DisplayField, which { + has '+value' => (isa => 'ArrayRef'); + has '+layout' => (default => 'displayfield/list'); + + has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, + ); + + override build_value => sub { + return super() || []; + }; + + implements build_value_names => as { + my $self = shift; + my @all = @{$self->value||[]}; + my $meth = $self->value_map_method; + my @names = map { blessed $_ ? $_->$meth : $_ } @all; + return [ sort @names ]; + }; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/Number.pm b/lib/Reaction/UI/ViewPort/DisplayField/Number.pm new file mode 100644 index 0000000..7c46d06 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/Number.pm @@ -0,0 +1,10 @@ +package Reaction::UI::ViewPort::DisplayField::Number; + +use Reaction::Class; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class Number is DisplayField, which { + has '+layout' => (default => 'displayfield/string'); +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/RelatedObject.pm b/lib/Reaction/UI/ViewPort/DisplayField/RelatedObject.pm new file mode 100644 index 0000000..3cd217c --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/RelatedObject.pm @@ -0,0 +1,26 @@ +package Reaction::UI::ViewPort::DisplayField::RelatedObject; + +use Reaction::Class; +use Scalar::Util 'blessed'; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class RelatedObject is DisplayField, which { + + has '+layout' => (default => 'displayfield/value_string'); + + has value_string => (isa => 'Str', is => 'ro', lazy_build => 1); + + has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, + ); + + implements build_value_string => as { + my $self = shift; + my $meth = $self->value_map_method; + my $value = $self->value; + return blessed $value ? $value->$meth : $value; + }; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/String.pm b/lib/Reaction/UI/ViewPort/DisplayField/String.pm new file mode 100644 index 0000000..3aab498 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/String.pm @@ -0,0 +1,11 @@ +package Reaction::UI::ViewPort::DisplayField::String; + +use Reaction::Class; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class String is DisplayField, which { + has '+value' => (isa => 'Str'); + has '+layout' => (default => 'displayfield/string'); +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/DisplayField/Text.pm b/lib/Reaction/UI/ViewPort/DisplayField/Text.pm new file mode 100644 index 0000000..c9e2c27 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/DisplayField/Text.pm @@ -0,0 +1,11 @@ +package Reaction::UI::ViewPort::DisplayField::Text; + +use Reaction::Class; +use aliased 'Reaction::UI::ViewPort::DisplayField'; + +class Text is DisplayField, which { + has '+value' => (isa => 'Str'); + has '+layout' => (default => 'displayfield/text'); +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/Field.pm b/lib/Reaction/UI/ViewPort/Field.pm new file mode 100644 index 0000000..41a7c42 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field.pm @@ -0,0 +1,166 @@ +package Reaction::UI::ViewPort::Field; + +use Reaction::Class; + +class Field is 'Reaction::UI::ViewPort', which { + + has name => ( + isa => 'Str', is => 'rw', required => 1 + ); + + has action => ( + isa => 'Reaction::InterfaceModel::Action', + is => 'ro', required => 0, predicate => 'has_action', + ); + + has attribute => ( + isa => 'Reaction::Meta::InterfaceModel::Action::ParameterAttribute', + is => 'ro', predicate => 'has_attribute', + ); + + has value => ( + is => 'rw', lazy_build => 1, trigger_adopt('value'), + clearer => 'clear_value', + ); + + has needs_sync => ( + isa => 'Int', is => 'rw', default => 0 + ); + + has label => (isa => 'Str', is => 'rw', lazy_build => 1); + + has message => ( + isa => 'Str', is => 'rw', required => 1, default => sub { '' } + ); + + implements BUILD => as { + my ($self) = @_; + if (!$self->has_attribute != !$self->has_action) { + confess "Should have both action and attribute or neither"; + } + }; + + implements build_label => as { + my ($self) = @_; + return join(' ', map { ucfirst } split('_', $self->name)); + }; + + implements build_value => as { + my ($self) = @_; + if ($self->has_attribute) { + my $reader = $self->attribute->get_read_method; + my $predicate = $self->attribute->predicate; + if (!$predicate || $self->action->$predicate) { + return $self->action->$reader; + } + } + return ''; + }; + + implements adopt_value => as { + my ($self) = @_; + $self->needs_sync(1) if $self->has_attribute; + }; + + implements sync_to_action => as { + my ($self) = @_; + return unless $self->needs_sync && $self->has_attribute && $self->has_value; + my $attr = $self->attribute; + if (my $tc = $attr->type_constraint) { + my $value = $self->value; + if ($tc->has_coercion) { + $value = $tc->coercion->coerce($value); + } + my $error = $tc->validate($self->value); + if (defined $error) { + $self->message($error); + return; + } + } + my $writer = $attr->get_write_method; + confess "No writer for attribute" unless defined($writer); + $self->action->$writer($self->value); + $self->needs_sync(0); + }; + + implements sync_from_action => as { + my ($self) = @_; + return unless !$self->needs_sync && $self->has_attribute; + $self->message($self->action->error_for($self->attribute)||''); + }; + + override accept_events => sub { ('value', super()) }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field + +=head1 DESCRIPTION + +This viewport is the base class for all field types. + +=head1 ATTRIBUTES + +=head2 name + +=head2 action + +L<Reaction::InterfaceModel::Action> + +=head2 attribute + +L<Reaction::Meta::InterfaceModel::Action::ParameterAttribute> + +=head2 value + +=head2 needs_sync + +=head2 label + +User friendly label, by default is based on the name. + +=head2 message + +Optional string relating to the field. + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort> + +=head2 L<Reaction::UI::ViewPort::DisplayField> + +=head2 L<Reaction::UI::ViewPort::Field::Boolean> + +=head2 L<Reaction::UI::ViewPort::Field::ChooseMany> + +=head2 L<Reaction::UI::ViewPort::Field::ChooseOne> + +=head2 L<Reaction::UI::ViewPort::Field::DateTime> + +=head2 L<Reaction::UI::ViewPort::Field::File> + +=head2 L<Reaction::UI::ViewPort::Field::HiddenArray> + +=head2 L<Reaction::UI::ViewPort::Field::Number> + +=head2 L<Reaction::UI::ViewPort::Field::Password> + +=head2 L<Reaction::UI::ViewPort::Field::String> + +=head2 L<Reaction::UI::ViewPort::Field::Text> + +=head2 L<Reaction::UI::ViewPort::Field::TimeRange> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/Boolean.pm b/lib/Reaction/UI/ViewPort/Field/Boolean.pm new file mode 100644 index 0000000..34f7aae --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/Boolean.pm @@ -0,0 +1,32 @@ +package Reaction::UI::ViewPort::Field::Boolean; + +use Reaction::Class; + +class Boolean is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'Bool'); + has '+layout' => (default => 'checkbox'); + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::Boolean + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/ChooseMany.pm b/lib/Reaction/UI/ViewPort/Field/ChooseMany.pm new file mode 100644 index 0000000..0ea4ed0 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/ChooseMany.pm @@ -0,0 +1,139 @@ +package Reaction::UI::ViewPort::Field::ChooseMany; + +use Reaction::Class; + +class ChooseMany is 'Reaction::UI::ViewPort::Field::ChooseOne', which { + + has '+layout' => (default => 'dual_select_group'); + + has '+value' => (isa => 'ArrayRef'); + + has available_value_names => + (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + my $listify = sub { # quick utility function, $listify->($arg) + return (defined($_[0]) + ? (ref($_[0]) eq 'ARRAY' + ? $_[0] # \@arr => \@arr + : [$_[0]]) # $scalar => [$scalar] + : []); # undef => [] + }; + + around value => sub { + my $orig = shift; + my $self = shift; + if (@_) { + my $value = $listify->(shift); + if (defined $value) { + $_ = $self->str_to_ident($_) for @$value; + my $checked = $self->attribute->check_valid_value($self->action, $value); + # i.e. fail if any of the values fail + confess "Not a valid set of values" + if (@$checked < @$value || grep { !defined($_) } @$checked); + + $value = $checked; + } + $orig->($self, $value); + } else { + $orig->($self); + } + }; + + override build_value => sub { + return super() || []; + }; + + implements is_current_value => as { + my ($self, $check_value) = @_; + my @our_values = @{$self->value||[]}; + #$check_value = $check_value->id if ref($check_value); + #return grep { $_->id eq $check_value } @our_values; + $check_value = $self->obj_to_str($check_value) if ref($check_value); + return grep { $self->obj_to_str($_) eq $check_value } @our_values; + }; + + implements current_values => as { + my $self = shift; + my @all = grep { $self->is_current_value($_) } @{$self->valid_values}; + return [ @all ]; + }; + + implements available_values => as { + my $self = shift; + my @all = grep { !$self->is_current_value($_) } @{$self->valid_values}; + return [ @all ]; + }; + + implements build_available_value_names => as { + my $self = shift; + my @all = @{$self->available_values}; + my $meth = $self->value_map_method; + my @names = map { $_->$meth } @all; + return [ sort @names ]; + }; + + implements build_value_names => as { + my $self = shift; + my @all = @{$self->value||[]}; + my $meth = $self->value_map_method; + my @names = map { $_->$meth } @all; + return [ sort @names ]; + }; + + around handle_events => sub { + my $orig = shift; + my ($self, $events) = @_; + my $ev_value = $listify->($events->{value}); + if (delete $events->{add_all_values}) { + $events->{value} = $self->valid_values; + } + if (delete $events->{do_add_values} && exists $events->{add_values}) { + my $add = $listify->(delete $events->{add_values}); + $events->{value} = [ @{$ev_value}, @$add ]; + } + if (delete $events->{remove_all_values}) { + $events->{value} = []; + } + if (delete $events->{do_remove_values} && exists $events->{remove_values}) { + my $remove = $listify->(delete $events->{remove_values}); + my %r = map { ($_ => 1) } @$remove; + $events->{value} = [ grep { !$r{$_} } @{$ev_value} ]; + } + return $orig->(@_); + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::ChooseMany + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 is_current_value + +=head2 current_values + +=head2 available_values + +=head2 available_value_names + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/ChooseOne.pm b/lib/Reaction/UI/ViewPort/Field/ChooseOne.pm new file mode 100644 index 0000000..ea0db1d --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/ChooseOne.pm @@ -0,0 +1,138 @@ +package Reaction::UI::ViewPort::Field::ChooseOne; + +use Reaction::Class; +use URI; +use Scalar::Util 'blessed'; + +class ChooseOne is 'Reaction::UI::ViewPort::Field', which { + + has '+layout' => (default => 'select'); + + has valid_value_names => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has valid_values => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has name_to_value_map => (isa => 'HashRef', is => 'ro', lazy_build => 1); + + has value_to_name_map => (isa => 'HashRef', is => 'ro', lazy_build => 1); + + has value_map_method => ( + isa => 'Str', is => 'ro', required => 1, default => sub { 'display_name' }, + ); + + around value => sub { + my $orig = shift; + my $self = shift; + if (@_) { + my $value = shift; + if (defined $value) { + if (!ref $value) { + $value = $self->str_to_ident($value); + } + my $checked = $self->attribute->check_valid_value($self->action, $value); + confess "${value} is not a valid value" unless defined($checked); + $value = $checked; + } + $orig->($self, $value); + } else { + $orig->($self); + } + }; + + implements build_valid_values => as { + my $self = shift; + return [ $self->attribute->all_valid_values($self->action) ]; + }; + + implements build_valid_value_names => as { + my $self = shift; + my $all = $self->valid_values; + my $meth = $self->value_map_method; + my @names = map { $_->$meth } @$all; + return [ sort @names ]; + }; + + implements build_name_to_value_map => as { + my $self = shift; + my $all = $self->valid_values; + my $meth = $self->value_map_method; + my %map; + $map{$_->$meth} = $self->obj_to_str($_) for @$all; + return \%map; + }; + + implements build_value_to_name_map => as { + my $self = shift; + my $all = $self->valid_values; + my $meth = $self->value_map_method; + my %map; + $map{$self->obj_to_str($_)} = $_->$meth for @$all; + return \%map; + }; + + implements is_current_value => as { + my ($self, $check_value) = @_; + my $our_value = $self->value; + return unless ref($our_value); + $check_value = $self->obj_to_str($check_value) if ref($check_value); + return $self->obj_to_str($our_value) eq $check_value; + }; + + implements str_to_ident => as { + my ($self, $str) = @_; + my $u = URI->new('','http'); + $u->query($str); + return { $u->query_form }; + }; + + implements obj_to_str => as { + my ($self, $obj) = @_; + return $obj unless ref($obj); + confess "${obj} not an object" unless blessed($obj); + my $ident = $obj->ident_condition; + my $u = URI->new('', 'http'); + $u->query_form(%$ident); + return $u->query; + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::ChooseOne + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 is_current_value + +=head2 value + +=head2 valid_values + +=head2 valid_value_names + +=head2 value_to_name_map + +=head2 name_to_value_map + +=head2 str_to_ident + +=head2 obj_to_str + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/DateTime.pm b/lib/Reaction/UI/ViewPort/Field/DateTime.pm new file mode 100644 index 0000000..2b8509f --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/DateTime.pm @@ -0,0 +1,89 @@ +package Reaction::UI::ViewPort::Field::DateTime; + +use Reaction::Class; +use Reaction::Types::DateTime; +use Time::ParseDate (); + +class DateTime is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'DateTime'); + + has '+layout' => (default => 'dt_textfield'); + + has value_string => ( + isa => 'Str', is => 'rw', lazy_build => 1, + trigger_adopt('value_string') + ); + + has value_string_default_format => ( + isa => 'Str', is => 'rw', required => 1, default => sub { "%F %H:%M:%S" } + ); + + implements build_value_string => as { + my $self = shift; + + # XXX + #<mst> aha, I know why the fucker's lazy + #<mst> it's because if value's calculated + #<mst> it needs to be possible to clear it + #<mst> eval { $self->value } ... is probably the best solution atm + my $value = eval { $self->value }; + return '' unless $self->has_value; + my $format = $self->value_string_default_format; + return $value->strftime($format) if $value; + return ''; + }; + + implements adopt_value_string => as { + my ($self) = @_; + my $value = $self->value_string; + my ($epoch) = Time::ParseDate::parsedate($value, UK => 1); + if (defined $epoch) { + my $dt = 'DateTime'->from_epoch( epoch => $epoch ); + $self->value($dt); + } else { + $self->message("Could not parse date or time"); + $self->clear_value; + $self->needs_sync(1); + } + }; + + override accept_events => sub { + ('value_string', super()); + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::DateTime + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 value_string + +Accessor for the string representation of the DateTime object. + +=head2 value_string_default_format + +By default it is set to "%F %H:%M:%S". + +=head1 SEE ALSO + +=head2 L<DateTime> + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/File.pm b/lib/Reaction/UI/ViewPort/Field/File.pm new file mode 100644 index 0000000..557826d --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/File.pm @@ -0,0 +1,45 @@ +package Reaction::UI::ViewPort::Field::File; + +use Reaction::Class; +use Reaction::Types::File; + +class File is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'File', required => 0); + + has '+layout' => (default => 'file'); + + override apply_our_events => sub { + my ($self, $ctx, $events) = @_; + my $value_key = join(':', $self->location, 'value'); + if (my $upload = $ctx->req->upload($value_key)) { + local $events->{$value_key} = $upload; + return super(); + } else { + return super(); + } + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::File + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/HiddenArray.pm b/lib/Reaction/UI/ViewPort/Field/HiddenArray.pm new file mode 100644 index 0000000..7f8cc73 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/HiddenArray.pm @@ -0,0 +1,42 @@ +package Reaction::UI::ViewPort::Field::HiddenArray; + +use Reaction::Class; + +class HiddenArray is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'ArrayRef'); + + around value => sub { + my $orig = shift; + my $self = shift; + if (@_) { + $orig->($self, (ref $_[0] eq 'ARRAY' ? $_[0] : [ $_[0] ])); + $self->sync_to_action; + } else { + $orig->($self); + } + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::HiddenArray + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/Number.pm b/lib/Reaction/UI/ViewPort/Field/Number.pm new file mode 100644 index 0000000..e4e925f --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/Number.pm @@ -0,0 +1,31 @@ +package Reaction::UI::ViewPort::Field::Number; + +use Reaction::Class; + +class Number is 'Reaction::UI::ViewPort::Field', which { + + has '+layout' => (default => 'textfield'); + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::Number + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/Password.pm b/lib/Reaction/UI/ViewPort/Field/Password.pm new file mode 100644 index 0000000..d70ed62 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/Password.pm @@ -0,0 +1,32 @@ +package Reaction::UI::ViewPort::Field::Password; + +use Reaction::Class; + +class Password is 'Reaction::UI::ViewPort::Field::String', which { + + has '+value' => (isa => 'SimpleStr'); + has '+layout' => (default => 'password'); + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::Password + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/String.pm b/lib/Reaction/UI/ViewPort/Field/String.pm new file mode 100644 index 0000000..4be6bdc --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/String.pm @@ -0,0 +1,34 @@ +package Reaction::UI::ViewPort::Field::String; + +use Reaction::Class; + +class String is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'Str'); # accept over 255 chars in case, upstream + # constraint from model should catch it + + has '+layout' => (default => 'textfield'); + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::String + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/Text.pm b/lib/Reaction/UI/ViewPort/Field/Text.pm new file mode 100644 index 0000000..d4e89f8 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/Text.pm @@ -0,0 +1,32 @@ +package Reaction::UI::ViewPort::Field::Text; + +use Reaction::Class; + +class Text is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'Str'); + has '+layout' => (default => 'textarea'); + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::Text + +=head1 DESCRIPTION + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/Field/TimeRange.pm b/lib/Reaction/UI/ViewPort/Field/TimeRange.pm new file mode 100644 index 0000000..3619b5e --- /dev/null +++ b/lib/Reaction/UI/ViewPort/Field/TimeRange.pm @@ -0,0 +1,151 @@ +package Reaction::UI::ViewPort::Field::TimeRange; + +use Reaction::Class; +use Reaction::Types::DateTime; +use DateTime; +use DateTime::SpanSet; +use Time::ParseDate (); + +class TimeRange is 'Reaction::UI::ViewPort::Field', which { + + has '+value' => (isa => 'DateTime::SpanSet'); + + has '+layout' => (default => 'timerange'); + + has value_string => + (isa => 'Str', is => 'rw', lazy_fail => 1, trigger_adopt('value_string')); + + has delete_label => ( + isa => 'Str', is => 'rw', required => 1, default => sub { 'Delete' }, + ); + + has parent => ( + isa => 'Reaction::UI::ViewPort::TimeRangeCollection', + is => 'ro', + required => 1, + is_weak_ref => 1 + ); + + implements build_value_string => as { + my $self = shift; + #return '' unless $self->has_value; + #return $self->value_string; + }; + + implements value_array => as { + my $self = shift; + return split(',', $self->value_string); + }; + + implements adopt_value_string => as { + my ($self) = @_; + my @values = $self->value_array; + for my $idx (0 .. 3) { # last value is repeat + if (length $values[$idx]) { + my ($epoch) = Time::ParseDate::parsedate($values[$idx], UK => 1); + $values[$idx] = DateTime->from_epoch( epoch => $epoch ); + } + } + $self->value($self->range_to_spanset(@values)); + }; + + implements range_to_spanset => as { + my ($self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern) = @_; + my $spanset = DateTime::SpanSet->empty_set; + if (!$pattern || $pattern eq 'none') { + my $span = DateTime::Span->from_datetimes( + start => $time_from, end => $time_to + ); + $spanset = $spanset->union( $span ); + } else { + my $duration = $time_to - $time_from; + my %args = ( days => $time_from->day + 2, + hours => $time_from->hour, + minutes => $time_from->minute, + seconds => $time_from->second ); + + delete $args{'days'} if ($pattern eq 'daily'); + delete @args{qw/hours days/} if ($pattern eq 'hourly'); + $args{'days'} = $time_from->day if ($pattern eq 'monthly'); + my $start_set = DateTime::Event::Recurrence->$pattern( %args ); + my $iter = $start_set->iterator( start => $repeat_from, end => $repeat_to ); + while ( my $dt = $iter->next ) { + my $endtime = $dt + $duration; + my $new_span = DateTime::Span->from_datetimes( + start => $dt, + end => $endtime + ); + $spanset = $spanset->union( $new_span ); + } + } + return $spanset; + }; + + implements delete => as { + my ($self) = @_; + $self->parent->remove_range_vp($self); + }; + + override accept_events => sub { ('value_string', 'delete', super()) }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::Field::TimeRange + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=head2 value + + Accessor for a L<DateTime::SpanSet> object. + +=head2 value_string + + Returns: Encoded range string representing the value. + +=head2 value_array + + Returns: Arrayref of the elements of C<value_string>. + +=head2 parent + + L<Reaction::UI::ViewPort::TimeRangeCollection> object. + +=head2 range_to_spanset + + Arguments: $self, $time_from, $time_to, $repeat_from, $repeat_to, $pattern + where $time_from, $time_to, $repeat_from, $repeat_to are L<DateTime> + objects, and $pattern is a L<DateTime::Event::Recurrence> method name + + Returns: $spanset + +=head2 delete + + Removes TimeRange from C<parent> collection. + +=head2 delete_label + + Label for the delete option. Default: 'Delete'. + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort::Field> + +=head2 L<Reaction::UI::ViewPort::TimeRangeCollection> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/ListView.pm b/lib/Reaction/UI/ViewPort/ListView.pm new file mode 100644 index 0000000..d5ddfba --- /dev/null +++ b/lib/Reaction/UI/ViewPort/ListView.pm @@ -0,0 +1,465 @@ +package Reaction::UI::ViewPort::ListView; + +use Reaction::Class; +use Data::Page; +use Text::CSV_XS; +use Scalar::Util qw/blessed/; + +class ListView is 'Reaction::UI::ViewPort', which { + has collection => (isa => 'DBIx::Class::ResultSet', + is => 'rw', required => 1); + + has current_collection => ( + isa => 'DBIx::Class::ResultSet', is => 'rw', + lazy_build => 1, clearer => 'clear_current_collection', + ); + + has current_page_collection => ( + isa => 'DBIx::Class::ResultSet', is => 'rw', + lazy_build => 1, clearer => 'clear_current_page_collection', + ); + + has page => ( + isa => 'Int', is => 'rw', required => 1, + default => sub { 1 }, trigger_adopt('page'), + ); + + has pager => ( + isa => 'Data::Page', is => 'rw', + lazy_build => 1, clearer => 'clear_pager', + ); + + has per_page => ( + isa => 'Int', is => 'rw', predicate => 'has_per_page', + default => sub { 10 }, trigger_adopt('page'), + clearer => 'clear_per_page', + ); + + has field_names => (is => 'rw', isa => 'ArrayRef', lazy_build => 1); + + has field_label_map => (is => 'rw', isa => 'HashRef', lazy_build => 1); + + has order_by => ( + isa => 'Str', is => 'rw', predicate => 'has_order_by', + trigger_adopt('order_by') + ); + + has order_by_desc => ( + isa => 'Int', is => 'rw', default => sub { 0 }, + trigger_adopt('order_by') + ); + + has row_action_prototypes => (isa => 'ArrayRef', is => 'ro', lazy_build => 1); + + has exclude_columns => + ( is => 'rw', isa => 'ArrayRef', required => 1, default => sub{ [] } ); + + implements BUILD => as { + my ($self, $args) = @_; + if ($args->{unpaged}) { + $self->clear_per_page; + } + }; + + sub field_label { shift->field_label_map->{+shift}; } + + implements build_pager => as { + my ($self) = @_; + return $self->current_page_collection->pager; + }; + + implements adopt_page => as { + my ($self) = @_; + $self->clear_current_page_collection; + $self->clear_pager; + }; + + implements adopt_order_by => as { + my ($self) = @_; + $self->clear_current_collection; + $self->clear_current_page_collection; + }; + + implements build_current_collection => as { + my ($self) = @_; + my %attrs; + if ($self->has_order_by) { + $attrs{order_by} = $self->order_by; + if ($self->order_by_desc) { + $attrs{order_by} .= ' DESC'; + } + } + return $self->collection + ->search(undef, \%attrs); + }; + + implements build_current_page_collection => as { + my ($self) = @_; + my %attrs; + return $self->current_collection unless $self->has_per_page; + $attrs{rows} = $self->per_page; + return $self->current_collection + ->search(undef, \%attrs) + ->page($self->page); + }; + + implements all_current_rows => as { + return shift->current_collection->all; + }; + + implements current_rows => as { + return shift->current_page_collection->all; + }; + + implements build_field_names => as { + my ($self) = @_; + #candidate for future optimization + my %excluded = map { $_ => undef } @{ $self->exclude_columns }; + + return + $self->sort_by_spec( $self->column_order, + [ map { (($_->get_read_method) || ()) } + grep { !($_->has_type_constraint + && ($_->type_constraint->is_a_type_of('ArrayRef') + || eval { $_->type_constraint->name->isa( + 'DBIx::Class::ResultSet') })) } + grep { !exists $excluded{$_->name} } + grep { $_->name !~ /^_/ } + $self->current_collection + ->result_class + ->meta + ->compute_all_applicable_attributes + ] ); + }; + + implements build_field_label_map => as { + my ($self) = @_; + my %labels; + foreach my $name (@{$self->field_names}) { + $labels{$name} = join(' ', map { ucfirst } split('_', $name)); + } + return \%labels; + }; + + implements build_row_action_prototypes => as { + my $self = shift; + my $ctx = $self->ctx; + return [ + { label => 'View', action => sub { + [ '', 'view', [ @{$ctx->req->captures}, $_[0]->id ] ] } }, + { label => 'Edit', action => sub { + [ '', 'update', [ @{$ctx->req->captures}, $_[0]->id ] ] } }, + { label => 'Delete', action => sub { + [ '', 'delete', [ @{$ctx->req->captures}, $_[0]->id ] ] } }, + ]; + }; + + implements row_actions_for => as { + my ($self, $row) = @_; + my @act; + my $c = $self->ctx; + foreach my $proto (@{$self->row_action_prototypes}) { + my %new = %$proto; + my ($c_name, $a_name, @rest) = @{delete($new{action})->($row)}; + $new{label} = delete($new{label})->($row) if ref $new{label} eq 'CODE'; + $new{uri} = $c->uri_for( + $c->controller($c_name)->action_for($a_name), + @rest + ); + push(@act, \%new); + } + return \@act; + }; + + implements export_to_csv => as { + my ($self) = @_; + my $csv = Text::CSV_XS->new( { binary => 1 } ); + my $output; + my $exporter = sub { + $csv->combine( @_ ); + $output .= $csv->string."\r\n"; + }; + $self->export_to_data($exporter); + my $res = $self->ctx->res; + $res->content_type('text/csv'); + my $path = $self->ctx->req->path; + my @parts = split(/\//, $path); + $res->header( + 'Content-disposition' => 'attachment; filename='.pop(@parts).'.csv' + ); + $res->body($output); + }; + + implements export_to_data => as { + my ($self, $exporter) = @_; + $self->export_header_data($exporter); + $self->export_body_data($exporter); + }; + + implements export_header_data => as { + my ($self, $exporter) = @_; + my @names = @{$self->field_names}; + my %labels = %{$self->field_label_map}; + $exporter->( map { $labels{$_} } @names ); + }; + + implements export_body_data => as { + my ($self, $exporter) = @_; + my @names = @{$self->field_names}; + foreach my $row ($self->all_current_rows) { + my @row_data; + foreach $_ (@names) { + my $data = $row->$_; + if (blessed($data) && $data->can("display_name")) { + $data = $data->display_name; + } + push(@row_data, $data); + } + $exporter->( @row_data ); + } + }; + + override accept_events => sub { ('page', 'order_by', 'order_by_desc', 'export_to_csv', super()); }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::ListView - Page layout block for rows of DBIx::Class::ResultSets + +=head1 SYNOPSIS + + # Create a new ListView + # $stack isa Reaction::UI::FocusStack object + # Assuming you have a DBIC model with an Actors table + my $lv = $stack->push_viewport( + 'Reaction::UI::ViewPort::ListView', + collection => $ctx->model('DBIC::Actors'), # a DBIx::Class::ResultSet + page => 1, # 1 is default + per_page => 10, # 10 is default + field_names => [qw/name age/], + field_label_map => { + 'name' => 'Name', + 'age' => 'Age', + }, + order_by => 'name', + ); + +=head1 DESCRIPTION + +Use this ViewPort to display the contents of a +L<DBIx::Class::ResultSet> as paged sets of rows. The default display +shows 10 rows per page, unsorted. + +TODO: Add a filter_by which allows us to restrict the content? +(Scenario: user has a paged display of data, user selects one value in +a column and clicks "filter by this value", and then only rows +containing that value are shown. + +=head1 ATTRIIBUTES + +=head2 collection + +This mandatory attribute must be an object derived from +L<DBIx::Class::ResultSet> representing the search result or result +source(Table) you wish to display in the ListView. + +The collection is used as the basis to create a refined set of data to +show in the current ListView, this is stored in +L<current_collection>. The data can further be refined and restricted +by passing in or later changing the L<order_by> or L<page> +attributes. The + +=head2 order_by + +A string representing the C<ORDER BY> part of the SQL statement, for +more info see L<DBIx::Class::ResultSet/Attributes> + +=head2 order_by_desc + +By default, sorting is done in ascending order, set this to true to +sort in descending order. Changing this attribute will cause the +L<current_collection> to be cleared and recreated on the next access . + +=head2 exclude_columns + + + +=head2 page + +The page number of the current search result, this will default to +1. If set explicitly on the ListView object, the current search result +and the pager will be cleared and recreated on the next access. + +=head2 per_page + +The number of rows of data to list on each page. Changing this value +on the ListView object will cause the L<current_page_collection> and +the L<pager> to be cleared and recreated on the next access. This will +default to 10 if unset. + +=head2 unpaged + +Set this to a true value if you really don't want your results shown +in pages. + +=head2 field_names + +An array reference of field names to show in the ListView. These must +exist as accessors in the L<DBIx::Class::ResultSource> describing the +L<DBIx::Class::ResultSet> passed to L<collection>. + +If not set, this will default to the list of attributes in the +L<DBIx::Class::ResultSource> which do not begin with an underscore, +and don't have a type of either ArrayRef or +C<DBIx::Class::ResultSet>. In short, all the non-private and +non-relation attributes. + +=head2 field_label_map + +A hash reference mapping the L<field_names> to the column labels used +to describe them in the ListView display. + +If not set, the label values will default to the L<field_names> with +the initial characters capitalised and underscores turned into spaces. + +=head2 row_action_prototypes + + row_action_prototypes => [ + { label => 'Edit', action => sub { [ '', 'update', [ $_[0]->id ] ] } }, + { label => 'Delete', action => sub { [ '', 'delete', [ $_[0]->id ] ] } }, + ]; + +Prototypes describing the actions that can be done on the rows of +ListView data. This is an array reference of hash refs describing the +name of each action with a C<label>, and the actual C<action> that +takes place. The code reference stored in the C<action > will be +called with a L<DBIx::Class::Row> object, it should return a list of a +L<Catalyst::Controller> name, the name of an action in that +controller, and any other parameters that need to be passed to +it. C<label> may be a scalar value or a code reference, in the later case +it will be called with the same parameters as C<action> and the return value +will be used as the C<label> value. + +The example above shows the default actions if this attribute is not set. + +=head2 current_collection + +This contains the currently used L<DBIx::Class::ResultSet> +representing the ListViews data, it is based on the L<collection> +ResultSet, refined using the L<order_by> and L<order_by_desc> attributes. + +The current_collection will be cleared and recreated if the +L<order_by> or L<order_by_desc> attributes are changed on the ListView +object. + +=head2 current_rows + +=head2 all_current_rows + +=head2 pager + +A L<Data::Page> object representing the data for the current search +result, it is cleared and reset when either L<page> or L<order_by> are +changed. + +=head2 current_page_collection + +This contains contains a single page of the contents of the +L<current_collection>, with the L<per_page> number of rows +requested. If the L<page>, L<per_page>, L_order_by> or +L<order_by_desc> attributes are changed on the ListView object, the +current_page_collection is cleared and recreated. + +=head1 METHODS + +=head2 row_actions_for + +=over 4 + +=item Arguments: none + +=back + +Returns an array reference of uris and labels representing the actions +set in L<row_action_prototypes>. L<Catalyst/uri_for> is used to +construct these. + +=head2 export_header_data + +=over 4 + +=item Arguments: $exporter + +=back + + $lv->export_head_data($exporter); + +C<$exporter> should be a code reference which will export lists of +data passed to it. This method calls the C<exporter> code reference +passing it the labels from the L<field_label_map> using the current +set of L<field_names>. + +=head2 export_body_data + +=over 4 + +=item Arguments: $exporter + +=back + + $lv->export_body_data($exporter); + +C<$exporter> should be a code reference which will export lists of +data passed to it. This method calls the C<exporter> code reference +with an array of rows containing the data values of each of the +current L<field_values>. + +=head2 export_to_data + +=over 4 + +=item Arguments: $exporter + +=back + + $lv->export_to_data($exporter); + +C<$exporter> should be a code reference which will export lists of +data passed to it. This method calls L<export_header_data> and +L<export_body_data> with C<exporter>. + +=head2 export_to_csv + +=over 4 + +=item Arguments: none + +=back + + $lv->export_to_csv(); + +Fills the L<Catalyst::Response> body with CSV data of the +L<current_collection> using L<export_to_data> and L<Text::CSV_XS>. + +=head2 field_label + +=over 4 + +=item Arguments: $field_name + +=back + +Returns the label for the given C<field_name>, using L<field_label_map>. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/ViewPort/ObjectView.pm b/lib/Reaction/UI/ViewPort/ObjectView.pm new file mode 100644 index 0000000..e33ba5d --- /dev/null +++ b/lib/Reaction/UI/ViewPort/ObjectView.pm @@ -0,0 +1,182 @@ +package Reaction::UI::ViewPort::ObjectView; + +use Reaction::Class; + +use aliased 'Reaction::UI::ViewPort::DisplayField::Text'; +use aliased 'Reaction::UI::ViewPort::DisplayField::Number'; +use aliased 'Reaction::UI::ViewPort::DisplayField::Boolean'; +use aliased 'Reaction::UI::ViewPort::DisplayField::String'; +use aliased 'Reaction::UI::ViewPort::DisplayField::DateTime'; +use aliased 'Reaction::UI::ViewPort::DisplayField::RelatedObject'; +use aliased 'Reaction::UI::ViewPort::DisplayField::List'; +use aliased 'Reaction::UI::ViewPort::DisplayField::Collection'; + +class ObjectView is 'Reaction::UI::ViewPort', which { + has object => ( + isa => 'Reaction::InterfaceModel::Object', is => 'ro', required => 1 + ); + + has field_names => (isa => 'ArrayRef', is => 'rw', lazy_build => 1); + + has _field_map => ( + isa => 'HashRef', is => 'rw', init_arg => 'fields', + predicate => '_has_field_map', set_or_lazy_build('field_map'), + ); + + has exclude_fields => + ( is => 'rw', isa => 'ArrayRef', required => 1, default => sub{ [] } ); + + sub fields { shift->_field_map } + + implements BUILD => as { + my ($self, $args) = @_; + unless ($self->_has_field_map) { + my @field_map; + my $object = $self->object; + my %excluded = map{$_ => 1} @{$self->exclude_fields}; + for my $attr (grep { !$excluded{$_->name} } $object->parameter_attributes) { + push(@field_map, $self->build_fields_for($attr => $args)); + } + + my %field_map = @field_map; + my @field_names = @{ $self->sort_by_spec( + $args->{column_order}, [keys %field_map] )}; + + $self->_field_map(\%field_map); + $self->field_names(\@field_names); + } + }; + + implements build_fields_for => as { + my ($self, $attr, $args) = @_; + my $attr_name = $attr->name; + my $builder = "build_fields_for_name_${attr_name}"; + my @fields; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); # re-use coderef from can() + } elsif ($attr->has_type_constraint) { + my $constraint = $attr->type_constraint; + my $base_name = $constraint->name; + my $tried_isa = 0; + CONSTRAINT: while (defined($constraint)) { + my $name = $constraint->name; + if (eval { $name->can('meta') } && !$tried_isa++) { + foreach my $class ($name->meta->class_precedence_list) { + my $mangled_name = $class; + $mangled_name =~ s/:+/_/g; + my $builder = "build_fields_for_type_${mangled_name}"; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); + last CONSTRAINT; + } + } + } + if (defined($name)) { + unless (defined($base_name)) { + $base_name = "(anon subtype of ${name})"; + } + my $mangled_name = $name; + $mangled_name =~ s/:+/_/g; + my $builder = "build_fields_for_type_${mangled_name}"; + if ($self->can($builder)) { + @fields = $self->$builder($attr, $args); + last CONSTRAINT; + } + } + $constraint = $constraint->parent; + } + if (!defined($constraint)) { + confess "Can't build field ${attr_name} of type ${base_name} without $builder method or build_fields_for_type_<type> method for type or any supertype"; + } + } else { + confess "Can't build field ${attr} without $builder method or type constraint"; + } + return @fields; + }; + + implements build_field_map => as { + confess "Lazy field map building not supported by default"; + }; + + implements build_simple_field => as { + my ($self, $class, $attr, $args) = @_; + my $attr_name = $attr->name; + my %extra; + if (my $config = $args->{Field}{$attr_name}) { + %extra = %$config; + } + my $field = $class->new( + object => $self->object, + attribute => $attr, + name => $attr->name, + location => join('-', $self->location, 'field', $attr->name), + ctx => $self->ctx, + %extra + ); + return ($attr_name => $field); + }; + + implements build_fields_for_type_Num => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Number, $attr, $args); + }; + + implements build_fields_for_type_Int => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Number, $attr, $args); + }; + + implements build_fields_for_type_Bool => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Boolean, $attr, $args); + }; + + implements build_fields_for_type_Password => as { return }; + + implements build_fields_for_type_Str => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(String, $attr, $args); + }; + + implements build_fields_for_type_SimpleStr => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(String, $attr, $args); + }; + + implements build_fields_for_type_DateTime => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(DateTime, $attr, $args); + }; + + implements build_fields_for_type_Enum => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(String, $attr, $args); + }; + + + implements build_fields_for_type_ArrayRef => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(List, $attr, $args) + }; + + #todo dirty hack need generic collection object + #if a collection wasnt a resultset that'd be good. + implements build_fields_for_type_Reaction_InterfaceModel_DBIC_Collection => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(Collection, $attr, $args) + }; + + implements build_fields_for_type_Reaction_InterfaceModel_Object => as { + my ($self, $attr, $args) = @_; + return $self->build_simple_field(RelatedObject, $attr, $args); + }; + + + no Moose; + + no strict 'refs'; + delete ${__PACKAGE__ . '::'}{inner}; + +}; + +1; diff --git a/lib/Reaction/UI/ViewPort/TimeRangeCollection.pm b/lib/Reaction/UI/ViewPort/TimeRangeCollection.pm new file mode 100644 index 0000000..eb1b680 --- /dev/null +++ b/lib/Reaction/UI/ViewPort/TimeRangeCollection.pm @@ -0,0 +1,390 @@ +package Reaction::UI::ViewPort::TimeRangeCollection; + +use Reaction::Class; +use Reaction::Types::DateTime; +use Moose::Util::TypeConstraints (); +use DateTime::Event::Recurrence; +use aliased 'Reaction::UI::ViewPort::Field::String'; +use aliased 'Reaction::UI::ViewPort::Field::DateTime'; +use aliased 'Reaction::UI::ViewPort::Field::HiddenArray'; +use aliased 'Reaction::UI::ViewPort::Field::TimeRange'; + +class TimeRangeCollection is 'Reaction::UI::ViewPort', which { + + has '+layout' => (default => 'timerangecollection'); + + has '+column_order' => ( + default => sub{[ qw/ time_from time_to pattern repeat_from repeat_to / ]}, + ); + + has time_from => ( + isa => 'Reaction::UI::ViewPort::Field::DateTime', + is => 'rw', lazy_build => 1, + ); + + has time_to => ( + isa => 'Reaction::UI::ViewPort::Field::DateTime', + is => 'rw', lazy_build => 1, + ); + + has repeat_from => ( + isa => 'Reaction::UI::ViewPort::Field::DateTime', + is => 'rw', lazy_build => 1, + ); + + has repeat_to => ( + isa => 'Reaction::UI::ViewPort::Field::DateTime', + is => 'rw', lazy_build => 1, + ); + + has pattern => ( + isa => 'Reaction::UI::ViewPort::Field::String', + # valid_values => [ qw/none daily weekly monthly/ ], + is => 'rw', lazy_build => 1, + ); + + has range_vps => (isa => 'ArrayRef', is => 'rw', lazy_build => 1,); + + has max_range_vps => (isa => 'Int', is => 'rw', lazy_build => 1,); + + has error => ( + isa => 'Str', + is => 'rw', + required => 0, + ); + + has field_names => ( + isa => 'ArrayRef', is => 'rw', + lazy_build => 1, clearer => 'clear_field_names', + ); + + has _field_map => ( + isa => 'HashRef', is => 'rw', init_arg => 'fields', + clearer => '_clear_field_map', + predicate => '_has_field_map', + set_or_lazy_build('field_map'), + ); + + has on_next_callback => ( + isa => 'CodeRef', + is => 'rw', + predicate => 'has_on_next_callback', + ); + + implements fields => as { shift->_field_map }; + + implements build_range_vps => as { [] }; + + implements spanset => as { + my ($self) = @_; + my $spanset = DateTime::SpanSet->empty_set; + $spanset = $spanset->union($_->value) for @{$self->range_vps}; + return $spanset; + }; + + implements range_strings => as { + my ($self) = @_; + return [ map { $_->value_string } @{$self->range_vps} ]; + }; + + implements remove_range_vp => as { + my ($self, $to_remove) = @_; + $self->range_vps([ grep { $_ != $to_remove } @{$self->range_vps} ]); + $self->_clear_field_map; + $self->clear_field_names; + }; + + implements add_range_vp => as { + my ($self) = @_; + if ($self->can_add) { + $self->_clear_field_map; + $self->clear_field_names; + my @span_info = ( + $self->time_from->value, + $self->time_to->value, + (map { $_->has_value ? $_->value : '' } + map { $self->$_ } qw/repeat_from repeat_to/), + $self->pattern->value, + ); + my $encoded_spanset = join ',', @span_info; + my $args = { + value_string => $encoded_spanset, + parent => $self + }; + my $count = scalar(@{$self->range_vps}); + my $field = $self->build_simple_field(TimeRange, 'range-'.$count, $args); + my $d = DateTime::Format::Duration->new( pattern => '%s' ); + if ($d->format_duration( $self->spanset->intersection($field->value)->duration ) > 0) { + # XXX - Stop using the stash here? + $self->ctx->stash->{warning} = 'Warning: Most recent time range overlaps '. + 'with existing time range in this booking.'; + } + #warn "encoded spanset = $encoded_spanset\n"; + #warn "current range = ".join(', ', (@{$self->range_vps}))."\n"; + push(@{$self->range_vps}, $field); + } + }; + + implements build_field_map => as { + my ($self) = @_; + my %map; + foreach my $field (@{$self->range_vps}) { + $map{$field->name} = $field; + } + foreach my $name (@{$self->column_order}) { + $map{$name} = $self->$name; + } + return \%map; + }; + + implements build_field_names => as { + my ($self) = @_; + return [ + (map { $_->name } @{$self->range_vps}), + @{$self->column_order} + ]; + }; + + implements can_add => as { + my ($self) = @_; + my $error; + if ($self->time_to->has_value && $self->time_from->has_value) { + my $time_to = $self->time_to->value; + my $time_from = $self->time_from->value; + + my ($pattern, $repeat_from, $repeat_to) = ('','',''); + $pattern = $self->pattern->value if $self->pattern->has_value; + $repeat_from = $self->repeat_from->value if $self->repeat_from->has_value; + $repeat_to = $self->repeat_to->value if $self->repeat_to->has_value; + + my $duration = $time_to - $time_from; + if ($time_to < $time_from) { + $error = 'Please make sure that the Time To is after the Time From.'; + } elsif ($time_to == $time_from) { + $error = 'Your desired booking slot is too small.'; + } elsif ($pattern && $pattern ne 'none') { + my %pattern = (hourly => [ hours => 1 ], + daily => [ days => 1 ], + weekly => [ days => 7 ], + monthly => [ months => 1 ]); + my $pattern_comp = DateTime::Duration->compare( + $duration, DateTime::Duration->new( @{$pattern{$pattern}} ) + ); + if (!$repeat_to || !$repeat_from) { + $error = 'Please make sure that you enter a valid range for the '. + 'repetition period.'; + } elsif ($time_to == $time_from) { + $error = 'Your desired repetition period is too short.'; + } elsif ($repeat_to && ($repeat_to < $repeat_from)) { + $error = 'Please make sure that the Repeat To is after the Repeat From.'; + } elsif ( ( ($pattern eq 'hourly') && ($pattern_comp > 0) ) || + ( ($pattern eq 'daily') && ($pattern_comp > 0) ) || + ( ($pattern eq 'weekly') && ($pattern_comp > 0) ) || + ( ($pattern eq 'monthly') && ($pattern_comp > 0) ) ) { + $error = "Your repetition pattern ($pattern) is too short for your ". + "desired booking length."; + } + } + } else { + $error = 'Please complete both the Time To and Time From fields.'; + } + $self->error($error); + return !defined($error); + }; + + implements build_simple_field => as { + my ($self, $class, $name, $args) = @_; + return $class->new( + name => $name, + location => join('-', $self->location, 'field', $name), + ctx => $self->ctx, + %$args + ); + }; + + implements build_time_to => as { + my ($self) = @_; + return $self->build_simple_field(DateTime, 'time_to', {}); + }; + + implements build_time_from => as { + my ($self) = @_; + return $self->build_simple_field(DateTime, 'time_from', {}); + }; + + implements build_repeat_to => as { + my ($self) = @_; + return $self->build_simple_field(DateTime, 'repeat_to', {}); + }; + + implements build_repeat_from => as { + my ($self) = @_; + return $self->build_simple_field(DateTime, 'repeat_from', {}); + }; + + implements build_pattern => as { + my ($self) = @_; + return $self->build_simple_field(String, 'pattern', {}); + }; + + implements next => as { + $_[0]->on_next_callback->(@_); + }; + + override accept_events => sub { + my $self = shift; + ('add_range_vp', ($self->has_on_next_callback ? ('next') : ()), super()); + }; + + override child_event_sinks => sub { + my ($self) = @_; + return ((grep { ref($_) =~ 'Hidden' } values %{$self->_field_map}), + (grep { ref($_) !~ 'Hidden' } values %{$self->_field_map}), + super()); + }; + + override apply_events => sub { + my ($self, $ctx, $events) = @_; + + # auto-inflate range fields based on number from hidden field + + my $max = $events->{$self->location.':max_range_vps'}; + my @range_vps = map { + TimeRange->new( + name => "range-$_", + location => join('-', $self->location, 'field', 'range', $_), + ctx => $self->ctx, + parent => $self, + ) + } ($max ? (0 .. $max - 1) : ()); + $self->range_vps(\@range_vps); + $self->_clear_field_map; + $self->clear_field_names; + + # call original event handling + + super(); + + # repack range VPs in case of deletion + + my $prev_idx = -1; + + foreach my $vp (@{$self->range_vps}) { + my $cur_idx = ($vp->name =~ m/range-(\d+)/); + if (($cur_idx - $prev_idx) > 1) { + $cur_idx--; + my $name = "range-${cur_idx}"; + $vp->name($name); + $vp->location(join('-', $self->location, 'field', $name)); + } + $prev_idx = $cur_idx; + } + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::ViewPort::TimeRangeCollection + +=head1 SYNOPSIS + + my $trc = $self->push_viewport(TimeRangeCollection, + layout => 'avail_search_form', + on_apply_callback => $search_callback, + name => 'TRC', + ); + +=head1 DESCRIPTION + +=head1 ATTRIBUTES + +=head2 can_add + +=head2 column_order + +=head2 error + +=head2 field_names + +=head2 fields + +=head2 layout + +=head2 pattern + +Typically either: none, daily, weekly or monthly + +=head2 max_range_vps + +=head2 range_vps + +=head2 repeat_from + +A DateTime field. + +=head2 repeat_to + +A DateTime field. + +=head2 time_from + +A DateTime field. + +=head2 time_to + +A DateTime field. + +=head1 METHODS + +=head2 spanset + +Returns: $spanset consisting of all the TimeRange spans combined + +=head2 range_strings + +Returns: ArrayRef of Str consisting of the value_strings of all TimeRange +VPs + +=head2 remove_range_vp + +Arguments: $to_remove + +=head2 add_range_vp + +Arguments: $to_add + +=head2 build_simple_field + +Arguments: $class, $name, $args +where $class is an object, $name is a scalar and $args is a hashref + +=head2 next + +=head2 on_next_callback + +=head2 clear_field_names + +=head2 child_event_sinks + +=head1 SEE ALSO + +=head2 L<Reaction::UI::ViewPort> + +=head2 L<Reaction::UI::ViewPort::Field::TimeRange> + +=head2 L<Reaction::UI::ViewPort::Field::DateTime> + +=head2 L<DateTime::Event::Recurrence> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/Widget.pm b/lib/Reaction/UI/Widget.pm new file mode 100644 index 0000000..75cfae4 --- /dev/null +++ b/lib/Reaction/UI/Widget.pm @@ -0,0 +1,41 @@ +package Reaction::UI::Widget; + +use Reaction::Class; +use aliased 'Reaction::UI::ViewPort'; +use aliased 'Reaction::UI::View'; + +class Widget which { + + has 'viewport' => (isa => ViewPort, is => 'ro'); # required? + has 'view' => (isa => View, is => 'ro', required => 1); + + implements 'render' => as { + my ($self, $rctx) = @_; + $self->render_widget($rctx, { self => $self }); + }; + + implements 'render_viewport' => as { + my ($self, $rctx, $args) = @_; + my $vp = $args->{'_'}; + $self->view->render_viewport($rctx, $vp); + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::Widget + +=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/UI/Widget/ListView.pm b/lib/Reaction/UI/Widget/ListView.pm new file mode 100644 index 0000000..ab80d93 --- /dev/null +++ b/lib/Reaction/UI/Widget/ListView.pm @@ -0,0 +1,54 @@ +package Reaction::UI::Widget::ListView; + +use Reaction::UI::WidgetClass; +use aliased 'Reaction::UI::ViewPort::ListView' => 'ListView_VP'; + +class ListView which { + + has 'viewport' => (isa => ListView_VP, is => 'ro', required => 1); + + widget renders [ + qw(header body) => { viewport => func(self => 'viewport') } + ]; + + header renders [ header_entry over func(viewport => 'field_names') ]; + + header_entry renders [ string { $_{viewport}->field_label_map->{ $_ } } ]; + + body renders [ row over func(viewport => 'current_page_collection') ]; + + row renders [ + col_entry over func(viewport => 'field_names') => { row => $_ } + ]; + + col_entry renders [ + string { + my $proto = $_{row}->$_; + if (blessed($proto) && $proto->can('display_name')) { + return $proto->display_name; + } + return "${proto}"; + } + ]; + +}; + +1; + +=head1 NAME + +Reaction::UI::Widget::ListView + +=head1 DESCRIPTION + +=head2 viewport + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm new file mode 100644 index 0000000..9eadc35 --- /dev/null +++ b/lib/Reaction/UI/WidgetClass.pm @@ -0,0 +1,283 @@ +package Reaction::UI::WidgetClass; + +use Reaction::ClassExporter; +use Reaction::Class; +use Reaction::UI::Widget; +use Data::Dumper; + +no warnings 'once'; + +class WidgetClass, which { + + overrides exports_for_package => sub { + my ($self, $package) = @_; + return (super(), + func => sub { + my ($k, $m) = @_; + my $sig = "should be: func(data_key => 'method_name')"; + confess "Data key not present, ${sig}" unless defined($k); + confess "Data key must be string, ${sig}" unless !ref($k); + confess "Method name not present, ${sig}" unless defined($m); + confess "Method name must be string, ${sig}" unless !ref($m); + [ $k, $m ]; + }, # XXX zis is not ze grand design. OBSERVABLE. + string => sub (&) { -string => [ @_ ] }, # meh (maybe &;@ later?) + wrap => sub { $self->do_wrap_sub($package, @_); }, # should have class. + ); + }; + + overrides default_base => sub { ('Reaction::UI::Widget') }; + + overrides do_class_sub => sub { + my ($self, $package, $class) = @_; + # intercepts 'foo renders ...' + local *renders::AUTOLOAD = sub { + our $AUTOLOAD; + shift; + $AUTOLOAD =~ /^renders::(.*)$/; + $self->do_renders_meth($package, $class, $1, @_); + }; + # intercepts 'foo over ...' + local *over::AUTOLOAD = sub { + our $AUTOLOAD; + shift; + $AUTOLOAD =~ /^over::(.*)$/; + $self->do_over_meth($package, $class, $1, @_); + }; + # $_ returns '-topic:_', $_{foo} returns '-topic:foo' + local $_ = '-topic:_'; + my %topichash; + tie %topichash, 'Reaction::UI::WidgetClass::TopicHash'; + local *_ = \%topichash; + super; + }; + + implements do_wrap_sub => as { confess "Unimplemented" }; + + implements do_renders_meth => as { + my ($self, $package, $class, $fname, $content, $args, $extra) = @_; + + my $sig = 'should be: renders [ <content spec> ], \%args?'; + + confess "Too many args to renders, ${sig}" if defined($extra); + confess "First arg not an arrayref, ${sig}" unless ref($content) eq 'ARRAY'; + confess "Args must be hashref, ${sig}" + if (defined($args) && (ref($args) ne 'HASH')); + + $sig .= ' + where content spec is [ fragment_name over func(...), \%args? ] + or [ qw(list of fragment names), \%args ]'; # explain the mistake, yea + + my $inner_args = ((ref($content->[-1]) eq 'HASH') ? pop(@$content) : {}); + # [ blah over func(...), { ... } ] or [ qw(foo bar), { ... } ] + + # predeclare since content_gen gets populated somewhere in an if + # and inner_args_gen wants to be closed over by content_gen + + my ($content_gen, $inner_args_gen); + + my %args_extra; # again populated (possibly) within the if + + confess "Content spec invalid, ${sig}" + unless defined($content->[0]) && !ref($content->[0]); + + if (my ($key) = ($content->[0] =~ /^-(.*)?/)) { + + # if first content value is -foo, pull it off the front and then + # figure out is it's a type we know how to handle + + shift(@$content); + if ($key eq 'over') { # fragment_name over func + my ($fragment, $func) = @$content; + confess "Fragment name invalid, ${sig}" if ref($fragment); + my $content_meth = "render_${fragment}"; + # grab result of func + # - if arrayref, render fragment per entry + # - if obj and can('next') call that until undef + # - else scream loudly + my ($func_key, $func_meth) = @$func; + $content_gen = sub { + my ($widget, $args) = @_; + my $topic = eval { $args->{$func_key}->$func_meth }; + confess "Error calling ${func_meth} on ${func_key} argument " + .($args->{$func_key}||'').": $@" + if $@; + my $iter_sub; + if (ref $topic eq 'ARRAY') { + my @copy = @$topic; # non-destructive on original data + $iter_sub = sub { shift(@copy); }; + } elsif (Scalar::Util::blessed($topic) && $topic->can('next')) { + $iter_sub = sub { $topic->next }; + } else { + #confess "func(${func_key} => ${func_meth}) for topic within fragment ${fname} did not return arrayref or iterator object"; + # Coercing to a single-arg list instead for the mo. Mistake? + my @copy = ($topic); + $iter_sub = sub { shift(@copy); }; + } + my $inner_args = $inner_args_gen->($args); + return sub { + my $next = $iter_sub->(); + return undef unless $next; + return sub { + my ($rctx) = @_; + local $inner_args->{'_'} = $next; # ala local $_, why copy? + $widget->$content_meth($rctx, $inner_args); + }; + }; + }; + } elsif ($key eq 'string') { + + # string { ... } + + my $sub = $content->[0]->[0]; # string {} returns (-string => [ $cr ]) + $content_gen = sub { + my ($widget, $args) = @_; + my $done = 0; + my $inner_args = $inner_args_gen->($args); + return sub { + return if $done++; # a string content only happens once + return sub { # setup $_{foo} etc. and alias $_ to $_{_} + my ($rctx) = @_; + local *_ = \%{$inner_args}; + local $_ = $inner_args->{'_'}; + $sub->($rctx); + }; + }; + }; + + # must also handle just $_ later for wrap + } else { + # unrecognised -foo + confess "Unrecognised content spec type ${key}, ${sig}"; + } + } else { + + # handling the renders [ qw(list of frag names), \%args ] case + +#warn @$content; + confess "Invalid content spec, ${sig}" + if grep { ref($_) } @$content; + $content_gen = sub { + my ($widget, $args) = @_; + my @fragment_methods = map { "render_${_}" } @$content; + my $inner_args = $inner_args_gen->($args); + return sub { + my $next = shift(@fragment_methods); + return undef unless $next; + return sub { + my ($rctx) = @_; + $widget->$next($rctx, $inner_args); + }; + }; + }; + + foreach my $key (@$content) { + my $frag_meth = "render_${key}"; + $args_extra{$key} = sub { + my ($widget, $args) = @_; + my $inner_args = $inner_args_gen->($args); + return sub { + my ($rctx) = @_; + $widget->$frag_meth($rctx, $inner_args); + }; + }; + } + } + + # populate both args generators here primarily for clarity + + my $args_gen = $self->mk_args_generator($args); + $inner_args_gen = $self->mk_args_generator($inner_args); + + my $methname = "render_${fname}"; + + $args_extra{'_'} = $content_gen; + + my @extra_keys = keys %args_extra; + my @extra_gen = values %args_extra; + + my $meth = sub { + my ($self, $rctx, $args) = @_; + confess "No rendering context passed" unless $rctx; + my $r_args = $args_gen->($args); +#warn Dumper($r_args).' '; + @{$r_args}{@extra_keys} = map { $_->($self, $args); } @extra_gen; + $r_args->{'_'} = $content_gen->($self, $args); +#warn Dumper($r_args).' '; + $rctx->render($fname, $r_args); + }; + + $class->meta->add_method($methname => $meth); + }; + + implements do_over_meth => as { + my ($self, $package, $class, @args) = @_; + #warn Dumper(\@args); + return (-over => @args); + }; + + implements mk_args_generator => as { + my ($self, $argspec) = @_; +#warn Dumper($argspec); + # only handling [ $k, $v ] (func()) and -topic:$x ($_{$x}) for the moment + + my $sig = 'should be: key => $_ or key => $_{name} or key => func("name", "method")'; + + my (@func_to, @func_spec, @copy_from, @copy_to); + foreach my $key (keys %$argspec) { + my $val = $argspec->{$key}; + if (ref($val) eq 'ARRAY') { + push(@func_spec, $val); + push(@func_to, $key); + } elsif (!ref($val) && ($val =~ /^-topic:(.*)$/)) { + my $topic_key = $1; + push(@copy_from, $topic_key); + push(@copy_to, $key); + } else { + confess "Invalid args member for ${key}, ${sig}"; + } + } +#warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to); + return sub { + my ($outer_args) = @_; + my $args = { %$outer_args }; +#warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to).' '; + @{$args}{@copy_to} = @{$outer_args}{@copy_from}; + @{$args}{@func_to} = (map { + my ($key, $meth) = @{$_}; + $outer_args->{$key}->$meth; # [ 'a, 'b' ] ~~ ->{'a'}->b + } @func_spec); +#warn Dumper($args).' '; + return $args; + }; + }; + +}; + +package Reaction::UI::WidgetClass::TopicHash; + +use Tie::Hash; +use base qw(Tie::StdHash); + +sub FETCH { + my ($self, $key) = @_; + return "-topic:${key}"; +} + +1; + +=head1 NAME + +Reaction::UI::WidgetClass + +=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/UI/Window.pm b/lib/Reaction/UI/Window.pm new file mode 100644 index 0000000..ecf1e57 --- /dev/null +++ b/lib/Reaction/UI/Window.pm @@ -0,0 +1,292 @@ +package Reaction::UI::Window; + +use Reaction::Class; +use Reaction::UI::FocusStack; + +class Window which { + + has ctx => (isa => 'Catalyst', is => 'ro', required => 1); + has view_name => (isa => 'Str', is => 'ro', lazy_fail => 1); + has content_type => (isa => 'Str', is => 'ro', lazy_fail => 1); + has title => (isa => 'Str', is => 'rw', default => sub { 'Untitled window' }); + has view => ( + # XXX compile failure because the Catalyst::View constraint would be + # auto-generated which doesn't work with unions. ::Types::Catalyst needed. + #isa => 'Catalyst::View|Reaction::UI::View', + isa => 'Object', is => 'ro', lazy_build => 1 + ); + has focus_stack => ( + isa => 'Reaction::UI::FocusStack', + is => 'ro', required => 1, + default => sub { Reaction::UI::FocusStack->new }, + ); + + implements build_view => as { + my ($self) = @_; + return $self->ctx->view($self->view_name); + }; + + implements flush => as { + my ($self) = @_; + $self->flush_events; + $self->flush_view; + }; + + implements flush_events => as { + my ($self) = @_; + my $ctx = $self->ctx; + foreach my $type (qw/query body/) { + my $meth = "${type}_parameters"; + my $param_hash = $ctx->req->$meth; + $self->focus_stack->apply_events($ctx, $param_hash); + } + }; + + implements flush_view => as { + my ($self) = @_; + return if $self->ctx->res->status =~ /^3/ || length($self->ctx->res->body); + $self->ctx->res->body( + $self->view->render_window($self) + ); + $self->ctx->res->content_type($self->content_type); + }; + + # required by old Renderer::XHTML + + implements render_viewport => as { + my ($self, $vp) = @_; + return unless $vp; + return $self->view->render_viewport($self, $vp); + }; + +}; + +1; + +=head1 NAME + +Reaction::UI::Window - Container for rendering the UI elements in + +=head1 SYNOPSIS + + my $window = Reaction::UI::Window->new( + ctx => $ctx, + view_name => $view_name, + content_type => $content_type, + title => $window_title, + ); + + # More commonly, as Reaction::UI::RootController creates one for you: + my $window = $ctx->stash->{window}; + + # Resolve current events and render the view of the UI + # elements of this Window: + # This is called by the end action of Reaction::UI::RootController + $window->flush(); + + # Resolve current events: + $window->flush_events(); + + # Render the top ViewPort in the FocusStack of this Window: + $window->flush_view(); + + # Render a particular ViewPort: + $window->render_viewport($viewport); + + # Or in a template: + [% window.render_viewport(self.inner) %] + + # Add a ViewPort to the UI: + $window->focus_stack->push_viewport('Reaction::UI::ViewPort'); + +=head1 DESCRIPTION + +A Window object is created and stored in the stash by +L<Reaction::UI::RootController>, it is used to contain all the +elements (ViewPorts) that make up the UI. The Window is rendered in +the end action of the RootController to make up the page. + +To add L<ViewPorts|Reaction::UI::ViewPort> to the stack, read the +L<Reaction::UI::FocusStack> and L<Reaction::UI::ViewPort> documentation. + +Several Window attributes are set by +L<Reaction::UI::RootController/begin> when a new Window is created, +these are as follows: + +=over + +=item ctx + +The current L<Catalyst> context object is set. + +=item view_name + +The view_name is set from the L<Reaction::UI::RootController> attributes. + +=item content_type + +The content_type is set from the L<Reaction::UI::RootController> attributes. + +=item window_title + +The window_title is set from the L<Reaction::UI::RootController> attributes. + +=back + +=head1 METHODS + +=head2 ctx + +=over + +=item Arguments: none + +=back + +Retrieve the current L<Catalyst> context object. + +=head2 view_name + +=over + +=item Arguments: none + +=back + +Retrieve the name of the L<Catalyst::View> component used to render +this Window. If this has not been set, rendering the Window will fail. + +=head2 content_type + +=over + +=item Arguments: none + +=back + +Retrieve the content_type for the page. If this has not been set, +rendering the Window will fail. + +=head2 title + +=over + +=item Arguments: $title? + +=back + + [% window.title %] + +Retrieve the title of this page, if not set, it will default to +"Untitled window". + +=head2 view + +=over + +=item Arguments: none + +=back + +Retrieve the L<Catalyst::View> instance, this can be set, or will be +instantiated using the L<view_name> class. + +=head2 focus_stack + +=over + +=item Arguments: none + +=back + + $window->focus_stack->push_viewport('Reaction::UI::ViewPort'); + +Retrieve the L<stack|Reaction::UI::FocusStack> of +L<ViewPorts|Reaction::UI::ViewPorts> that contains all the UI elements +for this Window. Use L<Reaction::UI::FocusStack/push_viewport> on this +to create more elements. An empty FocusStack is created by the +RootController when the Window is created. + +=head2 render_viewport + +=over + +=item Arguments: $viewport + +=back + + $window->render_viewport($viewport); + + [% window.render_viewport(self.inner) %] + +Calls render on the L<view> object used by this Window. The following +arguments are given: + +=over + +=item ctx + +The L<Catalyst> context object. + +=item self + +The ViewPort object to be rendered. + +=item window + +The Window object. + +=item type + +The string that describes the layout from L<Reaction::UI::ViewPort/layout>. + +=back + +=head2 flush + +=over + +=item Arguments: none + +=back + +Synchronize the current events with all the L<Reaction::UI::ViewPort> +objects in the UI, then render the root ViewPort. This is called for +you by L<Reaction::UI::RootController/end>. + +=head2 flush_events + +=over + +=item Arguments: none + +=back + +Resolves all the current events, first the query parameters then the +body parameters, with all the L<Reaction::UI::ViewPort> objects in the +UI. This calls L<Reaction::UI::FocusStack/apply_events>. This method +is called by L<flush>. + +=head2 flush_view + +=over + +=item Arguments: none + +=back + +Renders the page into the L<Catalyst::Response> body, unless the +response status is already set to 3xx, or the body has already been +filled. This calls L<render_viewport> with the root +L<Reaction::UI::ViewPort> from the L<focus_stack>. This method is +called by L<flush>. + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut |