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