Commit | Line | Data |
7adfd53f |
1 | package Reaction::UI::WidgetClass; |
2 | |
3 | use Reaction::ClassExporter; |
4 | use Reaction::Class; |
5 | use Reaction::UI::Widget; |
6 | use Data::Dumper; |
ce0ce002 |
7 | use Devel::Declare; |
7adfd53f |
8 | |
9 | no warnings 'once'; |
10 | |
11 | class WidgetClass, which { |
12 | |
13 | overrides exports_for_package => sub { |
14 | my ($self, $package) = @_; |
15 | return (super(), |
16 | func => sub { |
17 | my ($k, $m) = @_; |
18 | my $sig = "should be: func(data_key => 'method_name')"; |
19 | confess "Data key not present, ${sig}" unless defined($k); |
20 | confess "Data key must be string, ${sig}" unless !ref($k); |
21 | confess "Method name not present, ${sig}" unless defined($m); |
22 | confess "Method name must be string, ${sig}" unless !ref($m); |
23 | [ $k, $m ]; |
24 | }, # XXX zis is not ze grand design. OBSERVABLE. |
25 | string => sub (&) { -string => [ @_ ] }, # meh (maybe &;@ later?) |
26 | wrap => sub { $self->do_wrap_sub($package, @_); }, # should have class. |
ce0ce002 |
27 | fragment => sub (@) { }, # placeholder rewritten by do_import |
2e3dcc8d |
28 | over => sub { -over => @_ }, |
ce0ce002 |
29 | ); |
30 | }; |
31 | |
32 | after do_import => sub { |
33 | my ($self, $pkg, $args) = @_; |
34 | |
35 | Devel::Declare->install_declarator( |
36 | $pkg, 'fragment', DECLARE_NAME, |
37 | sub { }, |
38 | sub { |
39 | our $FRAGMENT_CLOSURE; |
40 | splice(@_, 1, 1); # remove undef proto arg |
41 | $FRAGMENT_CLOSURE->(@_); |
42 | } |
7adfd53f |
43 | ); |
44 | }; |
45 | |
46 | overrides default_base => sub { ('Reaction::UI::Widget') }; |
47 | |
48 | overrides do_class_sub => sub { |
49 | my ($self, $package, $class) = @_; |
50 | # intercepts 'foo renders ...' |
ce0ce002 |
51 | our $FRAGMENT_CLOSURE; |
52 | local $FRAGMENT_CLOSURE = sub { |
53 | $self->do_renders_meth($package, $class, @_); |
7adfd53f |
54 | }; |
7adfd53f |
55 | # $_ returns '-topic:_', $_{foo} returns '-topic:foo' |
56 | local $_ = '-topic:_'; |
57 | my %topichash; |
58 | tie %topichash, 'Reaction::UI::WidgetClass::TopicHash'; |
59 | local *_ = \%topichash; |
60 | super; |
61 | }; |
62 | |
63 | implements do_wrap_sub => as { confess "Unimplemented" }; |
64 | |
65 | implements do_renders_meth => as { |
66 | my ($self, $package, $class, $fname, $content, $args, $extra) = @_; |
67 | |
68 | my $sig = 'should be: renders [ <content spec> ], \%args?'; |
69 | |
70 | confess "Too many args to renders, ${sig}" if defined($extra); |
71 | confess "First arg not an arrayref, ${sig}" unless ref($content) eq 'ARRAY'; |
72 | confess "Args must be hashref, ${sig}" |
73 | if (defined($args) && (ref($args) ne 'HASH')); |
74 | |
75 | $sig .= ' |
2e3dcc8d |
76 | where content spec is [ fragment_name => over (func(...)|$_|$_{keyname}), \%args? ] |
7adfd53f |
77 | or [ qw(list of fragment names), \%args ]'; # explain the mistake, yea |
78 | |
79 | my $inner_args = ((ref($content->[-1]) eq 'HASH') ? pop(@$content) : {}); |
e716714f |
80 | # [ blah over (func(...)|$_|$_{keyname}), { ... } ] or [ qw(foo bar), { ... } ] |
7adfd53f |
81 | |
82 | # predeclare since content_gen gets populated somewhere in an if |
83 | # and inner_args_gen wants to be closed over by content_gen |
84 | |
85 | my ($content_gen, $inner_args_gen); |
86 | |
87 | my %args_extra; # again populated (possibly) within the if |
88 | |
89 | confess "Content spec invalid, ${sig}" |
90 | unless defined($content->[0]) && !ref($content->[0]); |
91 | |
2e3dcc8d |
92 | # new-style over gives 'frag, -over, $func'. massage. |
93 | |
94 | if (defined($content->[1]) && !ref($content->[1]) |
95 | && ($content->[1] eq '-over')) { |
96 | @$content[0,1] = @$content[1,0]; |
97 | } |
98 | |
7adfd53f |
99 | if (my ($key) = ($content->[0] =~ /^-(.*)?/)) { |
100 | |
101 | # if first content value is -foo, pull it off the front and then |
102 | # figure out is it's a type we know how to handle |
103 | |
104 | shift(@$content); |
105 | if ($key eq 'over') { # fragment_name over func |
106 | my ($fragment, $func) = @$content; |
107 | confess "Fragment name invalid, ${sig}" if ref($fragment); |
108 | my $content_meth = "render_${fragment}"; |
109 | # grab result of func |
110 | # - if arrayref, render fragment per entry |
111 | # - if obj and can('next') call that until undef |
112 | # - else scream loudly |
e716714f |
113 | unless ((ref($func) eq 'ARRAY') || ($func =~ /^-topic:(.*)$/)) { |
114 | confess "over value wrong, should be ${sig}"; |
115 | } |
7adfd53f |
116 | $content_gen = sub { |
117 | my ($widget, $args) = @_; |
e716714f |
118 | my $topic; |
119 | if (ref($func) eq 'ARRAY') { |
120 | my ($func_key, $func_meth) = @$func; |
121 | $topic = eval { $args->{$func_key}->$func_meth }; |
122 | confess "Error calling ${func_meth} on ${func_key} argument " |
123 | .($args->{$func_key}||'').": $@" |
124 | if $@; |
125 | } elsif ($func =~ /^-topic:(.*)$/) { |
126 | $topic = $args->{$1}; |
127 | } else { |
128 | confess "Shouldn't get here"; |
129 | } |
7adfd53f |
130 | my $iter_sub; |
131 | if (ref $topic eq 'ARRAY') { |
132 | my @copy = @$topic; # non-destructive on original data |
133 | $iter_sub = sub { shift(@copy); }; |
134 | } elsif (Scalar::Util::blessed($topic) && $topic->can('next')) { |
135 | $iter_sub = sub { $topic->next }; |
136 | } else { |
137 | #confess "func(${func_key} => ${func_meth}) for topic within fragment ${fname} did not return arrayref or iterator object"; |
138 | # Coercing to a single-arg list instead for the mo. Mistake? |
139 | my @copy = ($topic); |
140 | $iter_sub = sub { shift(@copy); }; |
141 | } |
142 | my $inner_args = $inner_args_gen->($args); |
143 | return sub { |
144 | my $next = $iter_sub->(); |
145 | return undef unless $next; |
146 | return sub { |
147 | my ($rctx) = @_; |
148 | local $inner_args->{'_'} = $next; # ala local $_, why copy? |
149 | $widget->$content_meth($rctx, $inner_args); |
150 | }; |
151 | }; |
152 | }; |
153 | } elsif ($key eq 'string') { |
154 | |
155 | # string { ... } |
156 | |
157 | my $sub = $content->[0]->[0]; # string {} returns (-string => [ $cr ]) |
158 | $content_gen = sub { |
159 | my ($widget, $args) = @_; |
160 | my $done = 0; |
161 | my $inner_args = $inner_args_gen->($args); |
162 | return sub { |
163 | return if $done++; # a string content only happens once |
164 | return sub { # setup $_{foo} etc. and alias $_ to $_{_} |
165 | my ($rctx) = @_; |
166 | local *_ = \%{$inner_args}; |
167 | local $_ = $inner_args->{'_'}; |
168 | $sub->($rctx); |
169 | }; |
170 | }; |
171 | }; |
87018d74 |
172 | |
7adfd53f |
173 | # must also handle just $_ later for wrap |
174 | } else { |
175 | # unrecognised -foo |
176 | confess "Unrecognised content spec type ${key}, ${sig}"; |
177 | } |
178 | } else { |
179 | |
180 | # handling the renders [ qw(list of frag names), \%args ] case |
181 | |
182 | #warn @$content; |
183 | confess "Invalid content spec, ${sig}" |
184 | if grep { ref($_) } @$content; |
185 | $content_gen = sub { |
186 | my ($widget, $args) = @_; |
187 | my @fragment_methods = map { "render_${_}" } @$content; |
188 | my $inner_args = $inner_args_gen->($args); |
189 | return sub { |
190 | my $next = shift(@fragment_methods); |
191 | return undef unless $next; |
192 | return sub { |
193 | my ($rctx) = @_; |
194 | $widget->$next($rctx, $inner_args); |
195 | }; |
196 | }; |
197 | }; |
198 | |
199 | foreach my $key (@$content) { |
200 | my $frag_meth = "render_${key}"; |
201 | $args_extra{$key} = sub { |
202 | my ($widget, $args) = @_; |
203 | my $inner_args = $inner_args_gen->($args); |
204 | return sub { |
205 | my ($rctx) = @_; |
206 | $widget->$frag_meth($rctx, $inner_args); |
207 | }; |
208 | }; |
209 | } |
210 | } |
211 | |
212 | # populate both args generators here primarily for clarity |
213 | |
214 | my $args_gen = $self->mk_args_generator($args); |
215 | $inner_args_gen = $self->mk_args_generator($inner_args); |
216 | |
217 | my $methname = "render_${fname}"; |
218 | |
219 | $args_extra{'_'} = $content_gen; |
220 | |
221 | my @extra_keys = keys %args_extra; |
222 | my @extra_gen = values %args_extra; |
87018d74 |
223 | |
7adfd53f |
224 | my $meth = sub { |
225 | my ($self, $rctx, $args) = @_; |
226 | confess "No rendering context passed" unless $rctx; |
227 | my $r_args = $args_gen->($args); |
228 | #warn Dumper($r_args).' '; |
229 | @{$r_args}{@extra_keys} = map { $_->($self, $args); } @extra_gen; |
230 | $r_args->{'_'} = $content_gen->($self, $args); |
231 | #warn Dumper($r_args).' '; |
d8c7a86e |
232 | $rctx->render($self->layout_set, $fname, $r_args); |
7adfd53f |
233 | }; |
234 | |
235 | $class->meta->add_method($methname => $meth); |
236 | }; |
237 | |
238 | implements do_over_meth => as { |
239 | my ($self, $package, $class, @args) = @_; |
240 | #warn Dumper(\@args); |
241 | return (-over => @args); |
242 | }; |
243 | |
244 | implements mk_args_generator => as { |
245 | my ($self, $argspec) = @_; |
246 | #warn Dumper($argspec); |
247 | # only handling [ $k, $v ] (func()) and -topic:$x ($_{$x}) for the moment |
248 | |
249 | my $sig = 'should be: key => $_ or key => $_{name} or key => func("name", "method")'; |
250 | |
87018d74 |
251 | my (@func_to, @func_spec, @copy_from, @copy_to, @sub_spec, @sub_to); |
7adfd53f |
252 | foreach my $key (keys %$argspec) { |
253 | my $val = $argspec->{$key}; |
254 | if (ref($val) eq 'ARRAY') { |
255 | push(@func_spec, $val); |
256 | push(@func_to, $key); |
257 | } elsif (!ref($val) && ($val =~ /^-topic:(.*)$/)) { |
258 | my $topic_key = $1; |
259 | push(@copy_from, $topic_key); |
260 | push(@copy_to, $key); |
87018d74 |
261 | } elsif (ref($val) eq 'CODE') { |
262 | #LOOK AT ME |
263 | my $sub = sub{ |
264 | my $inner_args = shift; |
265 | local *_ = \%{$inner_args}; |
266 | local $_ = $inner_args->{'_'}; |
267 | return $val->(); |
268 | }; |
269 | push(@sub_spec, $sub); |
270 | push(@sub_to, $key); |
7adfd53f |
271 | } else { |
272 | confess "Invalid args member for ${key}, ${sig}"; |
273 | } |
274 | } |
275 | #warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to); |
276 | return sub { |
277 | my ($outer_args) = @_; |
278 | my $args = { %$outer_args }; |
279 | #warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to).' '; |
280 | @{$args}{@copy_to} = @{$outer_args}{@copy_from}; |
281 | @{$args}{@func_to} = (map { |
282 | my ($key, $meth) = @{$_}; |
283 | $outer_args->{$key}->$meth; # [ 'a, 'b' ] ~~ ->{'a'}->b |
284 | } @func_spec); |
87018d74 |
285 | #LOOK AT ME |
286 | @{$args}{@sub_to} = (map { $_->($outer_args) } @sub_spec); |
7adfd53f |
287 | #warn Dumper($args).' '; |
288 | return $args; |
289 | }; |
290 | }; |
87018d74 |
291 | |
7adfd53f |
292 | }; |
293 | |
87018d74 |
294 | 1; |
295 | |
7adfd53f |
296 | package Reaction::UI::WidgetClass::TopicHash; |
297 | |
298 | use Tie::Hash; |
299 | use base qw(Tie::StdHash); |
300 | |
301 | sub FETCH { |
302 | my ($self, $key) = @_; |
303 | return "-topic:${key}"; |
304 | } |
305 | |
306 | 1; |
307 | |
87018d74 |
308 | __END__; |
309 | |
7adfd53f |
310 | =head1 NAME |
311 | |
312 | Reaction::UI::WidgetClass |
313 | |
314 | =head1 DESCRIPTION |
315 | |
316 | =head1 AUTHORS |
317 | |
318 | See L<Reaction::Class> for authors. |
319 | |
320 | =head1 LICENSE |
321 | |
322 | See L<Reaction::Class> for the license. |
323 | |
324 | =cut |