--- /dev/null
+This file documents the revision history for Perl extension ComponentUI.
+
+0.01 2006-08-01 17:49:50
+ - initial revision, generated by Catalyst
--- /dev/null
+# 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/
--- /dev/null
+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;
--- /dev/null
+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.
--- /dev/null
+using_frontend_proxy 1
+
+<Controller Foo>
+ <action update>
+ <ViewPort>
+ <Field baz_list>
+ layout checkbox_group
+ </Field>
+ </ViewPort>
+ </Action>
+</Controller>
--- /dev/null
+=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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+package ComponentUI::View::XHTML;
+
+use Reaction::Class;
+
+extends 'Reaction::UI::Renderer::XHTML';
+
+1;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+=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
--- /dev/null
+=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
--- /dev/null
+=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
--- /dev/null
+=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
--- /dev/null
+=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
--- /dev/null
+=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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+package Reaction::UI::RenderingContext;
+
+use Reaction::Class;
+
+class RenderingContext which {
+
+ implements 'render' => as {
+ confess "abstract method";
+ };
+
+};
+
+1;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+[%
+
+attrs.enctype = 'multipart/form-data';
+PROCESS form_base;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[% PROCESS form_base %]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+PROCESS button;
+
+control_block = 'cancelbtn_control';
+
+BLOCK cancelbtn_control;
+
+ INCLUDE button_control attrs.value = 'Cancel' self.event = 'close';
+
+END;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%-
+
+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;
+
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+PROCESS displayfield_base;
+
+control_block = 'string_control';
+
+BLOCK string_control;
+
+ self.value | html;
+
+END;
+
+%]
--- /dev/null
+[%
+
+PROCESS displayfield_base;
+
+control_block = 'text_control';
+
+BLOCK text_control;
+
+ self.value | html;
+
+END;
+
+%]
--- /dev/null
+[%
+
+PROCESS displayfield_base;
+
+control_block = 'vstring_control';
+
+BLOCK vstring_control;
+
+ self.value_string | html;
+
+END;
+
+%]
--- /dev/null
+[%-
+
+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;
+
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%-
+
+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;
+
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%-
+
+#main_block = 'footer';
+
+#BLOCK footer;
+
+ %]<p>FOOTER</p>
+ [%
+
+#END;
+
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%-
+
+#main_block = 'header_block';
+
+#BLOCK header_block;
+
+ %]<p>HEADER</p>[%
+
+#END;
+
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+main_block = 'image_base';
+
+BLOCK image_base;
+
+ %]<img src="[% self.img_src | html %]" alt="[% self.text | html %]"[% process_attrs(attrs) %] />[%
+
+END;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[% PROCESS view_base %]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+PROCESS field_base;
+
+control_block = 'radio_control';
+
+BLOCK radio_control;
+
+ %]<input type="radio" id="[% id_attr %]" [% connect_control(self, 'value');
+ process_attrs(attrs) %] />[%
+
+END;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+PROCESS button;
+
+control_block = 'resetbtn_control';
+
+BLOCK resetbtn_control;
+
+ INCLUDE button_control button_type = 'reset' attrs.value = 'Reset';
+
+END;
+
+%]
--- /dev/null
+[%
+
+PROCESS field_base;
+
+control_block = 'search_base_control';
+
+BLOCK search_base_control;
+
+ INCLUDE component type = 'textfield';
+ INCLUDE component type = 'submitbtn' attrs.value = 'Search';
+
+END;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+PROCESS select;
+
+control_block = 'select_group_control';
+
+BLOCK select_group_control;
+
+ INCLUDE select_control attrs.multiple = 'multiple';
+ attrs.multiple = '';
+
+END;
+
+%]
--- /dev/null
+[%
+
+PROCESS button;
+
+control_block = 'submitbtn_control';
+
+BLOCK submitbtn_control;
+
+ INCLUDE button_control button_type = 'submit' attrs.value = 'Submit' self.event = 'ok';
+
+END;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+[% 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';
+-%]
--- /dev/null
+[%
+
+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;
+
+%]
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+#!/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
--- /dev/null
+#!/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;
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+BEGIN { use_ok 'Catalyst::Test', 'ComponentUI' }
+
+ok( request('/')->is_success, 'Request should succeed' );
--- /dev/null
+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();
--- /dev/null
+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");
+}
--- /dev/null
+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);
+}
--- /dev/null
+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;
--- /dev/null
+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(),
+);
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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;
--- /dev/null
+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 => {} });
--- /dev/null
+use lib 't/lib';
+use strict;
+use warnings;
+
+use Test::Class;
+use RTest::UI::FocusStack;
+
+Test::Class->runtests(
+ RTest::UI::FocusStack->new,
+);
+
--- /dev/null
+use lib 't/lib';
+use strict;
+use warnings;
+
+use Test::Class;
+use RTest::UI::ViewPort::ListView;
+
+Test::Class->runtests(
+ RTest::UI::ViewPort::ListView->new,
+);
--- /dev/null
+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->();
--- /dev/null
+use lib 't/lib';
+use strict;
+use warnings;
+
+use Test::Class;
+use RTest::UI::Window;
+
+Test::Class->runtests(
+ RTest::UI::Window->new,
+);
projects / catagits/Reaction.git / commitdiff
