diff options
199 files changed, 13209 insertions, 0 deletions
@@ -0,0 +1,4 @@ +This file documents the revision history for Perl extension ComponentUI. + +0.01 2006-08-01 17:49:50 + - initial revision, generated by Catalyst diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..10c77a4 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,41 @@ +# Avoid version control files. +\bRCS\b +\bCVS\b +,v$ +\B\.svn\b + +# Avoid Makemaker generated and utility files. +\bMakefile$ +\bblib +\bMakeMaker-\d +\bpm_to_blib$ +\bblibdirs$ +^MANIFEST\.SKIP$ + +# for developers only :) +^TODO$ +^VERSIONING\.SKETCH$ + +# Avoid Module::Build generated and utility files. +\bBuild$ +\b_build + +# Avoid temp and backup files. +~$ +\.tmp$ +\.old$ +\.bak$ +\#$ +\b\.# + +# avoid OS X finder files +\.DS_Store$ + +# Don't ship the test db +^t/var + +# Don't ship the last dist we built :) +\.tar\.gz$ + +# Skip maint stuff +^maint/ diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..aec5ca2 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,37 @@ +use inc::Module::Install 0.64; + +name 'ComponentUI'; +all_from 'lib/ComponentUI.pm'; + +requires 'Catalyst' => '5.7002'; +requires 'Catalyst::Plugin::ConfigLoader' => 0; +requires 'Catalyst::Plugin::Static::Simple' => 0; +requires 'Catalyst::Plugin::I18N' => 0; +requires 'Catalyst::Model::DBIC::Schema' => 0; +requires 'Catalyst::View::TT' => '0.23'; +requires 'Catalyst::Controller::BindLex' => 0; +requires 'Config::General' => 0; +requires 'Test::Class' => 0; +requires 'Test::Memory::Cycle' => 0; +requires 'DBIx::Class' => '0.07001'; +requires 'SQL::Translator' => '0.08'; +requires 'Moose' => '0.22'; +requires 'aliased' => 0; +requires 'DateTime'; +requires 'DateTime::Span'; +requires 'DateTime::Event::Recurrence'; +requires 'DateTime::Format::MySQL'; +requires 'Time::ParseDate'; +requires 'Email::Valid'; +requires 'Digest::MD5'; +requires 'Email::Send'; +requires 'Email::MIME'; +requires 'Email::MIME::Creator'; +requires 'Text::CSV_XS'; + +catalyst; + +install_script glob('script/*.pl'); + +auto_install; +WriteAll; @@ -0,0 +1,10 @@ +This is the Reaction MVC Platform. + +How to get to playing fast: + +perl Makefile.PL +make installdeps +make test # we're pre-0.01, some may fail +script/componentui_server.pl + +This library is free software under the same terms as perl itself. diff --git a/componentui.conf b/componentui.conf new file mode 100644 index 0000000..2d43094 --- /dev/null +++ b/componentui.conf @@ -0,0 +1,11 @@ +using_frontend_proxy 1 + +<Controller Foo> + <action update> + <ViewPort> + <Field baz_list> + layout checkbox_group + </Field> + </ViewPort> + </Action> +</Controller> diff --git a/lab/Reaction/Class.pm b/lab/Reaction/Class.pm new file mode 100644 index 0000000..f961baf --- /dev/null +++ b/lab/Reaction/Class.pm @@ -0,0 +1,82 @@ +=head1 NAME + +Reaction::Class - Reaction class declaration syntax + +=head1 SYNOPSIS + +In My/Person.pm: + +=for example My::Person setup + + package My::Person; + + use Reaction::Class; + use Reaction::Types::Core qw/Str/; + + class Person which { + + has 'name' => Str; + + has 'nickname' => optional Str; + + implements 'preferred_name' which { + accepts nothing; + returns Str; + guarantees when { $self->has_nickname } returns { $self->nickname }; + guarantees when { !$self->has_nickname } returns { $self->name }; + } with { + return ($self->has_nickname ? $self->nickname : $self->name); + }; + + }; + +=for example My::Person tests + +=begin tests + +my $meta = My::Person->meta; + +isa_ok($meta, 'Reaction::Meta::Class'); + +my $attr_map = $meta->get_attribute_map; + +foreach my $attr_name (qw/name nickname/) { + isa_ok($attr_map->{$attr_name}, 'Reaction::Meta::Attribute'); +} + +ok($attr_map->{name}->is_required, 'name is required'); +ok(!$attr_map->{nickname}->is_required, 'nickname is optional'); + +=end tests + +In your code - + +=for example My::Person usage + + my $jim = My::Person->new(name => 'Jim'); + + print $jim->name."\n"; # prints "Jim\n" + + print $jim->preferred_name."\n"; # prints "Jim\n" + + $jim->name('James'); # returns 'James' + + $jim->nickname('Jim'); # returns 'Jim' + + print $jim->preferred_name."\n"; # prints "Jim\n" + + $jim->preferred_name('foo'); # throws Reaction::Exception::MethodArgumentException + +=for example My::Person end + +=head1 DESCRIPTION + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut diff --git a/lib/ComponentUI.pm b/lib/ComponentUI.pm new file mode 100644 index 0000000..f1938c5 --- /dev/null +++ b/lib/ComponentUI.pm @@ -0,0 +1,61 @@ +package ComponentUI; + +use strict; +use warnings; + +use Catalyst::Runtime '5.70'; + +# Set flags and add plugins for the application +# +# -Debug: activates the debug mode for very useful log messages +# ConfigLoader: will load the configuration from a YAML file in the +# application's home directory +# Static::Simple: will serve static files from the application's root +# directory + +use Catalyst qw/-Debug ConfigLoader Static::Simple I18N/; + +our $VERSION = '0.01'; + +# Configure the application. +# +# Note that settings in ComponentUI.yml (or other external +# configuration file that you set up manually) take precedence +# over this when using ConfigLoader. Thus configuration +# details given here can function as a default configuration, +# with a external configuration file acting as an override for +# local deployment. + +__PACKAGE__->config( name => 'ComponentUI' ); + +# Start the application +__PACKAGE__->setup; + + +=head1 NAME + +ComponentUI - Catalyst based application + +=head1 SYNOPSIS + + script/componentui_server.pl + +=head1 DESCRIPTION + +[enter your description here] + +=head1 SEE ALSO + +L<ComponentUI::Controller::Root>, L<Catalyst> + +=head1 AUTHORS + +See L<Reaction::Class> for authors. + +=head1 LICENSE + +See L<Reaction::Class> for the license. + +=cut + +1; diff --git a/lib/ComponentUI/Controller/Bar.pm b/lib/ComponentUI/Controller/Bar.pm new file mode 100644 index 0000000..7f9d6c3 --- /dev/null +++ b/lib/ComponentUI/Controller/Bar.pm @@ -0,0 +1,17 @@ +package ComponentUI::Controller::Bar; + +use strict; +use warnings; +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestDB', + model_name => 'Bar', + action => { base => { Chained => '/base', PathPart => 'bar' }, + list => { ViewPort => { layout => 'bar_list' } }, + update => { ViewPort => { layout => 'bar_form' } }, + create => { ViewPort => { layout => 'bar_form' } } }, +); + +1; diff --git a/lib/ComponentUI/Controller/Baz.pm b/lib/ComponentUI/Controller/Baz.pm new file mode 100644 index 0000000..6d8e932 --- /dev/null +++ b/lib/ComponentUI/Controller/Baz.pm @@ -0,0 +1,14 @@ +package ComponentUI::Controller::Baz; + +use strict; +use warnings; +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestDB', + model_name => 'Baz', + action => { base => { Chained => '/base', PathPart => 'baz' } }, +); + +1; diff --git a/lib/ComponentUI/Controller/Foo.pm b/lib/ComponentUI/Controller/Foo.pm new file mode 100644 index 0000000..88503a5 --- /dev/null +++ b/lib/ComponentUI/Controller/Foo.pm @@ -0,0 +1,14 @@ +package ComponentUI::Controller::Foo; + +use strict; +use warnings; +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestDB', + model_name => 'Foo', + action => { base => { Chained => '/base', PathPart => 'foo' } }, +); + +1; diff --git a/lib/ComponentUI/Controller/Root.pm b/lib/ComponentUI/Controller/Root.pm new file mode 100644 index 0000000..1d7bd58 --- /dev/null +++ b/lib/ComponentUI/Controller/Root.pm @@ -0,0 +1,31 @@ +package ComponentUI::Controller::Root; + +use strict; +use warnings; +use base 'Reaction::UI::RootController'; +use Reaction::Class; + +use aliased 'Reaction::UI::ViewPort'; + +# +# Sets the actions in this controller to be registered with no prefix +# so they function identically to actions created in MyApp.pm +# +__PACKAGE__->config( + view_name => 'XHTML', + window_title => 'Reaction Test App', + content_type => 'text/html', + 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; diff --git a/lib/ComponentUI/Controller/TestModel/Bar.pm b/lib/ComponentUI/Controller/TestModel/Bar.pm new file mode 100644 index 0000000..2cf7681 --- /dev/null +++ b/lib/ComponentUI/Controller/TestModel/Bar.pm @@ -0,0 +1,15 @@ +package ComponentUI::Controller::TestModel::Bar; + +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestModel', + model_name => 'Bar', + action => { base => { Chained => '/base', PathPart => 'testmodel/bar' }, + list => { ViewPort => { layout => 'bar_list' } }, + update => { ViewPort => { layout => 'bar_form' } }, + create => { ViewPort => { layout => 'bar_form' } } }, +); + +1; diff --git a/lib/ComponentUI/Controller/TestModel/Baz.pm b/lib/ComponentUI/Controller/TestModel/Baz.pm new file mode 100644 index 0000000..ada76e4 --- /dev/null +++ b/lib/ComponentUI/Controller/TestModel/Baz.pm @@ -0,0 +1,12 @@ +package ComponentUI::Controller::TestModel::Baz; + +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestModel', + model_name => 'Baz', + action => { base => { Chained => '/base', PathPart => 'testmodel/baz' } }, +); + +1; diff --git a/lib/ComponentUI/Controller/TestModel/Foo.pm b/lib/ComponentUI/Controller/TestModel/Foo.pm new file mode 100644 index 0000000..846223e --- /dev/null +++ b/lib/ComponentUI/Controller/TestModel/Foo.pm @@ -0,0 +1,12 @@ +package ComponentUI::Controller::TestModel::Foo; + +use base 'Reaction::UI::CRUDController'; +use Reaction::Class; + +__PACKAGE__->config( + model_base => 'TestModel', + model_name => 'Foo', + action => { base => { Chained => '/base', PathPart => 'testmodel/foo' } }, +); + +1; diff --git a/lib/ComponentUI/Model/Action.pm b/lib/ComponentUI/Model/Action.pm new file mode 100644 index 0000000..9c03bb5 --- /dev/null +++ b/lib/ComponentUI/Model/Action.pm @@ -0,0 +1,16 @@ +package ComponentUI::Model::Action; + +use Reaction::Class; + +use lib 't/lib'; +use RTest::TestDB; + +use aliased 'Reaction::InterfaceModel::Action::DBIC::ActionReflector'; + +my $r = ActionReflector->new; + +$r->reflect_actions_for('RTest::TestDB::Foo' => __PACKAGE__); +$r->reflect_actions_for('RTest::TestDB::Bar' => __PACKAGE__); +$r->reflect_actions_for('RTest::TestDB::Baz' => __PACKAGE__); + +1; diff --git a/lib/ComponentUI/Model/TestDB.pm b/lib/ComponentUI/Model/TestDB.pm new file mode 100644 index 0000000..c2ae892 --- /dev/null +++ b/lib/ComponentUI/Model/TestDB.pm @@ -0,0 +1,11 @@ +package ComponentUI::Model::TestDB; + +use lib 't/lib'; +use base qw/Catalyst::Model::DBIC::Schema/; + +__PACKAGE__->config( + schema_class => 'RTest::TestDB', + connect_info => [ 'dbi:SQLite:t/var/reaction_test_withdb.db' ] +); + +1; diff --git a/lib/ComponentUI/Model/TestModel.pm b/lib/ComponentUI/Model/TestModel.pm new file mode 100644 index 0000000..4e9732c --- /dev/null +++ b/lib/ComponentUI/Model/TestModel.pm @@ -0,0 +1,12 @@ +package ComponentUI::Model::TestModel; + +use lib 't/lib'; +use base 'Reaction::InterfaceModel::DBIC::ModelBase'; + +__PACKAGE__->config + ( + im_class => 'ComponentUI::TestModel', + db_dsn => 'dbi:SQLite:t/var/reaction_test_withdb.db', + ); + +1; diff --git a/lib/ComponentUI/TestModel.pm b/lib/ComponentUI/TestModel.pm new file mode 100644 index 0000000..98ebb22 --- /dev/null +++ b/lib/ComponentUI/TestModel.pm @@ -0,0 +1,19 @@ +package ComponentUI::TestModel; + +use lib 't/lib'; +use Reaction::InterfaceModel::DBIC::SchemaClass; + +class TestModel, which { + + domain_model '_testdb_schema' => + ( + isa => 'RTest::TestDB', + reflect => [ + 'Foo', + ['Bar' => 'ComponentUI::TestModel::Bars'], + ['Baz' => 'ComponentUI::TestModel::Baz', 'bazes' ], + ], + ); +}; + +1; diff --git a/lib/ComponentUI/TestModel/Bars.pm b/lib/ComponentUI/TestModel/Bars.pm new file mode 100644 index 0000000..0319400 --- /dev/null +++ b/lib/ComponentUI/TestModel/Bars.pm @@ -0,0 +1,21 @@ +package ComponentUI::TestModel::Bars; + +use lib 't/lib'; +use Reaction::InterfaceModel::DBIC::ObjectClass; + +class Bars, which{ + domain_model '_bars_store' => + (isa => 'RTest::TestDB::Bar', inflate_result => 1, + reflect => [qw(name foo published_at avatar)], + ); + + reflect_actions + ( + Create => { attrs =>[qw(name foo published_at avatar)] }, + Update => { attrs =>[qw(name foo published_at avatar)] }, + Delete => {}, + ); + +}; + +1; diff --git a/lib/ComponentUI/TestModel/Baz.pm b/lib/ComponentUI/TestModel/Baz.pm new file mode 100644 index 0000000..255673d --- /dev/null +++ b/lib/ComponentUI/TestModel/Baz.pm @@ -0,0 +1,21 @@ +package ComponentUI::TestModel::Baz; + +use lib 't/lib'; +use Reaction::InterfaceModel::DBIC::ObjectClass; + +class Baz, which{ + domain_model '_baz_store' => + (isa => 'RTest::TestDB::Baz', inflate_result => 1, + handles => ['display_name'], + reflect => [qw(id name foo_list)], + ); + + reflect_actions + ( + Create => { attrs =>[qw(name)] }, + Update => { attrs =>[qw(name)] }, + Delete => {}, + ); +}; + +1; diff --git a/lib/ComponentUI/TestModel/Foo.pm b/lib/ComponentUI/TestModel/Foo.pm new file mode 100644 index 0000000..73de6b6 --- /dev/null +++ b/lib/ComponentUI/TestModel/Foo.pm @@ -0,0 +1,22 @@ +package ComponentUI::TestModel::Foo; + +use lib 't/lib'; +use Reaction::InterfaceModel::DBIC::ObjectClass; + +class Foo, which{ + domain_model '_foo_store' => + (isa => 'RTest::TestDB::Foo', inflate_result => 1, + handles => ['display_name'], + reflect => [qw(id first_name last_name baz_list)], + ); + + reflect_actions + ( + Create => { attrs =>[qw(first_name last_name baz_list)] }, + Update => { attrs =>[qw(first_name last_name baz_list)] }, + Delete => {}, + CustomAction => { attrs =>[qw(last_name baz_list)] }, + ); +}; + +1; diff --git a/lib/ComponentUI/TestModel/Foo/Action/CustomAction.pm b/lib/ComponentUI/TestModel/Foo/Action/CustomAction.pm new file mode 100644 index 0000000..e6f3707 --- /dev/null +++ b/lib/ComponentUI/TestModel/Foo/Action/CustomAction.pm @@ -0,0 +1,9 @@ +package ComponentUI::TestModel::Foo::Action::CustomAction; + +use Reaction::Class; + +class CustomAction is 'Reaction::InterfaceModel::Action', which { + has first_name => (isa => 'NonEmptySimpleStr', is => 'rw', lazy_build => 1); +}; + +1; diff --git a/lib/ComponentUI/View/XHTML.pm b/lib/ComponentUI/View/XHTML.pm new file mode 100644 index 0000000..32a5c87 --- /dev/null +++ b/lib/ComponentUI/View/XHTML.pm @@ -0,0 +1,7 @@ +package ComponentUI::View::XHTML; + +use Reaction::Class; + +extends 'Reaction::UI::Renderer::XHTML'; + +1; 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 diff --git a/root/bar_form b/root/bar_form new file mode 100644 index 0000000..1eece03 --- /dev/null +++ b/root/bar_form @@ -0,0 +1,6 @@ +[% + +attrs.enctype = 'multipart/form-data'; +PROCESS form_base; + +%] diff --git a/root/bar_list b/root/bar_list new file mode 100644 index 0000000..ce57b74 --- /dev/null +++ b/root/bar_list @@ -0,0 +1,21 @@ +[% + +PROCESS listview; + +table_end_block = 'bar_list_table_end'; + +BLOCK bar_list_table_end; + + "\n</table>\n"; + include( 'create_link_block' ); + "\n<br />\n"; + + enctype = attrs.enctype || 'application/x-www-form-urlencoded'; + %]<form action="[% connect_form %]" method="post" enctype="[% enctype %]"[% + attrs.enctype = ''; process_attrs(self.attrs); '>'; + INCLUDE component type = 'search_base' attrs.value = 'xxx'; + "\n</form>"; + +END; + +%] diff --git a/root/base/actionform b/root/base/actionform new file mode 100644 index 0000000..ab5755b --- /dev/null +++ b/root/base/actionform @@ -0,0 +1 @@ +[% PROCESS form_base %] diff --git a/root/base/button b/root/base/button new file mode 100644 index 0000000..5e09c4d --- /dev/null +++ b/root/base/button @@ -0,0 +1,21 @@ +[% + +PROCESS field_base; + +main_block = 'button_control'; + +BLOCK button_control; + + %]<input type="[% button_type || 'submit' %]" [% + IF attrs.value == ''; + 'value="'; loc(self.value) | html; '" '; + END; + connect_control(self, self.event); + process_attrs(attrs) %] />[% +# IF self.img_src; +# INCLUDE component type = 'image'; +# ELSE; + +END; + +%] diff --git a/root/base/cancelbtn b/root/base/cancelbtn new file mode 100644 index 0000000..a9d8af0 --- /dev/null +++ b/root/base/cancelbtn @@ -0,0 +1,13 @@ +[% + +PROCESS button; + +control_block = 'cancelbtn_control'; + +BLOCK cancelbtn_control; + + INCLUDE button_control attrs.value = 'Cancel' self.event = 'close'; + +END; + +%] diff --git a/root/base/checkbox b/root/base/checkbox new file mode 100644 index 0000000..dd80d86 --- /dev/null +++ b/root/base/checkbox @@ -0,0 +1,22 @@ +[% + +PROCESS field_base; + +control_block = 'checkbox_control'; + +BLOCK checkbox_control; + + %]<input type="checkbox" id="[% id_attr %]" [% + connect_control(self, 'value'); + process_attrs(attrs); + IF self.value; + ' checked="checked"'; + END; + UNLESS attrs.value; + ' value="1"'; + END; + %] />[% + +END; + +%] diff --git a/root/base/checkbox_group b/root/base/checkbox_group new file mode 100644 index 0000000..52660b0 --- /dev/null +++ b/root/base/checkbox_group @@ -0,0 +1,19 @@ +[% + +PROCESS field_base; + +control_block = 'checkbox_group_control'; + +BLOCK checkbox_group_control; + + FOREACH v_name IN self.valid_value_names; + v_val = self.name_to_value_map.$v_name; + %]<input type="checkbox" id="[% id_attr %]" [% connect_control(self, 'value'); + ' value="'; v_val; '"'; + IF self.is_current_value(v_val); ' checked="checked"'; END; + process_attrs(attrs); ' />'; v_name; "\n"; + END; + +END; + +%] diff --git a/root/base/component b/root/base/component new file mode 100644 index 0000000..4f455ce --- /dev/null +++ b/root/base/component @@ -0,0 +1,64 @@ +[%- + +GLOBAL_DEBUG = ctx.debug; + +MACRO loc(text, args) BLOCK; + + ctx.localize(text, args); + +END; + +MACRO include(name, args) BLOCK; + + filename = ${name}; + + IF filename; + IF GLOBAL_DEBUG; + '<!-- Start block '; name | html; ' calling '; filename | html; " -->\n"; + END; + INCLUDE $filename args; + IF GLOBAL_DEBUG; + '<!-- End block '; name | html; " -->\n"; + END; + ELSE; + error = 'Chosen INCLUDE ' _ name _ ' is empty'; + THROW file error; + END; + +END; + +MACRO connect_form(vp, event) BLOCK; + + ''; + +END; + +MACRO connect_control(vp, event, value) BLOCK; + + 'name="'; vp.event_id_for(event); '"'; + +END; + +MACRO connect_href(vp, events) BLOCK; + + FOREACH event = events.keys; + evt_args.${vp.event_id_for(event)} = events.$event; + END; + 'href="'; ctx.req.uri_with(evt_args); '"'; + +END; + +UNLESS type; + errmsg = "type is empty rendering " _ self; + THROW file errmsg; +END; + +PROCESS $type; + +IF GLOBAL_DEBUG; '<!-- Rendering component '; type | html; " -->\n"; END; + +include( 'main_block' ); + +IF GLOBAL_DEBUG; '<!-- End component '; type | html; " -->\n"; END; + +-%] diff --git a/root/base/displayfield/list b/root/base/displayfield/list new file mode 100644 index 0000000..2dcf066 --- /dev/null +++ b/root/base/displayfield/list @@ -0,0 +1,17 @@ +[% + +PROCESS displayfield_base; + +control_block = 'list_control'; + +BLOCK list_control; + + "<ul>\n"; + FOREACH v_val IN self.value_names; + ' <li>'; v_val | html; "</li>\n"; + END; + "</ul>\n"; + +END; + +%] diff --git a/root/base/displayfield/string b/root/base/displayfield/string new file mode 100644 index 0000000..7fa3075 --- /dev/null +++ b/root/base/displayfield/string @@ -0,0 +1,13 @@ +[% + +PROCESS displayfield_base; + +control_block = 'string_control'; + +BLOCK string_control; + + self.value | html; + +END; + +%] diff --git a/root/base/displayfield/text b/root/base/displayfield/text new file mode 100644 index 0000000..dded894 --- /dev/null +++ b/root/base/displayfield/text @@ -0,0 +1,13 @@ +[% + +PROCESS displayfield_base; + +control_block = 'text_control'; + +BLOCK text_control; + + self.value | html; + +END; + +%] diff --git a/root/base/displayfield/value_string b/root/base/displayfield/value_string new file mode 100644 index 0000000..1277e83 --- /dev/null +++ b/root/base/displayfield/value_string @@ -0,0 +1,13 @@ +[% + +PROCESS displayfield_base; + +control_block = 'vstring_control'; + +BLOCK vstring_control; + + self.value_string | html; + +END; + +%] diff --git a/root/base/displayfield_base b/root/base/displayfield_base new file mode 100644 index 0000000..3fdcfca --- /dev/null +++ b/root/base/displayfield_base @@ -0,0 +1,23 @@ +[%- + +main_block = 'displayfield_base_field'; + +control_block = 'displayfield_base_control'; + +BLOCK displayfield_base_field; + + IF self.label; + '<label>'; loc(self.label); '</label>: '; + END; + + include( 'control_block' ); + +END; + +BLOCK displayfield_base_control; + + "CONTROL"; + +END; + +-%] diff --git a/root/base/dt_textfield b/root/base/dt_textfield new file mode 100644 index 0000000..749e3ca --- /dev/null +++ b/root/base/dt_textfield @@ -0,0 +1,16 @@ +[% + +PROCESS field_base; + +control_block = 'textfield_control'; + +BLOCK textfield_control; + + attrs.maxlength = '255'; # SimpleStr requires <= 255 + %]<input type="text" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, 'value_string'); + ' value="'; self.value_string | html; '"'; process_attrs(attrs) %] />[% + attrs.maxlength = ''; + +END; + +%] diff --git a/root/base/dual_select_group b/root/base/dual_select_group new file mode 100644 index 0000000..1cc5243 --- /dev/null +++ b/root/base/dual_select_group @@ -0,0 +1,42 @@ +[% + +PROCESS select_group; + +control_block = 'dual_select_group_control'; + +BLOCK dual_select_group_control; + + -%]</p><table[% process_attrs(attrs) %]> + <tr> + <td> +[%- self.label = ''; self.tmp_message = self.message; self.message = ''; + values_list_type = 'available_values'; + INCLUDE component type = 'select_group' self.hide_selected = 1 attrs.size = 10 attrs.name = 'add_values' | indent(4); + attrs.name = ''; attrs.size = ''; %] + </td><td align="center">[% + INCLUDE component type = 'submitbtn' attrs.value = '>>' self.event = 'add_all_values' | indent(4); + '<br />'; + INCLUDE component type = 'submitbtn' attrs.value = '>' self.event = 'do_add_values' | indent(4); + '<br />'; + INCLUDE component type = 'submitbtn' attrs.value = '<' self.event = 'do_remove_values' | indent(4); + '<br />'; + INCLUDE component type = 'submitbtn' attrs.value = '<<' self.event = 'remove_all_values' | indent(4); %] + </td><td> +[%- attrs.value = ''; + values_list_type = 'current_values'; + INCLUDE component type = 'select_group' self.hide_selected = 1 attrs.size = 10 attrs.name = 'remove_values' | indent(4); + attrs.name = ''; attrs.size = ''; + + FOREACH v_val IN self.current_values; + v_val = self.obj_to_str(v_val); + INCLUDE component type = 'hidden' self.val = v_val attrs = '' | indent(4); + END; + +# self.message = self.tmp_message; self.tmp_message = ''; %] + </td> + </tr>[% + %]</table><p>[% + +END; + +%] diff --git a/root/base/error_404 b/root/base/error_404 new file mode 100644 index 0000000..0177cba --- /dev/null +++ b/root/base/error_404 @@ -0,0 +1,17 @@ +[% + +main_block = 'error_404_main'; + +BLOCK error_404_main; + + loc("404 Not Found"); + + %] <a href="[% ctx.uri_for(ctx.action.chain.0.attributes.Chained.0) %]">[% + + loc("Return to root"); + + %]</a>[% + +END; + +%] diff --git a/root/base/field_base b/root/base/field_base new file mode 100644 index 0000000..3605a8c --- /dev/null +++ b/root/base/field_base @@ -0,0 +1,27 @@ +[%- + +main_block = 'field_base_field'; + +control_block = 'field_base_control'; + +BLOCK field_base_field; + + IF self.label; + '<label>'; loc(self.label); '</label>: '; + END; + + include( 'control_block' ); + + IF self.message; + "\n<span>"; loc(self.message); '</span>'; + END; + +END; + +BLOCK field_base_control; + + "CONTROL"; + +END; + +-%] diff --git a/root/base/fieldset b/root/base/fieldset new file mode 100644 index 0000000..7daa8be --- /dev/null +++ b/root/base/fieldset @@ -0,0 +1,20 @@ +[% + +PROCESS field_base; + +control_block = 'fieldset_control'; + +BLOCK fieldset_control; + + %]<fieldset id="[% self.field_name | html %]"[% process_attrs(attrs) %] />[% + IF self.text; + '<legend>'; self.text; '</legend>'; + END; + +# INCLUDE( 'control_block' ); + + %]</fieldset>[% + +END; + +%] diff --git a/root/base/file b/root/base/file new file mode 100644 index 0000000..c89c397 --- /dev/null +++ b/root/base/file @@ -0,0 +1,16 @@ +[% + +PROCESS field_base; + +control_block = 'fileselect_control'; + +BLOCK fileselect_control; + + %]<input type="file" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, 'value'); + # browsers ignore this for security reasons, can be uncommented for testing. + # ' value="'; self.value.filename | html; '"'; + process_attrs(attrs) %] />[% + +END; + +%] diff --git a/root/base/footer b/root/base/footer new file mode 100644 index 0000000..aa00551 --- /dev/null +++ b/root/base/footer @@ -0,0 +1,12 @@ +[%- + +#main_block = 'footer'; + +#BLOCK footer; + + %]<p>FOOTER</p> + [% + +#END; + +-%] diff --git a/root/base/form_base b/root/base/form_base new file mode 100644 index 0000000..cb988ec --- /dev/null +++ b/root/base/form_base @@ -0,0 +1,77 @@ +[% + +main_block = 'form_base_control'; + +control_block = 'form_base_control'; + +header_block = 'form_base_header'; +fields_block = 'form_base_fields'; +button_block = 'form_base_buttons'; +footer_block = 'form_base_footer'; + +form_id = 0; + +BLOCK form_base_control; + + form_id = form_id + 1; + + enctype = attrs.enctype || 'multipart/form-data'; + %]<form action="[% attrs.action || connect_form %]" method="post" id="element_[% form_id %]" enctype="[% enctype %]"[% + IF attrs.name != ""; ' name="'; attrs.name; attrs.name = ''; '"'; END; + attrs.enctype = ''; attrs.action = ''; + process_attrs(self.attrs) %]>[% "\n"; + + include( 'header_block' ); + include( 'fields_block' ); + + id_attr = ''; '<p>'; + include( 'button_block' ); + include( 'footer_block' ); + + "</p>\n</form>"; + +END; + +BLOCK form_base_header; + + ''; + +END; + +BLOCK form_base_fields; + + FOREACH f_name = self.field_names; + field = self.fields.$f_name; + id = form_id _ '_' _ loop.count; + '<p>'; window.render_viewport(field); "</p>\n"; + END; + +END; + +BLOCK form_base_buttons; + + allowed_events = self.accept_events; + + IF allowed_events.grep('^ok$').size; + INCLUDE component type = 'submitbtn' self.value = 'ok' self.event = 'ok' self.label = self.ok_label; + END; + + IF (self.field_names.size != 0) && (allowed_events.grep('^apply$').size); + INCLUDE component type = 'submitbtn' self.value = 'apply' self.event = 'apply' self.label = self.apply_label; + END; + + IF allowed_events.grep('^close$').size; + INCLUDE component type = 'cancelbtn' self.value = 'cancel' self.event = 'close' self.label = self.cancel_label; + END; + +END; + +BLOCK form_base_footer; + + IF self.message; + ' <span>'; self.message; '</span>'; + END; + +END; + +%] diff --git a/root/base/header b/root/base/header new file mode 100644 index 0000000..933457f --- /dev/null +++ b/root/base/header @@ -0,0 +1,11 @@ +[%- + +#main_block = 'header_block'; + +#BLOCK header_block; + + %]<p>HEADER</p>[% + +#END; + +-%] diff --git a/root/base/hidden b/root/base/hidden new file mode 100644 index 0000000..6b5f6c4 --- /dev/null +++ b/root/base/hidden @@ -0,0 +1,15 @@ +[% + +PROCESS field_base; + +control_block = 'hidden_control'; + +BLOCK hidden_control; + + name = attrs.name || 'value'; attrs.name = ''; + %]<input type="hidden" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, name); + ' value="'; self.val; '"'; process_attrs(attrs) %] />[% + +END; + +%] diff --git a/root/base/hiddenarray b/root/base/hiddenarray new file mode 100644 index 0000000..8168ad3 --- /dev/null +++ b/root/base/hiddenarray @@ -0,0 +1,17 @@ +[% + +PROCESS field_base; + +control_block = 'hiddenarray_control'; + +BLOCK hiddenarray_control; + + name = attrs.name || 'value'; attrs.name = ''; + FOREACH val IN self.value; + %]<input type="hidden" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, name); + ' value="'; val; '"'; process_attrs(attrs) %] />[% "\n"; + END; + +END; + +%] diff --git a/root/base/image b/root/base/image new file mode 100644 index 0000000..36cf927 --- /dev/null +++ b/root/base/image @@ -0,0 +1,11 @@ +[% + +main_block = 'image_base'; + +BLOCK image_base; + + %]<img src="[% self.img_src | html %]" alt="[% self.text | html %]"[% process_attrs(attrs) %] />[% + +END; + +%] diff --git a/root/base/label b/root/base/label new file mode 100644 index 0000000..e380ba0 --- /dev/null +++ b/root/base/label @@ -0,0 +1,17 @@ +[% + +PROCESS field_base; + +control_block = 'label_control'; + +BLOCK label_control; + + %]<label id="[% self.field_name | html %]" [% connect_control(self, 'value') %] value="[% self.field_value | html %]" />[% + +# INCLUDE( 'control_block' ); + + '</label>'; + +END; + +%] diff --git a/root/base/listview b/root/base/listview new file mode 100644 index 0000000..382630d --- /dev/null +++ b/root/base/listview @@ -0,0 +1,60 @@ +[% + +PROCESS listview_base; + +header_field_block = 'listview_header_field'; + +BLOCK listview_header_field; + + desc = 0; + IF (self.order_by == field_name && !self.order_by_desc); + desc = 1; + ELSE; + desc = 0; + END; + + "\n <th"; process_attrs(attrs); '><a '; connect_href(self, order_by => field_name, order_by_desc => desc); '>'; + loc(self.field_label(field_name)); '</a></th>'; + +END; + +header_block = 'listview_header'; + +BLOCK listview_header; + + INCLUDE listview_base_header; + IF self.row_action_prototypes.size; + %] + <th colspan="[% self.row_action_prototypes.size %]"[% + process_attrs(attrs); %]>[% loc('Actions'); %]</th>[% + END; + +END; + +row_block = 'listview_row'; + +BLOCK listview_row; + + INCLUDE listview_base_row; + FOREACH action IN self.row_actions_for(row); + %] <td[% process_attrs(attrs); %]><a href="[% action.uri %]">[% + loc(action.label) %]</a></td>[% + IF loop.last == 0; "\n"; END; + END; + +END; + +row_field_block = 'listview_row_field'; + +BLOCK listview_row_field; + + field_value = field_value || row.$f_name; + + IF field_value.isa('DateTime'); + field_value = field_value.strftime("%F %H:%M:%S"); + END; + INCLUDE listview_base_row_field; + +END; + +%] diff --git a/root/base/listview_base b/root/base/listview_base new file mode 100644 index 0000000..9b71c30 --- /dev/null +++ b/root/base/listview_base @@ -0,0 +1,124 @@ +[% + +main_block = 'listview_base_main'; + +table_start_block = 'listview_base_table_start'; +table_end_block = 'listview_base_table_end'; +row_block = 'listview_base_row'; +row_field_block = 'listview_base_row_field'; +header_block = 'listview_base_header'; +header_field_block = 'listview_base_header_field'; +footer_block = 'listview_base_footer'; +footer_field_block = 'listview_base_footer_field'; +create_link_block = 'listview_base_create'; + +show_footer = 1; + +BLOCK listview_base_main; + + include( 'table_start_block' ); %] + <thead> + <tr>[% include( 'header_block' ) | indent(4); %] + </tr> + </thead>[% + + IF show_footer && self.footer_field_names.size != ''; + "\n <tfoot>"; + include( 'footer_block' ) | indent(4); + "\n </tfoot>"; + END; + + %] + <tbody> + [% + + FOREACH row = self.current_rows; + "<tr>\n"; + include( 'row_block' ) | indent(4); + "\n </tr>"; + END; %] + </tbody>[% + + include( 'table_end_block' ); + +END; + +BLOCK listview_base_table_start; + + #IF self.has_per_page; + IF self.has_per_page && self.pager.last_page > self.pager.first_page; + INCLUDE component type = 'pager'; + END; + + %]<table>[% + +END; + +BLOCK listview_base_table_end; + + "\n</table>\n"; + include( 'create_link_block' ); + +END; + +BLOCK listview_base_row; + + FOREACH f_name = self.field_names; + include( 'row_field_block' ); + END; + +END; + +BLOCK listview_base_row_field; + + field_value = field_value || row.$f_name; + IF field_value.can('display_name'); field_value = field_value.display_name; END; + ' <td'; process_attrs(attrs); '>'; field_value || row.$f_name; "</td>\n"; + +END; + +BLOCK listview_base_header; + + FOREACH field_name = self.field_names; + include( 'header_field_block' ); + END; + +END; + +BLOCK listview_base_header_field; + + "\n<th>"; self.field_label(field_name); '</th>'; + +END; + +BLOCK listview_base_footer; + + "\n<tr>"; + + FOREACH footer_field_name = self.footer_field_names; + include( 'footer_field_block' ); + END; + + '</tr>'; + +END; + +BLOCK listview_base_footer_field; + + "\n <td>"; self.field_label(footer_field_name); '</td>'; + +END; + +BLOCK listview_base_create; + + '<p>'; + action = ctx.controller.action_for('create'); + IF action; + action = ctx.uri_for(action); + '<a href="'; action; '">'; loc("Create record"); '</a>'; + END; + '</p>'; + +END; + +%] diff --git a/root/base/objectview b/root/base/objectview new file mode 100644 index 0000000..567d3c8 --- /dev/null +++ b/root/base/objectview @@ -0,0 +1 @@ +[% PROCESS view_base %] diff --git a/root/base/pager b/root/base/pager new file mode 100644 index 0000000..cde0ce4 --- /dev/null +++ b/root/base/pager @@ -0,0 +1,128 @@ +[% + +main_block = 'pager_main'; + +start_block = 'pager_start'; +prev_block = 'pager_prev'; +current_block = 'pager_current'; +next_block = 'pager_next'; +end_block = 'pager_end'; +list_block = 'pager_list'; + +start_label_block = 'pager_start_label'; +prev_label_block = 'pager_prev_label'; +current_label_block = 'pager_current_label'; +next_label_block = 'pager_next_label'; +end_label_block = 'pager_end_label'; +list_label_block = 'pager_list_label'; + +BLOCK pager_main; + + '<div>[ '; + data = []; + + str = BLOCK; include( 'start_block' ); END; + data.push(str) IF str; + + str = BLOCK; include( 'prev_block' ); END; + data.push(str) IF str; + + str = BLOCK; include( 'current_block' ); END; + data.push(str) IF str; + + str = BLOCK; include( 'next_block' ); END; + data.push(str) IF str; + + str = BLOCK; include( 'end_block' ); END; + data.push(str) IF str; + + data.join(" |\n"); + " ]</div>\n"; + +END; + +BLOCK pager_start; + + %]<a [% connect_href(self, 'page' => self.pager.first_page); process_attrs(attrs) %]>[% + include( 'start_label_block' ) %]</a>[% + +END; + +BLOCK pager_start_label; + + loc('Start'); ' ('; self.pager.first_page; ')'; + +END; + +BLOCK pager_prev; + + IF self.pager.current_page != 1; + %]<a [% connect_href(self, 'page' => self.pager.previous_page); process_attrs(attrs) %]>[% + include( 'prev_label_block' ) %]</a>[% + END; + +END; + +BLOCK pager_prev_label; + + loc('Previous'); ' ('; self.pager.previous_page; ')'; + +END; + +BLOCK pager_current; + + %]<a [% connect_href(self, 'page' => self.pager.current_page); process_attrs(attrs) %]>[% + include( 'current_label_block' ) %]</a>[% + +END; + +BLOCK pager_current_label; + + loc('Current'); ' ('; self.pager.current_page; ')'; + +END; + +BLOCK pager_next; + + IF self.pager.current_page != self.pager.last_page; + %]<a [% connect_href(self, 'page' => self.pager.next_page); process_attrs(attrs) %]>[% + include( 'next_label_block' ) %]</a>[% + END; + +END; + +BLOCK pager_next_label; + + loc('Next'); ' ('; self.pager.next_page; ')'; + +END; + +BLOCK pager_end; + + %]<a [% connect_href(self, 'page' => self.pager.last_page); process_attrs(attrs) %]>[% + include( 'end_label_block' ) %]</a>[% + +END; + +BLOCK pager_end_label; + + loc('End'); ' ('; self.pager.last_page; ')'; + +END; + +BLOCK pager_list; + + FOREACH page IN self.pager.list; + '<a'; connect_href(self, 'page' => page); process_attrs(attrs); '>'; + include( 'list_label_block' ); "</a>\n"; + END; + +END; + +BLOCK pager_list_label; + + page; + +END; + +%] diff --git a/root/base/password b/root/base/password new file mode 100644 index 0000000..ba3f389 --- /dev/null +++ b/root/base/password @@ -0,0 +1,14 @@ +[% + +PROCESS field_base; + +control_block = 'passwordfield_control'; + +BLOCK passwordfield_control; + + %]<input type="password" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, 'value'); + ' value="'; self.value | html; '"'; process_attrs(attrs) %] />[% + +END; + +%] diff --git a/root/base/radio b/root/base/radio new file mode 100644 index 0000000..a4e897a --- /dev/null +++ b/root/base/radio @@ -0,0 +1,14 @@ +[% + +PROCESS field_base; + +control_block = 'radio_control'; + +BLOCK radio_control; + + %]<input type="radio" id="[% id_attr %]" [% connect_control(self, 'value'); + process_attrs(attrs) %] />[% + +END; + +%] diff --git a/root/base/radio_group b/root/base/radio_group new file mode 100644 index 0000000..b64e5b8 --- /dev/null +++ b/root/base/radio_group @@ -0,0 +1,17 @@ +[% + +PROCESS field_base; + +control_block = 'radiogroup_control'; + +BLOCK radiogroup_control; + + FOREACH value IN self.values.keys; + '<input type="radio" id="[% id_attr %]" [% connect_control(self, 'value'); + IF self.default == value; ' checked="checked"'; END; + process_attrs(attrs); " />\n"; + END; + +END; + +%] diff --git a/root/base/resetbtn b/root/base/resetbtn new file mode 100644 index 0000000..859d5c8 --- /dev/null +++ b/root/base/resetbtn @@ -0,0 +1,13 @@ +[% + +PROCESS button; + +control_block = 'resetbtn_control'; + +BLOCK resetbtn_control; + + INCLUDE button_control button_type = 'reset' attrs.value = 'Reset'; + +END; + +%] diff --git a/root/base/search_base b/root/base/search_base new file mode 100644 index 0000000..24bbfff --- /dev/null +++ b/root/base/search_base @@ -0,0 +1,14 @@ +[% + +PROCESS field_base; + +control_block = 'search_base_control'; + +BLOCK search_base_control; + + INCLUDE component type = 'textfield'; + INCLUDE component type = 'submitbtn' attrs.value = 'Search'; + +END; + +%] diff --git a/root/base/select b/root/base/select new file mode 100644 index 0000000..a387fa1 --- /dev/null +++ b/root/base/select @@ -0,0 +1,38 @@ +[% + +PROCESS field_base; + +control_block = 'select_control'; + +BLOCK select_control; + + IF values_list_type; + values_list = self.${values_list_type}; + ELSE; + values_list = self.valid_values; + END; + + name = attrs.name || 'value'; attrs.name = ''; + '<select '; + IF id_attr; 'id="'; id_attr; '"'; END; + connect_control(self, name); process_attrs(attrs); ">\n"; + + IF attrs.nullable == 1 || !(self.attribute.required); + attrs.nullable = ''; + " <option value=\"\">--</option>\n"; + END; + + FOREACH v_val IN values_list; + v_val = self.obj_to_str(v_val); + v_name = self.value_to_name_map.${v_val} || v_val; + ' <option value="'; v_val | html; '"'; + IF (self.is_current_value(v_val) || self.value == v_val ) && !self.hide_selected; + ' selected="selected"'; + END; + '>'; v_name | html; "</option>\n"; + END; + '</select>'; + +END; + +%] diff --git a/root/base/select_group b/root/base/select_group new file mode 100644 index 0000000..f740d77 --- /dev/null +++ b/root/base/select_group @@ -0,0 +1,14 @@ +[% + +PROCESS select; + +control_block = 'select_group_control'; + +BLOCK select_group_control; + + INCLUDE select_control attrs.multiple = 'multiple'; + attrs.multiple = ''; + +END; + +%] diff --git a/root/base/submitbtn b/root/base/submitbtn new file mode 100644 index 0000000..6e2246c --- /dev/null +++ b/root/base/submitbtn @@ -0,0 +1,13 @@ +[% + +PROCESS button; + +control_block = 'submitbtn_control'; + +BLOCK submitbtn_control; + + INCLUDE button_control button_type = 'submit' attrs.value = 'Submit' self.event = 'ok'; + +END; + +%] diff --git a/root/base/textarea b/root/base/textarea new file mode 100644 index 0000000..57114f9 --- /dev/null +++ b/root/base/textarea @@ -0,0 +1,15 @@ +[% + +PROCESS field_base; + +control_block = 'textarea_control'; + +BLOCK textarea_control; + + attrs.maxlength = ''; + %]<textarea id="[% id_attr %]" [% connect_control(self, 'value'); + process_attrs(attrs) %]>[% self.value | html; '</textarea>'; + +END; + +%] diff --git a/root/base/textfield b/root/base/textfield new file mode 100644 index 0000000..a43f445 --- /dev/null +++ b/root/base/textfield @@ -0,0 +1,17 @@ +[% + +PROCESS field_base; + +control_block = 'textfield_control'; + +BLOCK textfield_control; + + attrs.maxlength = '255'; # SimpleStr requires <= 255 + name = attrs.name || 'value'; attrs.name = ''; + %]<input type="text" [% IF id_attr; 'id="'; id_attr; '"'; END; connect_control(self, name); + ' value="'; self.value | html; '"'; process_attrs(attrs) %] />[% + attrs.maxlength = ''; + +END; + +%] diff --git a/root/base/timerange b/root/base/timerange new file mode 100644 index 0000000..a987cfd --- /dev/null +++ b/root/base/timerange @@ -0,0 +1,44 @@ +[% + +main_block = 'timerange_field'; + +BLOCK timerange_field; + + include( 'control_block' ); + + IF self.message; + "\n<span>"; loc(self.message); '</span>'; + END; + +END; + +control_block = 'timerange_control'; + +BLOCK timerange_control; + + name = attrs.name || 'value_string'; attrs.name = ''; + self.label = ''; + data = self.value_string.split(','); + #USE dumper; dumper.dump(data); + data.0.replace('T', ' ') | ucfirst; ' to '; data.1.replace('T', ' '); + IF data.2 == 'none'; data.2 = ''; END; + IF data.2 != ''; + ' every '; data.4.replace('dai', 'day').replace('ly', ''); + ' between '; data.2.replace('T', ' '); ' and '; data.3.replace('T', ' '); + END; + inner = { + value => self.delete_label, + event => 'delete', + location => self.location, + }; +# INCLUDE component type = 'button' button_type = 'submit' self = inner; + '<input type="submit" value="'; self.delete_label; ;'" '; connect_control(self, 'delete'); ' />'; + "<br />\n"; + '<input type="hidden" '; connect_control(self, name); ' value="'; self.value_string; '"'; process_attrs(attrs); ' />'; + "\n"; + +# INCLUDE component type = 'hiddenarray' self.value = ctx.stash.ranges; + +END; + +%] diff --git a/root/base/timerangecollection b/root/base/timerangecollection new file mode 100644 index 0000000..2c0bf1a --- /dev/null +++ b/root/base/timerangecollection @@ -0,0 +1,60 @@ +[% + +PROCESS form_base; + +fields_block = 'timerangecollection_control'; + +BLOCK timerangecollection_control; + + include( 'error_block' ); + include( 'results_block' ); + FOREACH f_name = self.field_names; + NEXT IF f_name.match('range'); + field = self.fields.$f_name; + '<p>'; window.render_viewport(field); "</p>\n"; + END; + +END; + +results_block = 'timerangecollection_results'; + +BLOCK timerangecollection_results; + + FOREACH field = self.range_vps; + '<p>'; window.render_viewport(field); "</p>\n"; + END; + '<input type="hidden"'; connect_control(self, 'max_range_vps'); ' value="'; self.range_vps.size; '" />'; +# INCLUDE component type = 'hidden' self.name = 'max_range_vps' self.val = self.range_vps.size; + +END; + +error_block = 'timerangecollection_error'; + +BLOCK timerangecollection_error; + + IF self.warning; + '<p>'; self.warning; '</p>'; + END; + IF self.error; + '<p>'; self.error; '</p>'; + END; + +END; + +button_block = 'timerangecollection_buttons'; + +BLOCK timerangecollection_buttons; + + INCLUDE component type = 'submitbtn' self.value = 'add' self.event = 'add_range_vp' self.label = ''; + + IF self.has_on_next_callback; + INCLUDE component type = 'submitbtn' self.value = 'next' self.event = 'next' self.label = ''; + END; + + IF self.is_changed; self.value = 'cancel'; ELSE; self.value = 'close'; END; + INCLUDE component type = 'cancelbtn' self.label = '' self.event = 'close'; + '<br />'; + +END; + +%] diff --git a/root/base/view_base b/root/base/view_base new file mode 100644 index 0000000..e67ac8f --- /dev/null +++ b/root/base/view_base @@ -0,0 +1,22 @@ +[% + +main_block = 'view_base_control'; +control_block = 'view_base_control'; +fields_block = 'view_base_fields'; + +BLOCK view_base_control; + + include( 'fields_block' ); + +END; + +BLOCK view_base_fields; + + FOREACH f_name = self.field_names; + field = self.fields.$f_name; + window.render_viewport(field); "<br />\n"; + END; + +END; + +%] diff --git a/root/base/xhtml b/root/base/xhtml new file mode 100644 index 0000000..0c0ea26 --- /dev/null +++ b/root/base/xhtml @@ -0,0 +1,29 @@ +[% BLOCK xhtml_main; -%] +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> + +<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en"> + +<head> + <title>[% window.title %]</title> + + [%- FOREACH stylesheet IN stylesheets; -%] + <link rel="stylesheet" type="text/css" href="[% ctx.uri_for('/stylesheets', stylesheet) %]" /> + [%- END; -%] + [%- FOREACH javascript IN javascripts; -%] + <script src="[% ctx.uri_for('/javascript', javascript) %]" type="text/javascript"></script> + [%- END; -%] + + <meta http-equiv="Content-Type" content="text/html; charset=utf8" /> + <meta name="GENERATOR" content="Catalyst/TT" /> +</head> + +<body> +[% INCLUDE header; +window.render_viewport(self.inner); %] +[% INCLUDE footer; %] +</body> +</html> +[%- END; +main_block = 'xhtml_main'; +-%] diff --git a/root/favicon.ico b/root/favicon.ico Binary files differnew file mode 100644 index 0000000..5ad723d --- /dev/null +++ b/root/favicon.ico diff --git a/root/index b/root/index new file mode 100644 index 0000000..4cc7bc3 --- /dev/null +++ b/root/index @@ -0,0 +1,23 @@ +[% + +main_block = 'index'; + +BLOCK index; + +%] + +<h2>Using ActionReflector and DBIC (View doesn't work)</h2> +<p><a href="[% ctx.uri_for('/foo') %]">foo</a></p> +<p><a href="[% ctx.uri_for('/bar') %]">bar</a></p> +<p><a href="[% ctx.uri_for('/baz') %]">baz</a></p> + +<h2>Using InterfaceModel, ObjectClass, SchemaClass, and ModelBase</h2> +<p><a href="[% ctx.uri_for('/testmodel/foo') %]">foo</a></p> +<p><a href="[% ctx.uri_for('/testmodel/bar') %]">bar</a></p> +<p><a href="[% ctx.uri_for('/testmodel/baz') %]">baz</a></p> + +[% + +END; + +%] diff --git a/root/static/images/btn_120x50_built.png b/root/static/images/btn_120x50_built.png Binary files differnew file mode 100644 index 0000000..c709fd6 --- /dev/null +++ b/root/static/images/btn_120x50_built.png diff --git a/root/static/images/btn_120x50_built_shadow.png b/root/static/images/btn_120x50_built_shadow.png Binary files differnew file mode 100644 index 0000000..15142fe --- /dev/null +++ b/root/static/images/btn_120x50_built_shadow.png diff --git a/root/static/images/btn_120x50_powered.png b/root/static/images/btn_120x50_powered.png Binary files differnew file mode 100644 index 0000000..7249b47 --- /dev/null +++ b/root/static/images/btn_120x50_powered.png diff --git a/root/static/images/btn_120x50_powered_shadow.png b/root/static/images/btn_120x50_powered_shadow.png Binary files differnew file mode 100644 index 0000000..e6876c0 --- /dev/null +++ b/root/static/images/btn_120x50_powered_shadow.png diff --git a/root/static/images/btn_88x31_built.png b/root/static/images/btn_88x31_built.png Binary files differnew file mode 100644 index 0000000..007b5db --- /dev/null +++ b/root/static/images/btn_88x31_built.png diff --git a/root/static/images/btn_88x31_built_shadow.png b/root/static/images/btn_88x31_built_shadow.png Binary files differnew file mode 100644 index 0000000..ccf4624 --- /dev/null +++ b/root/static/images/btn_88x31_built_shadow.png diff --git a/root/static/images/btn_88x31_powered.png b/root/static/images/btn_88x31_powered.png Binary files differnew file mode 100644 index 0000000..8f0cd9f --- /dev/null +++ b/root/static/images/btn_88x31_powered.png diff --git a/root/static/images/btn_88x31_powered_shadow.png b/root/static/images/btn_88x31_powered_shadow.png Binary files differnew file mode 100644 index 0000000..aa776fa --- /dev/null +++ b/root/static/images/btn_88x31_powered_shadow.png diff --git a/root/static/images/catalyst_logo.png b/root/static/images/catalyst_logo.png Binary files differnew file mode 100644 index 0000000..21f1cac --- /dev/null +++ b/root/static/images/catalyst_logo.png diff --git a/script/componentui_cgi.pl b/script/componentui_cgi.pl new file mode 100755 index 0000000..f75d75e --- /dev/null +++ b/script/componentui_cgi.pl @@ -0,0 +1,37 @@ +#!/usr/bin/perl -w + +BEGIN { $ENV{CATALYST_ENGINE} ||= 'CGI' } + +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use ComponentUI; + +ComponentUI->run; + +1; + +=head1 NAME + +componentui_cgi.pl - Catalyst CGI + +=head1 SYNOPSIS + +See L<Catalyst::Manual> + +=head1 DESCRIPTION + +Run a Catalyst application as a cgi script. + +=head1 AUTHOR + +Sebastian Riedel, C<sri@oook.de> + +=head1 COPYRIGHT + + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/componentui_create.pl b/script/componentui_create.pl new file mode 100755 index 0000000..b99305c --- /dev/null +++ b/script/componentui_create.pl @@ -0,0 +1,74 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; +use Getopt::Long; +use Pod::Usage; +use Catalyst::Helper; + +my $force = 0; +my $mech = 0; +my $help = 0; + +GetOptions( + 'nonew|force' => \$force, + 'mech|mechanize' => \$mech, + 'help|?' => \$help + ); + +pod2usage(1) if ( $help || !$ARGV[0] ); + +my $helper = Catalyst::Helper->new( { '.newfiles' => !$force, mech => $mech } ); + +pod2usage(1) unless $helper->mk_component( 'ComponentUI', @ARGV ); + +1; + +=head1 NAME + +componentui_create.pl - Create a new Catalyst Component + +=head1 SYNOPSIS + +componentui_create.pl [options] model|view|controller name [helper] [options] + + Options: + -force don't create a .new file where a file to be created exists + -mechanize use Test::WWW::Mechanize::Catalyst for tests if available + -help display this help and exits + + Examples: + componentui_create.pl controller My::Controller + componentui_create.pl -mechanize controller My::Controller + componentui_create.pl view My::View + componentui_create.pl view MyView TT + componentui_create.pl view TT TT + componentui_create.pl model My::Model + componentui_create.pl model SomeDB DBIC::Schema MyApp::Schema create=dynamic\ + dbi:SQLite:/tmp/my.db + componentui_create.pl model AnotherDB DBIC::Schema MyApp::Schema create=static\ + dbi:Pg:dbname=foo root 4321 + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Create a new Catalyst Component. + +Existing component files are not overwritten. If any of the component files +to be created already exist the file will be written with a '.new' suffix. +This behavior can be suppressed with the C<-force> option. + +=head1 AUTHOR + +Sebastian Riedel, C<sri@oook.de> +Maintained by the Catalyst Core Team. + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/componentui_fastcgi.pl b/script/componentui_fastcgi.pl new file mode 100755 index 0000000..d21ea3f --- /dev/null +++ b/script/componentui_fastcgi.pl @@ -0,0 +1,76 @@ +#!/usr/bin/perl -w + +BEGIN { $ENV{CATALYST_ENGINE} ||= 'FastCGI' } + +use strict; +use warnings; +use Getopt::Long; +use Pod::Usage; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use ComponentUI; + +my $help = 0; +my ( $listen, $nproc, $pidfile, $manager, $detach ); + +GetOptions( + 'help|?' => \$help, + 'listen|l=s' => \$listen, + 'nproc|n=i' => \$nproc, + 'pidfile|p=s' => \$pidfile, + 'manager|M=s' => \$manager, + 'daemon|d' => \$detach, +); + +pod2usage(1) if $help; + +ComponentUI->run( + $listen, + { nproc => $nproc, + pidfile => $pidfile, + manager => $manager, + detach => $detach, + } +); + +1; + +=head1 NAME + +componentui_fastcgi.pl - Catalyst FastCGI + +=head1 SYNOPSIS + +componentui_fastcgi.pl [options] + + Options: + -? -help display this help and exits + -l -listen Socket path to listen on + (defaults to standard input) + can be HOST:PORT, :PORT or a + filesystem path + -n -nproc specify number of processes to keep + to serve requests (defaults to 1, + requires -listen) + -p -pidfile specify filename for pid file + (requires -listen) + -d -daemon daemonize (requires -listen) + -M -manager specify alternate process manager + (FCGI::ProcManager sub-class) + or empty string to disable + +=head1 DESCRIPTION + +Run a Catalyst application as fastcgi. + +=head1 AUTHOR + +Sebastian Riedel, C<sri@oook.de> +Maintained by the Catalyst Core Team. + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/componentui_server.pl b/script/componentui_server.pl new file mode 100755 index 0000000..a5775fc --- /dev/null +++ b/script/componentui_server.pl @@ -0,0 +1,110 @@ +#!/usr/bin/perl -w + +BEGIN { + $ENV{CATALYST_ENGINE} ||= 'HTTP'; + $ENV{CATALYST_SCRIPT_GEN} = 28; +} + +use strict; +use warnings; +use Getopt::Long; +use Pod::Usage; +use FindBin; +use lib "$FindBin::Bin/../lib"; + +my $debug = 0; +my $fork = 0; +my $help = 0; +my $host = undef; +my $port = 3000; +my $keepalive = 0; +my $restart = 0; +my $restart_delay = 1; +my $restart_regex = '\.yml$|\.yaml$|\.pm$'; +my $restart_directory = undef; + +my @argv = @ARGV; + +GetOptions( + 'debug|d' => \$debug, + 'fork' => \$fork, + 'help|?' => \$help, + 'host=s' => \$host, + 'port=s' => \$port, + 'keepalive|k' => \$keepalive, + 'restart|r' => \$restart, + 'restartdelay|rd=s' => \$restart_delay, + 'restartregex|rr=s' => \$restart_regex, + 'restartdirectory=s' => \$restart_directory, +); + +pod2usage(1) if $help; + +if ( $restart ) { + $ENV{CATALYST_ENGINE} = 'HTTP::Restarter'; +} +if ( $debug ) { + $ENV{CATALYST_DEBUG} = 1; +} + +# This is require instead of use so that the above environment +# variables can be set at runtime. +require ComponentUI; + +ComponentUI->run( $port, $host, { + argv => \@argv, + 'fork' => $fork, + keepalive => $keepalive, + restart => $restart, + restart_delay => $restart_delay, + restart_regex => qr/$restart_regex/, + restart_directory => $restart_directory, +} ); + +1; + +=head1 NAME + +componentui_server.pl - Catalyst Testserver + +=head1 SYNOPSIS + +componentui_server.pl [options] + + Options: + -d -debug force debug mode + -f -fork handle each request in a new process + (defaults to false) + -? -help display this help and exits + -host host (defaults to all) + -p -port port (defaults to 3000) + -k -keepalive enable keep-alive connections + -r -restart restart when files get modified + (defaults to false) + -rd -restartdelay delay between file checks + -rr -restartregex regex match files that trigger + a restart when modified + (defaults to '\.yml$|\.yaml$|\.pm$') + -restartdirectory the directory to search for + modified files + (defaults to '../') + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Run a Catalyst Testserver for this application. + +=head1 AUTHOR + +Sebastian Riedel, C<sri@oook.de> +Maintained by the Catalyst Core Team. + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/componentui_test.pl b/script/componentui_test.pl new file mode 100755 index 0000000..c9fc92b --- /dev/null +++ b/script/componentui_test.pl @@ -0,0 +1,54 @@ +#!/usr/bin/perl -w + +use strict; +use warnings; +use Getopt::Long; +use Pod::Usage; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Catalyst::Test 'ComponentUI'; + +my $help = 0; + +GetOptions( 'help|?' => \$help ); + +pod2usage(1) if ( $help || !$ARGV[0] ); + +print request($ARGV[0])->content . "\n"; + +1; + +=head1 NAME + +componentui_test.pl - Catalyst Test + +=head1 SYNOPSIS + +componentui_test.pl [options] uri + + Options: + -help display this help and exits + + Examples: + componentui_test.pl http://localhost/some_action + componentui_test.pl /some_action + + See also: + perldoc Catalyst::Manual + perldoc Catalyst::Manual::Intro + +=head1 DESCRIPTION + +Run a Catalyst action from the command line. + +=head1 AUTHOR + +Sebastian Riedel, C<sri@oook.de> +Maintained by the Catalyst Core Team. + +=head1 COPYRIGHT + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/script/moose_to_rclass.pl b/script/moose_to_rclass.pl new file mode 100755 index 0000000..67d0e73 --- /dev/null +++ b/script/moose_to_rclass.pl @@ -0,0 +1,33 @@ +#!/usr/bin/env perl + +# THIS IS A FUCKING CHEESY HACK. DON'T RUN IT ON ANYTHING YOU CARE ABOUT +# (and don't have in svn at least. Oh, and it breaks horribly on with) + +use strict; +use warnings; + +my $data; + +foreach my $file (@ARGV) { + open IN, $file; + { local $/; $data = <IN>; } + close IN; + unless ($data =~ m/(.*?\n)(?:extends (.*?);)?\n+?(has.*)\n(1;\s*\n.*)/s) { + warn "Failed to match for ${file}\n"; + next; + } + my ($front, $super_list, $body, $rest) = ($1, $2, $3, $4); + my @supers = split(/\s*,\s*/, $super_list); + my $pkg = (split(/\//, $file))[-1]; + $pkg =~ s/\.pm//; + $body =~ s/^sub (\S+) {$/method $1 => sub {/mg; + $body =~ s/^}$/};/mg; + $body =~ s/^(\S+) '([^\+]\S+)' =>/$1 $2 =>/mg; + $body =~ s/^/ /mg; + my $is_list = join('', map { "is $_, " } @supers); + open OUT, '>', $file; + print OUT "${front}class ${pkg} ${is_list}which {\n${body}\n};\n\n${rest}"; + close OUT; +} + +exit 0; diff --git a/t/01app.t b/t/01app.t new file mode 100644 index 0000000..c72e2c7 --- /dev/null +++ b/t/01app.t @@ -0,0 +1,7 @@ +use strict; +use warnings; +use Test::More tests => 2; + +BEGIN { use_ok 'Catalyst::Test', 'ComponentUI' } + +ok( request('/')->is_success, 'Request should succeed' ); diff --git a/t/02pod.t b/t/02pod.t new file mode 100644 index 0000000..251640d --- /dev/null +++ b/t/02pod.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => 'Test::Pod 1.14 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +all_pod_files_ok(); diff --git a/t/03podcoverage.t b/t/03podcoverage.t new file mode 100644 index 0000000..d8b1422 --- /dev/null +++ b/t/03podcoverage.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +my @modules = sort { $a cmp $b } (Test::Pod::Coverage::all_modules()); +@modules = grep {!/^ComponentUI::/} @modules; +plan tests => scalar(@modules); + +# methods to ignore on all modules +my $exceptions = { + ignore => [ + qw/ BUILD build_ can_ clear_ has_ do_ adopt_ accept_ + apply_ layout value meta / + ] +}; + +foreach my $module (@modules) { + # build parms up from ignore list + my $parms = {}; + $parms->{trustme} = + [ map { qr/^$_/ } @{ $exceptions->{ignore} } ] + if exists($exceptions->{ignore}); + + # run the test with the potentially modified parm set + pod_coverage_ok($module, $parms, "$module POD coverage"); +} diff --git a/t/04load_all.t b/t/04load_all.t new file mode 100644 index 0000000..a7923fc --- /dev/null +++ b/t/04load_all.t @@ -0,0 +1,15 @@ +use strict; +use warnings; +use Test::More (); + +Test::More::plan('no_plan'); + +use Module::Pluggable::Object; + +my $finder = Module::Pluggable::Object->new( + search_path => [ 'Reaction' ], + ); + +foreach my $class (sort $finder->plugins) { + Test::More::use_ok($class); +} diff --git a/t/05reflect_attr_from.t b/t/05reflect_attr_from.t new file mode 100644 index 0000000..67974ba --- /dev/null +++ b/t/05reflect_attr_from.t @@ -0,0 +1,34 @@ +package TestMe2; +use strict; +use warnings; +use Reaction::Class; +use Reaction::Types::DateTime; + +has id => (is => 'ro', required => 1, isa => 'Int'); +has username => (is => 'rw', required => 1, isa => 'NonEmptySimpleStr'); +has created_d => (is => 'rw', required => 1, isa => 'DateTime'); + +1; + +package TestMe; +use strict; +use warnings; +use Reaction::Class; + +reflect_attributes_from('TestMe2' => qw(id username created_d)); + +1; + +package main; +use strict; +use warnings; +use Data::Dumper; +use Test::More; + +plan tests => 1; + +my @test_list = TestMe->meta->get_attribute_list; +my @test2_list = TestMe2->meta->get_attribute_list; +is_deeply(\@test_list, \@test2_list, "Attribute lists match"); + +1; diff --git a/t/im_dbic.t b/t/im_dbic.t new file mode 100644 index 0000000..db4f772 --- /dev/null +++ b/t/im_dbic.t @@ -0,0 +1,15 @@ +use lib 't/lib'; +use strict; +use warnings; + +use Test::Class; +use RTest::InterfaceModel::DBIC; +use RTest::InterfaceModel::Reflector::DBIC; + +Test::Class->runtests( + RTest::InterfaceModel::DBIC->new(), +); + +Test::Class->runtests( + RTest::InterfaceModel::Reflector::DBIC->new(), +); diff --git a/t/lib/RTest/InterfaceModel/DBIC.pm b/t/lib/RTest/InterfaceModel/DBIC.pm new file mode 100644 index 0000000..3a2bf57 --- /dev/null +++ b/t/lib/RTest/InterfaceModel/DBIC.pm @@ -0,0 +1,140 @@ +package RTest::InterfaceModel::DBIC; + +use base qw/Reaction::Test::WithDB Reaction::Object/; +use Reaction::Class; +use ComponentUI::TestModel; +use Test::More (); + +has '+schema_class' => (default => sub { 'RTest::TestDB' }); + +has im_schema => (is =>'ro', isa => 'ComponentUI::TestModel', lazy_build => 1); +sub build_im_schema{ + my $self = shift; + + my (@dm) = ComponentUI::TestModel->domain_models; + Test::More::ok(@dm == 1, 'Correct number of Domain Models'); + my $dm = shift @dm; + Test::More::ok($dm->name eq '_testdb_schema', 'Domain Model created correctly'); + + ComponentUI::TestModel->new($dm->name => $self->schema); +} + +sub test_SchemaClass :Tests { + my $self = shift; + my $s = $self->im_schema; + + #just make sure here... + Test::More::isa_ok( $s, 'Reaction::InterfaceModel::Object', + 'Correctly override default base object' ); + + my %pa = map{$_->name => $_ } $s->parameter_attributes; + Test::More::ok(keys %pa == 3, 'Correct number of Parameter Attributes'); + + Test::More::ok($pa{Foo} && $pa{'Bar'} && $pa{'Baz'}, + 'Parameter Attributes named correctly'); + + #for now since we have no generic collection object + Test::More::ok + ( $pa{Foo}->_isa_metadata eq 'Reaction::InterfaceModel::DBIC::Collection', + 'Parameter Attributes typed correctly' ); + + Test::More::is($pa{Baz}->reader, 'bazes', 'Correct Baz reader created'); + Test::More::is($pa{Foo}->reader, 'foo_collection', 'Correct Foo reader created'); + Test::More::is($pa{Bar}->reader, 'bar_collection', 'Correct Bar reader created'); + + #is this check good enough? Moose will take care of checking the type constraints, + # so i dont need tocheck that Moose++ !! + my $foo1 = $s->foo_collection; + my $foo2 = $s->foo_collection; + Test::More::ok + (Scalar::Util::refaddr($foo1) ne Scalar::Util::refaddr($foo2), + 'Fresh Collections work'); +} + +sub test_ObjectClass :Tests { + my $self = shift; + + my $collection = $self->im_schema->foo_collection; + Test::More::ok( my $im = $collection->find({ id => 1}), 'Find call successful'); + + Test::More::isa_ok( $im, 'ComponentUI::TestModel::Foo', + 'Correct result class set' ); + + my %pa = map{$_->name => $_ } $im->parameter_attributes; + Test::More::ok(keys %pa == 4, 'Correct number of Parameter Attributes'); + + Test::More::is( $pa{first_name}->_isa_metadata, 'NonEmptySimpleStr' + ,'Column ParameterAttribute typed correctly'); + + Test::More::is + ($pa{baz_list}->_isa_metadata, 'Reaction::InterfaceModel::DBIC::Collection', + "Relationship detected successfully"); + + my (@dm) = $im->domain_models; + Test::More::ok(@dm == 1, 'Correct number of Domain Models'); + my $dm = shift @dm; + Test::More::is($dm->name, '_foo_store', 'Domain Model created correctly'); + + my $rs = $collection->_override_action_args_for->{target_model}; + Test::More::isa_ok( $rs, 'DBIx::Class::ResultSet', + 'Collection target_type ISA ResultSet' ); + + my $row = $im->_default_action_args_for->{target_model}; + Test::More::isa_ok( $row, 'DBIx::Class::Row', 'Collection target_type ISA Row' ); + + my $ctx = $self->simple_mock_context; + + my $create = $collection->action_for('Create', ctx => $ctx); + Test::More::isa_ok( $create, 'Reaction::InterfaceModel::Action', + 'Create action isa Action' ); + + Test::More::isa_ok( $create, 'ComponentUI::TestModel::Foo::Action::Create', + 'Create action has correct name' ); + + Test::More::isa_ok + ( $create, 'Reaction::InterfaceModel::Action::DBIC::ResultSet::Create', + 'Create action isa Action::DBIC::ResultSet::Create' ); + + + my $update = $im->action_for('Update', ctx => $ctx); + Test::More::isa_ok( $update, 'Reaction::InterfaceModel::Action', + 'Update action isa Action' ); + + Test::More::isa_ok( $update, 'ComponentUI::TestModel::Foo::Action::Update', + 'Update action has correct name' ); + + Test::More::isa_ok + ( $update, 'Reaction::InterfaceModel::Action::DBIC::Result::Update', + 'Update action isa Action::DBIC::ResultSet::Update' ); + + my $delete = $im->action_for('Delete', ctx => $ctx); + Test::More::isa_ok( $delete, 'Reaction::InterfaceModel::Action', + 'Delete action isa Action' ); + + Test::More::isa_ok( $delete, 'ComponentUI::TestModel::Foo::Action::Delete', + 'Delete action has correct name' ); + + Test::More::isa_ok + ( $delete, 'Reaction::InterfaceModel::Action::DBIC::Result::Delete', + 'Delete action isa Action::DBIC::ResultSet::Delete' ); + + + my $custom = $im->action_for('CustomAction', ctx => $ctx); + Test::More::isa_ok( $custom, 'Reaction::InterfaceModel::Action', + 'CustomAction isa Action' ); + + Test::More::isa_ok( $custom, 'ComponentUI::TestModel::Foo::Action::CustomAction', + 'CustomAction has correct name' ); + + my %params = map {$_->name => $_ } $custom->parameter_attributes; + Test::More::ok(exists $params{$_}, "Field ${_} reflected") + for qw(first_name last_name baz_list); + + #TODO -- will I need a mock $c object or what? I dont really know much about + # testingcat apps, who wants to volunteer? + # main things needing testing is attribute reflection + # and correct action class creation (superclasses) +} + + +1; diff --git a/t/lib/RTest/InterfaceModel/Reflector/DBIC.pm b/t/lib/RTest/InterfaceModel/Reflector/DBIC.pm new file mode 100644 index 0000000..1215788 --- /dev/null +++ b/t/lib/RTest/InterfaceModel/Reflector/DBIC.pm @@ -0,0 +1,317 @@ +package RTest::InterfaceModel::Reflector::DBIC; + +use base qw/Reaction::Test::WithDB Reaction::Object/; +use Reaction::Class; +use Class::MOP (); +use ComponentUI::TestModel; +use Test::More (); +use Reaction::InterfaceModel::Reflector::DBIC; + +has '+schema_class' => (default => sub { 'RTest::TestDB' }); + +has im_schema => (is =>'ro', isa => 'RTest::TestIM', lazy_build => 1); + +#at the moment I am only testing with the "reflect all" functionality +#when I have time I will write test cases that cover all the other bases +#it's just kind of a pain in the ass right now and I am behind on a lot of other shit. + +sub build_im_schema{ + my $self = shift; + + my $reflector = Reaction::InterfaceModel::Reflector::DBIC + ->new(model_class => 'RTest::TestIM'); + + $reflector->reflect_model( + domain_model_class => 'RTest::TestDB', + #exclude_submodels => ['FooBaz'], + reflect_submodels => [qw/Foo Bar Baz/] + ); + my (@dm) = RTest::TestIM->domain_models; + Test::More::ok(@dm == 1, 'Correct number of Domain Models'); + my $dm = shift @dm; + + print STDERR "instantiating with domain name of " . $dm->name . "\n"; + RTest::TestIM->new($dm->name => $self->schema); +} + +sub test_classnames : Tests{ + my $self = shift; + + my $reflector = Reaction::InterfaceModel::Reflector::DBIC + ->new(model_class => 'RTest::__TestIM'); + + Test::More::ok( + Class::MOP::is_class_loaded( 'RTest::__TestIM'), + "Successfully created IM class" + ); + + Test::More::is( + $reflector->submodel_classname_from_source_name('Foo'), + 'RTest::__TestIM::Foo', + 'Correct naming scheme for submodels' + ); + + Test::More::is( + $reflector->classname_for_collection_of('RTest::__TestIM::Foo'), + 'RTest::__TestIM::Foo::Collection', + 'Correct naming scheme for submodel collections' + ); +} + +sub test_reflect_model :Tests { + my $self = shift; + my $s = $self->im_schema; + + Test::More::isa_ok( $s, 'Reaction::InterfaceModel::Object', + 'Correct base' ); + + my %pa = map{$_->name => $_ } $s->parameter_attributes; + Test::More::ok(keys %pa == 3, 'Correct number of Parameter Attributes'); + + Test::More::ok($pa{Foo} && $pa{'Bar'} && $pa{'Baz'}, + 'Parameter Attributes named correctly'); + + for my $submodel (values %pa){ + Test::More::ok( + $submodel->_isa_metadata->isa('Reaction::InterfaceModel::Collection::Virtual::ResultSet'), + 'Parameter Attribute typed correctly' + ); + } + + Test::More::can_ok($s, qw/foo_collection bar_collection baz_collection/); + + for ( qw/Foo Bar Baz/ ){ + Test::More::ok( + Class::MOP::is_class_loaded("RTest::TestIM::${_}"), + "Successfully created ${_} IM class" + ); + Test::More::ok( + Class::MOP::is_class_loaded("RTest::TestIM::${_}::Collection"), + "Successfully created ${_} IM class Collection" + ); + } +} + + +sub test_add_submodel_to_model :Tests { + my $self = shift; + my $s = $self->im_schema; + + for (qw/Foo Bar Baz /) { + my $attr = $s->meta->find_attribute_by_name($_); + my $reader = $_; + $reader =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $reader = lc($reader) . "_collection"; + + Test::More::ok( $attr->is_required, "${_} is required"); + Test::More::ok( $attr->has_reader, "${_} has a reader"); + Test::More::ok( $attr->has_predicate, "${_} has a predicate"); + Test::More::ok( $attr->has_domain_model, "${_} has a domain_model"); + Test::More::ok( $attr->has_default, "${_} has a default"); + Test::More::ok( $attr->is_default_a_coderef, "${_}'s defaultis a coderef"); + Test::More::is( $attr->reader, $reader, "Correct ${_} reader"); + Test::More::is( $attr->domain_model, "_RTest_TestDB", "Correct ${_} domain_model"); + + Test::More::isa_ok( + $s->$reader, + "RTest::TestIM::${_}::Collection", + "${_} default method works" + ); + + } +} + +sub test_reflect_collection_for :Tests{ + my $self = shift; + my $s = $self->im_schema; + + for ( qw/Foo Bar Baz/ ){ + my $reader = $s->meta->find_attribute_by_name($_)->reader; + my $collection = $s->$reader; + + Test::More::is( + $collection->meta->name, + "RTest::TestIM::${_}::Collection", + "Correct Classname" + ); + Test::More::isa_ok( + $collection, + 'Reaction::InterfaceModel::Collection', + "Collection ISA Collection" + ); + Test::More::isa_ok( + $collection, + 'Reaction::InterfaceModel::Collection::Virtual', + "Collection ISA virtual collection" + ); + Test::More::isa_ok( + $collection, + 'Reaction::InterfaceModel::Collection::Virtual::ResultSet', + "Collection ISA virtual resultset" + ); + Test::More::can_ok($collection, '_build_im_class'); + Test::More::is( + $collection->_build_im_class, + "RTest::TestIM::${_}", + "Collection has correct _im_class" + ); + } +} + +sub test_reflect_submodel :Tests{ + my $self = shift; + my $s = $self->im_schema; + + for my $sm ( qw/Foo Bar Baz/ ){ + my $reader = $s->meta->find_attribute_by_name($sm)->reader; + my $collection = $s->$reader; + my ($member) = $collection->members; + Test::More::ok($member, "Successfully retrieved member"); + Test::More::isa_ok( + $member, + "Reaction::InterfaceModel::Object", + "Member isa IM::Object" + ); + Test::More::isa_ok($member, $collection->_im_class); + + my (@dm) = $member->domain_models; + Test::More::ok(@dm == 1, 'Correct number of Domain Models'); + my $dm = shift @dm; + + my $dm_name = $sm; + $dm_name =~ s/([a-z0-9])([A-Z])/${1}_${2}/g ; + $dm_name = "_" . lc($dm_name) . "_store"; + + Test::More::is($dm->_is_metadata, "rw", "Correct is metadata"); + Test::More::ok($dm->is_required, "DM is_required"); + Test::More::is($dm->name, $dm_name, "Correct DM name"); + Test::More::can_ok($member, "inflate_result"); + Test::More::is( + $dm->_isa_metadata, + "RTest::TestDB::${sm}", + "Correct isa metadata" + ); + + my %attrs = map { $_->name => $_ } $member->parameter_attributes; + my $target; + if( $sm eq "Bar"){$target = 4; } + elsif($sm eq "Baz"){$target = 3; } + elsif($sm eq "Foo"){$target = 4; } + Test::More::is( scalar keys %attrs, $target, "Correct # of attributes"); + + for my $attr_name (keys %attrs){ + my $attr = $attrs{$attr_name}; + Test::More::ok($attr->is_lazy, "is lazy"); + Test::More::ok($attr->is_required, "is required"); + Test::More::ok($attr->has_clearer, "has clearer"); + Test::More::ok($attr->has_default, "has defau;t"); + Test::More::ok($attr->has_predicate, "has predicate"); + Test::More::ok($attr->has_domain_model, "has domain model"); + Test::More::ok($attr->has_orig_attr_name, "has orig attr name"); + Test::More::ok($attr->is_default_a_coderef, "default is coderef"); + Test::More::is($attr->_is_metadata, "ro", "Correct is metadata"); + Test::More::is($attr->domain_model, $dm_name, "Correct domain model"); + Test::More::is($attr->orig_attr_name, $attr_name, "Correct orig attr name"); + } + + if($sm eq "Foo"){ + Test::More::is($attrs{id}->_isa_metadata, "Int", "Correct id isa metadata"); + Test::More::is($attrs{first_name}->_isa_metadata, "NonEmptySimpleStr", "Correct first_name isa metadata"); + Test::More::is($attrs{last_name}->_isa_metadata, "NonEmptySimpleStr", "Correct last_name isa metadata"); + Test::More::is( + $attrs{baz_list}->_isa_metadata, + "RTest::TestIM::Baz::Collection", + "Correct baz_list isa metadata" + ); + } elsif($sm eq 'Bar'){ + Test::More::is($attrs{name}->_isa_metadata, "NonEmptySimpleStr", "Correct name isa metadata"); + Test::More::is($attrs{foo}->_isa_metadata, "RTest::TestIM::Foo", "Correct foo isa metadata"); + Test::More::is($attrs{published_at}->_isa_metadata, "DateTime", "Correct published_at isa metadata"); + Test::More::is($attrs{avatar}->_isa_metadata, "File", "Correct avatar isa metadata"); + } elsif($sm eq "Baz"){ + Test::More::is($attrs{id}->_isa_metadata, "Int", "Correct id isa metadata"); + Test::More::is($attrs{name}->_isa_metadata, "NonEmptySimpleStr", "Correct name isa metadata"); + Test::More::is( + $attrs{foo_list}->_isa_metadata, + "RTest::TestIM::Foo::Collection", + "Correct foo_list isa metadata" + ); + } + + } +} + +sub test_reflect_submodel_action :Tests{ + my $self = shift; + my $s = $self->im_schema; + + for my $sm ( qw/Foo Bar Baz/ ){ + my $reader = $s->meta->find_attribute_by_name($sm)->reader; + my $collection = $s->$reader; + my ($member) = $collection->members; + Test::More::ok($member, "Successfully retrieved member"); + Test::More::isa_ok( + $member, + "Reaction::InterfaceModel::Object", + "Member isa IM::Object" + ); + Test::More::isa_ok($member, $collection->_im_class); + + my $ctx = $self->simple_mock_context; + foreach my $action_name (qw/Update Delete Create/){ + + my $target_im = $action_name eq 'Create' ? $collection : $member; + my $action = $target_im->action_for($action_name, ctx => $ctx); + + Test::More::isa_ok( $action, "Reaction::InterfaceModel::Action", + "Create action isa Action" ); + Test::More::is( + $action->meta->name, + "RTest::TestIM::${sm}::Action::${action_name}", + "${action_name} action has correct name" + ); + + my $base = 'Reaction::InterfaceModel::Action::DBIC' . + ($action_name eq 'Create' ? '::ResultSet::Create' : "::Result::${action_name}"); + Test::More::isa_ok($action, $base, 'Create action has correct base'); + + + my %attrs = map { $_->name => $_ } $action->parameter_attributes; + my $attr_num; + if($action_name eq 'Delete'){next; } + elsif($sm eq "Bar"){$attr_num = 4; } + elsif($sm eq "Baz"){$attr_num = 1; } + elsif($sm eq "Foo"){$attr_num = 3; } + Test::More::is( scalar keys %attrs, $attr_num, "Correct # of attributes"); + if($attr_num != keys %attrs ){ + print STDERR "\t..." . join ", ", keys %attrs, "\n"; + } + + for my $attr_name (keys %attrs){ + my $attr = $attrs{$attr_name}; + Test::More::ok($attr->has_predicate, "has predicate"); + Test::More::is($attr->_is_metadata, "rw", "Correct is metadata"); + if ($attr->is_required){ + Test::More::ok($attr->is_lazy, "is lazy"); + Test::More::ok($attr->has_default, "has default"); + Test::More::ok($attr->is_default_a_coderef, "default is coderef"); + } + } + + if($sm eq "Foo"){ + Test::More::is($attrs{first_name}->_isa_metadata, "NonEmptySimpleStr", "Correct first_name isa metadata"); + Test::More::is($attrs{last_name}->_isa_metadata, "NonEmptySimpleStr", "Correct last_name isa metadata"); + Test::More::is($attrs{baz_list}->_isa_metadata, "ArrayRef", "Correct baz_list isa metadata"); + } elsif($sm eq 'Bar'){ + Test::More::is($attrs{name}->_isa_metadata, "NonEmptySimpleStr", "Correct name isa metadata"); + Test::More::is($attrs{foo}->_isa_metadata, "RTest::TestDB::Foo", "Correct foo isa metadata"); + Test::More::is($attrs{published_at}->_isa_metadata, "DateTime", "Correct published_at isa metadata"); + Test::More::is($attrs{avatar}->_isa_metadata, "File", "Correct avatar isa metadata"); + } elsif($sm eq "Baz"){ + Test::More::is($attrs{name}->_isa_metadata, "NonEmptySimpleStr", "Correct name isa metadata"); + } + } + } +} + +1; diff --git a/t/lib/RTest/TestDB.pm b/t/lib/RTest/TestDB.pm new file mode 100644 index 0000000..25012d2 --- /dev/null +++ b/t/lib/RTest/TestDB.pm @@ -0,0 +1,29 @@ +package # hide from PAUSE + RTest::TestDB; + +use base qw/DBIx::Class::Schema/; + +use DateTime; + +__PACKAGE__->load_classes; + +sub setup_test_data { + my $self = shift; + $self->populate('Foo' => [ + [ qw/ first_name last_name / ], + map { ( + [ "Joe", "Bloggs $_" ], + [ "John", "Smith $_" ], + ) } (1 .. 50) + ]); + $self->populate('Baz' => [ + [ qw/ name / ], + map { [ "Baz $_" ] } (1 .. 4) + ]); + $self->populate('Bar' => [ + [ qw/ name foo_id / ], + map { [ "Bar $_", $_ ] } (1 .. 4) + ]); +} + +1; diff --git a/t/lib/RTest/TestDB/Bar.pm b/t/lib/RTest/TestDB/Bar.pm new file mode 100644 index 0000000..4e22d06 --- /dev/null +++ b/t/lib/RTest/TestDB/Bar.pm @@ -0,0 +1,34 @@ +package # hide from PAUSE + RTest::TestDB::Bar; + +use DBIx::Class 0.07; + +use base qw/DBIx::Class Reaction::Object/; +use Reaction::Class; +use Reaction::Types::DateTime; +use Reaction::Types::File; + +has 'name' => (isa => 'NonEmptySimpleStr', is => 'rw', required => 1); +has 'foo' => (isa => 'RTest::TestDB::Foo', is => 'rw', required => 1); +has 'published_at' => (isa => 'DateTime', is => 'rw'); +has 'avatar' => (isa => 'File', is => 'rw'); + +__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); + +__PACKAGE__->table('bar'); + +__PACKAGE__->add_columns( + name => { data_type => 'varchar', size => 255 }, + foo_id => { data_type => 'integer', size => 16 }, + published_at => { data_type => 'datetime', is_nullable => 1 }, + avatar => { data_type => 'blob', is_nullable => 1 }, +); + +__PACKAGE__->set_primary_key('name'); + +__PACKAGE__->belongs_to( + 'foo' => 'RTest::TestDB::Foo', + { 'foreign.id' => 'self.foo_id' } +); + +1; diff --git a/t/lib/RTest/TestDB/Baz.pm b/t/lib/RTest/TestDB/Baz.pm new file mode 100644 index 0000000..848cb4f --- /dev/null +++ b/t/lib/RTest/TestDB/Baz.pm @@ -0,0 +1,29 @@ +package # hide from PAUSE + RTest::TestDB::Baz; + +use DBIx::Class 0.07; + +use base qw/DBIx::Class Reaction::Object/; +use Reaction::Class; + +has 'id' => (isa => 'Int', is => 'ro', required => 1); +has 'name' => (isa => 'NonEmptySimpleStr', is => 'rw', required => 1); +has 'foo_list' => (isa => 'ArrayRef', is => 'ro', required => 1); + +__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); + +__PACKAGE__->table('baz'); + +__PACKAGE__->add_columns( + id => { data_type => 'integer', size => 16, is_auto_increment => 1 }, + name => { data_type => 'varchar', size => 255 }, +); + +sub display_name { shift->name; } + +__PACKAGE__->set_primary_key('id'); + +__PACKAGE__->has_many('links_to_foo_list' => 'RTest::TestDB::FooBaz', 'baz'); +__PACKAGE__->many_to_many('foo_list' => 'links_to_foo_list' => 'foo'); + +1; diff --git a/t/lib/RTest/TestDB/Foo.pm b/t/lib/RTest/TestDB/Foo.pm new file mode 100644 index 0000000..5733054 --- /dev/null +++ b/t/lib/RTest/TestDB/Foo.pm @@ -0,0 +1,42 @@ +package # hide from PAUSE + RTest::TestDB::Foo; + +use DBIx::Class 0.07; + +use base qw/DBIx::Class Reaction::Object/; +use Reaction::Class; + +has 'id' => (isa => 'Int', is => 'ro', required => 1); +has 'first_name' => (isa => 'NonEmptySimpleStr', is => 'rw', required => 1); +has 'last_name' => (isa => 'NonEmptySimpleStr', is => 'rw', required => 1); +has 'baz_list' => ( + isa => 'ArrayRef', is => 'rw', required => 1, + reader => 'get_baz_list', writer => 'set_baz_list' +); + +__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); + +__PACKAGE__->table('foo'); + +__PACKAGE__->add_columns( + id => { data_type => 'integer', size => 16, is_auto_increment => 1 }, + first_name => { data_type => 'varchar', size => 255 }, + last_name => { data_type => 'varchar', size => 255 }, +); + +sub display_name { + my $self = shift; + return join(' ', $self->first_name, $self->last_name); +} + +__PACKAGE__->set_primary_key('id'); + +__PACKAGE__->has_many('links_to_baz_list' => 'RTest::TestDB::FooBaz', 'foo'); +__PACKAGE__->many_to_many('baz_list' => 'links_to_baz_list' => 'baz'); + +{ + no warnings 'redefine'; + *get_baz_list = sub { [ shift->baz_list->all ] }; +} + +1; diff --git a/t/lib/RTest/TestDB/FooBaz.pm b/t/lib/RTest/TestDB/FooBaz.pm new file mode 100644 index 0000000..695b141 --- /dev/null +++ b/t/lib/RTest/TestDB/FooBaz.pm @@ -0,0 +1,22 @@ +package # hide from PAUSE + RTest::TestDB::FooBaz; + +use DBIx::Class 0.07; + +use base qw/DBIx::Class/; + +__PACKAGE__->load_components(qw/InflateColumn::DateTime Core/); + +__PACKAGE__->table('foo_baz'); + +__PACKAGE__->add_columns( + foo => { data_type => 'integer', size => 16 }, + baz => { data_type => 'integer', size => 16 }, +); + +__PACKAGE__->set_primary_key(qw/foo baz/); + +__PACKAGE__->belongs_to('foo' => 'RTest::TestDB::Foo'); +__PACKAGE__->belongs_to('baz' => 'RTest::TestDB::Baz'); + +1; diff --git a/t/lib/RTest/UI/FocusStack.pm b/t/lib/RTest/UI/FocusStack.pm new file mode 100644 index 0000000..b30f060 --- /dev/null +++ b/t/lib/RTest/UI/FocusStack.pm @@ -0,0 +1,56 @@ +package RTest::UI::FocusStack; + +use base qw/Test::Class/; +use Reaction::Class; +use Reaction::UI::FocusStack; +use aliased "Reaction::UI::ViewPort"; +use Test::More (); +use Test::Memory::Cycle; + +has 'stack' => (isa => 'Reaction::UI::FocusStack', is => 'rw', set_or_lazy_build('stack')); + +sub build_stack { + return Reaction::UI::FocusStack->new; +} + +sub test_stack :Tests { + my $self = shift; + my $stack = $self->build_stack; + my $ctx = bless({}, 'Catalyst'); + Test::More::ok(!$stack->has_loc_prefix, 'No location prefix'); + Test::More::cmp_ok($stack->vp_count, '==', 0, 'Empty viewport stack'); + my $vp = $stack->push_viewport(ViewPort, ctx => $ctx); + Test::More::is($vp->location, '0', 'New vp has location 0'); + Test::More::cmp_ok($stack->vp_count, '==', 1, 'Viewport count 1'); + Test::More::is($stack->vp_head, $vp, 'Head set ok'); + Test::More::is($stack->vp_tail, $vp, 'Tail set ok'); + my $vp2 = $stack->push_viewport(ViewPort, ctx => $ctx); + Test::More::is($vp2->location, '1', 'New vp has location 1'); + Test::More::cmp_ok($stack->vp_count, '==', 2, 'Viewport count 2'); + Test::More::is($stack->vp_head, $vp, 'Head set ok'); + Test::More::is($stack->vp_tail, $vp2, 'Tail set ok'); + Test::More::is($vp->inner, $vp2, 'Inner ok on head'); + Test::More::is($vp2->outer, $vp, 'Outer ok on tail'); + Test::More::is($vp->focus_stack, $stack, 'Head focus_stack ok'); + Test::More::is($vp2->focus_stack, $stack, 'Tail focus_stack ok'); + memory_cycle_ok($stack, 'No cycles in the stack'); + my $vp3 = $stack->push_viewport(ViewPort, ctx => $ctx); + my $vp4 = $stack->push_viewport(ViewPort, ctx => $ctx); + Test::More::is($stack->vp_tail, $vp4, 'Tail still ok'); + Test::More::cmp_ok($stack->vp_count, '==', 4, 'Count still ok'); + $stack->pop_viewports_to($vp3); + Test::More::is($stack->vp_tail, $vp2, 'Correct pop to'); + Test::More::cmp_ok($stack->vp_count, '==', 2, 'Count after pop to'); + Test::More::is($stack->vp_head, $vp, 'Head unchanged'); + Test::More::is($stack->vp_tail, $vp2, 'Tail back to vp2'); + my $pop_ret = $stack->pop_viewport; + Test::More::is($vp2, $pop_ret, 'Correct viewport popped'); + Test::More::is($stack->vp_head, $vp, 'Head unchanged'); + Test::More::is($stack->vp_tail, $vp, 'Tail now head'); + $stack->pop_viewport; + Test::More::ok(!defined($stack->vp_head), 'Head cleared'); + Test::More::ok(!defined($stack->vp_tail), 'Tail cleared'); + Test::More::cmp_ok($stack->vp_count, '==', 0, 'Count Zero'); +} + +1; diff --git a/t/lib/RTest/UI/ViewPort/ListView.pm b/t/lib/RTest/UI/ViewPort/ListView.pm new file mode 100644 index 0000000..02d00ba --- /dev/null +++ b/t/lib/RTest/UI/ViewPort/ListView.pm @@ -0,0 +1,102 @@ +package RTest::UI::ViewPort::ListView; + +use base qw/Reaction::Test::WithDB/; +use Reaction::Class; + +use Reaction::UI::ViewPort::ListView; +use RTest::TestDB; +use Test::More (); + +has '+schema_class' => (default => sub { 'RTest::TestDB' }); + +has 'viewport' => ( + isa => 'Reaction::UI::ViewPort::ListView', + is => 'rw', set_or_lazy_build('viewport'), + clearer => 'clear_viewport', +); + +has 'collection' => ( + isa => 'DBIx::Class::ResultSet', + is => 'rw', set_or_lazy_build('collection'), + clearer => 'clear_collection', +); + +sub build_collection { + shift->schema->resultset('Foo'); +} + +sub build_viewport { + my ($self) = @_; + my $vp = Reaction::UI::ViewPort::ListView->new( + location => 0, + collection => $self->collection, + ctx => $self->simple_mock_context, + column_order => [qw(id first_name last_name)], + ); + return $vp; +} + +sub init_viewport :Tests { + my ($self) = @_; + + $self->clear_viewport; + + Test::More::cmp_ok($self->viewport->page, '==', 1, "Default page"); + Test::More::cmp_ok($self->viewport->per_page, '==', 10, "Default per page"); + + my @columns = qw(id first_name last_name); + Test::More::is_deeply($self->viewport->field_names, \@columns, "Field names"); + Test::More::is($self->viewport->field_label('first_name'), 'First Name', 'Field label'); + + my @rows = $self->viewport->current_rows; + Test::More::cmp_ok(@rows, '==', 10, 'Row count'); + Test::More::isa_ok($rows[0], 'RTest::TestDB::Foo', 'First row class'); + Test::More::cmp_ok($rows[0]->id, '==', 1, 'First row id'); + + my $pager = $self->viewport->pager; + Test::More::cmp_ok($pager->current_page, '==', 1, 'Pager current page'); + Test::More::cmp_ok($pager->next_page, '==', 2, 'Pager next page'); + Test::More::ok(!defined($pager->previous_page), 'Pager previous page'); + Test::More::cmp_ok($pager->entries_per_page, '==', 10, 'Pager entries per page'); +} + +sub modify_viewport :Tests { + my ($self) = @_; + + $self->clear_viewport; + + $self->viewport->per_page(20); + $self->viewport->page(2); + + my $pager = $self->viewport->pager; + + Test::More::cmp_ok($pager->current_page, '==', 2, 'Pager current page'); + Test::More::cmp_ok($pager->last_page, '==', 5, 'Pager last page'); +} + +sub viewport_to_csv :Tests { + my ($self) = @_; + + $self->clear_viewport; + + $self->viewport->export_to_csv; + + Test::More::like($self->viewport->ctx->res->body, + qr/^Id,"First Name","Last Name"\r +1,Joe,"Bloggs 1"\r +2,John,"Smith 1"\r +3,Joe,"Bloggs 2"\r +4,John,"Smith 2"\r +5,Joe,"Bloggs 3"\r +6,John,"Smith 3"\r +7,Joe,"Bloggs 4"\r +8,John,"Smith 4"\r +9,Joe,"Bloggs 5"\r +10,John,"Smith 5"\r +/, "CSV export head ok"); + Test::More::like($self->viewport->ctx->res->body, + qr/100,John,"Smith 50"\r\n$/, "CSV export tail ok"); + +} + +1; diff --git a/t/lib/RTest/UI/Window.pm b/t/lib/RTest/UI/Window.pm new file mode 100644 index 0000000..2528f03 --- /dev/null +++ b/t/lib/RTest/UI/Window.pm @@ -0,0 +1,110 @@ +package RTest::UI::Window; + +use aliased 'Reaction::UI::ViewPort'; + +use base qw/Reaction::Test/; +use Reaction::Class; + +BEGIN { + + package RTest::UI::Window::_::view; + + use base qw/Reaction::UI::Renderer::XHTML/; + + sub render { + return $_[0]->{render}->(@_); + } + + package RTest::UI::Window::_::TestViewPort; + + use Reaction::Class; + + extends 'Reaction::UI::ViewPort'; + + register_inc_entry; + + sub handle_events { + $_[0]->{handle_events}->(@_); + } + +}; + +use Test::More (); +use Reaction::UI::Window; +use aliased 'RTest::UI::Window::_::TestViewPort'; + +has 'window' => ( + isa => 'Reaction::UI::Window', is => 'rw', + set_or_lazy_build('window') +); + +sub build_window { + my $self = shift; + return Reaction::UI::Window->new( + ctx => bless({}, 'Reaction::Test::Mock::Context'), + view_name => 'Test', + content_type => 'text/html', + ); +} + +sub test_window :Tests { + my $self = shift; + my $window = $self->build_window; + my $view = bless({}, 'RTest::UI::Window::_::view'); + $window->ctx->{view} = sub { + Test::More::is($_[1], 'Test', 'View name ok'); + return $view; + }; + Test::More::is($window->view, $view, 'View retrieved from context'); + my %param; + $window->ctx->{req} = sub { + return bless({ + query_parameters => sub { \%param }, + body_parameters => sub { {} }, + }, 'Reaction::Test::Mock::Request'); + }; + $window->ctx->{res} = sub { + return bless({ + status => sub { 200 }, + body => sub { '' }, + }, 'Reaction::Test::Mock::Response'); + }; + eval { $window->flush }; + Test::More::like($@, qr/empty focus stack/, 'Error thrown without viewports'); + my @vp; + push(@vp, $window->focus_stack + ->push_viewport(ViewPort, ctx => $window->ctx)); + push(@vp, $window->focus_stack + ->push_viewport(ViewPort, ctx => $window->ctx)); + my $i; + $view->{render} = sub { + my $expect_vp = $vp[$i++]; + Test::More::is($_[1], $window->ctx, 'Context ok'); + Test::More::is($_[2], 'component', 'Component template'); + Test::More::is($_[3]->{self}, $expect_vp, 'Viewport'); + $_[3]->{window}->render_viewport($expect_vp->inner); + return "foo"; + }; + my $body; + $window->ctx->{res} = sub { + return bless({ + body => sub { shift; return '' unless @_; $body = shift; }, + content_type => sub { }, + status => sub { 200 }, + }, 'Reaction::Test::Mock::Response'); + }; + $window->flush; + Test::More::is($body, 'foo', 'body set ok'); + my $test_vp = $vp[1]->create_tangent('foo') + ->push_viewport(TestViewPort, + ctx => bless({}, 'Catalyst')); + my $param_name = '1.foo.0:name'; + Test::More::is($test_vp->event_id_for('name'), $param_name, 'Event id ok'); + $param{$param_name} = 'blah'; + $test_vp->{handle_events} = sub { + Test::More::is($_[1]->{name}, 'blah', 'Event delivered ok'); + }; + $window->flush_events; +} + +1; diff --git a/t/simple.pl b/t/simple.pl new file mode 100644 index 0000000..0244f7c --- /dev/null +++ b/t/simple.pl @@ -0,0 +1,11 @@ +use strict; +use warnings; + +use lib 'lib'; +use ComponentUI; + +my $ctx = bless({ stash => {} }, 'ComponentUI'); + +my $view = ComponentUI->view('TT'); + +print $view->render($ctx, 'textfield', { self => { label => 'Label', message => 'Status message.' }, blocks => {} }); diff --git a/t/ui_focus_stack.t b/t/ui_focus_stack.t new file mode 100644 index 0000000..15bf439 --- /dev/null +++ b/t/ui_focus_stack.t @@ -0,0 +1,11 @@ +use lib 't/lib'; +use strict; +use warnings; + +use Test::Class; +use RTest::UI::FocusStack; + +Test::Class->runtests( + RTest::UI::FocusStack->new, +); + diff --git a/t/ui_viewport.t b/t/ui_viewport.t new file mode 100644 index 0000000..0cff6d8 --- /dev/null +++ b/t/ui_viewport.t @@ -0,0 +1,10 @@ +use lib 't/lib'; +use strict; +use warnings; + +use Test::Class; +use RTest::UI::ViewPort::ListView; + +Test::Class->runtests( + RTest::UI::ViewPort::ListView->new, +); diff --git a/t/ui_widget_listview.show b/t/ui_widget_listview.show new file mode 100644 index 0000000..05e3ab8 --- /dev/null +++ b/t/ui_widget_listview.show @@ -0,0 +1,43 @@ +use strict; +use warnings; +use Reaction::UI::Widget::ListView; +use Data::Dump::Streamer qw(Dump); + +my ($name, $data); + +sub FakeRCTX::render { + shift; + ($name, $data) = @_; +} + +sub FakeVP::field_names { [ qw(foo bar baz) ] } + +sub FakeVP::field_label_map { ({ foo => 'Foo', bar => 'Bar', baz => 'Baz' }); } + +my $w = bless({ viewport => 'VIEWPORT' }, 'Reaction::UI::Widget::ListView'); + +my $rctx = bless({}, 'FakeRCTX'); + +$w->render_header($rctx, { self => $w, viewport => bless({}, 'FakeVP') }); + +print "Name: ${name}\n"; +print "Data: "; +print Dump($data); + +my $first = $data->{_}->(); + +print "First: "; +print Dump($first); + +$first->($rctx); + +print "Name: ${name}\n"; +print "Data: "; +print Dump($data); + +my $inner = $data->{_}->(); + +print "Inner: "; +print Dump($inner); + +print $inner->(); diff --git a/t/ui_window.t b/t/ui_window.t new file mode 100644 index 0000000..0fcd1e8 --- /dev/null +++ b/t/ui_window.t @@ -0,0 +1,10 @@ +use lib 't/lib'; +use strict; +use warnings; + +use Test::Class; +use RTest::UI::Window; + +Test::Class->runtests( + RTest::UI::Window->new, +); |
