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