Commit | Line | Data |
192db6f8 |
1 | package CatalystX::DynamicComponent::ModelToControllerReflector; |
59fc9d16 |
2 | use Moose::Role; |
abcde601 |
3 | use Moose::Util qw/does_role/; |
279c014c |
4 | use List::MoreUtils qw/uniq/; |
3765b9ee |
5 | use Moose::Autobox; |
046d763d |
6 | use namespace::autoclean; |
59fc9d16 |
7 | |
28627027 |
8 | my $mangle_attributes_on_generated_methods = sub { |
9 | my ($meta, $config) = @_; |
10 | foreach my $name (keys %{ $config->{methods}}) { |
11 | my $m = $meta->get_method($name); |
83c57636 |
12 | $meta->register_method_attributes($m->body, ['Local']); |
28627027 |
13 | } |
14 | }; |
15 | |
53a42ae0 |
16 | with 'CatalystX::DynamicComponent' => { |
17 | name => '_setup_dynamic_controller', |
28627027 |
18 | pre_immutable_hook => $mangle_attributes_on_generated_methods, |
53a42ae0 |
19 | }; |
59fc9d16 |
20 | |
cbc455a6 |
21 | requires 'setup_components'; |
59fc9d16 |
22 | |
cbc455a6 |
23 | after 'setup_components' => sub { shift->_setup_dynamic_controllers(@_); }; |
59fc9d16 |
24 | |
25 | sub _setup_dynamic_controllers { |
26 | my ($app) = @_; |
00b934f1 |
27 | |
62680454 |
28 | my @model_names = grep { /::Model::/ } keys %{ $app->components }; |
59fc9d16 |
29 | foreach my $model_name (@model_names) { |
6a2f1e96 |
30 | $app->_reflect_model_to_controller( $model_name, $app->components->{$model_name} ); |
59fc9d16 |
31 | } |
32 | } |
33 | |
6a2f1e96 |
34 | sub _reflect_model_to_controller { |
35 | my ( $app, $model_name, $model ) = @_; |
36 | |
fd379fe9 |
37 | # Model passed in as MyApp::Model::Foo, strip MyApp |
38 | $model_name =~ s/^[^:]+:://; |
77e54b00 |
39 | |
fd379fe9 |
40 | # Get Controller::Foo |
6a2f1e96 |
41 | my $controller_name = $model_name; |
fd379fe9 |
42 | $controller_name =~ s/^Model::/Controller::/; |
6a2f1e96 |
43 | |
fd379fe9 |
44 | # Get Foo |
77e54b00 |
45 | my $suffix = $model_name; |
fd379fe9 |
46 | $suffix =~ s/Model:://; |
77e54b00 |
47 | |
549d6abc |
48 | my %controller_methods; |
192db6f8 |
49 | # FIXME - Abstract this strategy crap out. |
549d6abc |
50 | my $model_methods = $model->meta->get_method_map; |
d0fd9aa1 |
51 | my $interface_roles = [ uniq( map { exists $_->{interface_roles} ? $_->{interface_roles}->flatten : () } $app->config->{$model_name}, $app->config->{'CatalystX::DynamicComponent::ModelToControllerReflector'} ) ]; |
3765b9ee |
52 | |
62680454 |
53 | for my $interface_role (@$interface_roles) { |
6eb165c2 |
54 | for my $required_method ($interface_role->meta->get_required_method_list) { |
55 | # Note need to pass model name, as the method actually comes from |
56 | # the underlying model class, not the Catalyst shim class we autogenerated. |
57 | $controller_methods{$required_method} = |
58 | $app->generate_reflected_controller_action_method($suffix, $model_methods->{$required_method}) |
59 | } |
77e54b00 |
60 | } |
549d6abc |
61 | |
4e8f668c |
62 | # Shallow copy so we don't stuff method refs in config |
96e54fc3 |
63 | my $config = { %{$app->config->{$controller_name}||{}} }; |
64 | |
c52d8688 |
65 | $config->{methods} = \%controller_methods; |
66 | $app->_setup_dynamic_controller( $controller_name, $config ); |
2f61148c |
67 | } |
68 | |
77e54b00 |
69 | sub generate_reflected_controller_action_method { |
70 | my ( $app, $model, $method ) = @_; |
71 | my $method_name = $method->name; # Is it worth passing the actual method object here? |
72 | sub { |
73 | my ($self, $c, @args) = @_; |
74 | $c->res->header('X-From-Model', $model); |
d7bd7765 |
75 | my $response = $c->model($model)->$method_name($c->req->data); |
76 | $c->res->header('X-From-Model-Data', $response); |
77e54b00 |
77 | $c->res->body('OK'); |
d7bd7765 |
78 | $c->stash->{response} = $response; |
77e54b00 |
79 | }; |
59fc9d16 |
80 | } |
81 | |
82 | 1; |
83 | |
7299c4b9 |
84 | __END__ |
85 | |
86 | =head1 NAME |
87 | |
88 | CatalystX::DynamicComponent::ModelToControllerReflector - Generate Catalyst controllers automaticall from models and configuration. |
89 | |
90 | =head1 SYNOPSIS |
91 | |
92 | =head1 DESCRIPTION |
93 | |
94 | =head1 LINKS |
95 | |
96 | L<Catalyst>, L<MooseX::MethodAttributes>, L<CatalystX::ModelsFromConfig>. |
97 | |
98 | =head1 BUGS |
99 | |
100 | Probably plenty, test suite certainly isn't comprehensive.. Patches welcome. |
101 | |
102 | =head1 AUTHOR |
103 | |
104 | Tomas Doran (t0m) <bobtfish@bobtfish.net> |
105 | |
106 | =head1 LICENSE |
107 | |
108 | This code is copyright (c) 2009 Tomas Doran. This code is licensed on the same terms as perl |
109 | itself. |
110 | |
111 | =cut |
112 | |