lib/Reaction/UI/WidgetClass.pm

   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 .= '
  68 where content spec is [ fragment_name over (func(...)|$_|$_{keyname}), \%args? ]
  69   or [ qw(list of fragment names), \%args ]'; # explain the mistake, yea
  70
  71     my $inner_args = ((ref($content->[-1]) eq 'HASH') ? pop(@$content) : {});
  72     # [ blah over (func(...)|$_|$_{keyname}), { ... } ] or [ qw(foo bar), { ... } ]
  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
  98         unless ((ref($func) eq 'ARRAY') || ($func =~ /^-topic:(.*)$/)) {
  99           confess "over value wrong, should be ${sig}";
 100         }
 101         $content_gen = sub {
 102           my ($widget, $args) = @_;
 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           }
 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         };
 157
 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;
 208
 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
 236     my (@func_to, @func_spec, @copy_from, @copy_to, @sub_spec, @sub_to);
 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);
 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);
 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);
 270       #LOOK AT ME
 271       @{$args}{@sub_to} = (map { $_->($outer_args) } @sub_spec);
 272 #warn Dumper($args).' ';
 273       return $args;
 274     };
 275   };
 276
 277 };
 278
 279 1;
 280
 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
 293 __END__;
 294
 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