aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Reaction/UI/WidgetClass.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Reaction/UI/WidgetClass.pm')
-rw-r--r--lib/Reaction/UI/WidgetClass.pm283
1 files changed, 283 insertions, 0 deletions
diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm
new file mode 100644
index 0000000..9eadc35
--- /dev/null
+++ b/lib/Reaction/UI/WidgetClass.pm
@@ -0,0 +1,283 @@
+package Reaction::UI::WidgetClass;
+
+use Reaction::ClassExporter;
+use Reaction::Class;
+use Reaction::UI::Widget;
+use Data::Dumper;
+
+no warnings 'once';
+
+class WidgetClass, which {
+
+ overrides exports_for_package => sub {
+ my ($self, $package) = @_;
+ return (super(),
+ func => sub {
+ my ($k, $m) = @_;
+ my $sig = "should be: func(data_key => 'method_name')";
+ confess "Data key not present, ${sig}" unless defined($k);
+ confess "Data key must be string, ${sig}" unless !ref($k);
+ confess "Method name not present, ${sig}" unless defined($m);
+ confess "Method name must be string, ${sig}" unless !ref($m);
+ [ $k, $m ];
+ }, # XXX zis is not ze grand design. OBSERVABLE.
+ string => sub (&) { -string => [ @_ ] }, # meh (maybe &;@ later?)
+ wrap => sub { $self->do_wrap_sub($package, @_); }, # should have class.
+ );
+ };
+
+ overrides default_base => sub { ('Reaction::UI::Widget') };
+
+ overrides do_class_sub => sub {
+ my ($self, $package, $class) = @_;
+ # intercepts 'foo renders ...'
+ local *renders::AUTOLOAD = sub {
+ our $AUTOLOAD;
+ shift;
+ $AUTOLOAD =~ /^renders::(.*)$/;
+ $self->do_renders_meth($package, $class, $1, @_);
+ };
+ # intercepts 'foo over ...'
+ local *over::AUTOLOAD = sub {
+ our $AUTOLOAD;
+ shift;
+ $AUTOLOAD =~ /^over::(.*)$/;
+ $self->do_over_meth($package, $class, $1, @_);
+ };
+ # $_ returns '-topic:_', $_{foo} returns '-topic:foo'
+ local $_ = '-topic:_';
+ my %topichash;
+ tie %topichash, 'Reaction::UI::WidgetClass::TopicHash';
+ local *_ = \%topichash;
+ super;
+ };
+
+ implements do_wrap_sub => as { confess "Unimplemented" };
+
+ implements do_renders_meth => as {
+ my ($self, $package, $class, $fname, $content, $args, $extra) = @_;
+
+ my $sig = 'should be: renders [ <content spec> ], \%args?';
+
+ confess "Too many args to renders, ${sig}" if defined($extra);
+ confess "First arg not an arrayref, ${sig}" unless ref($content) eq 'ARRAY';
+ confess "Args must be hashref, ${sig}"
+ if (defined($args) && (ref($args) ne 'HASH'));
+
+ $sig .= '
+ where content spec is [ fragment_name over func(...), \%args? ]
+ or [ qw(list of fragment names), \%args ]'; # explain the mistake, yea
+
+ my $inner_args = ((ref($content->[-1]) eq 'HASH') ? pop(@$content) : {});
+ # [ blah over func(...), { ... } ] or [ qw(foo bar), { ... } ]
+
+ # predeclare since content_gen gets populated somewhere in an if
+ # and inner_args_gen wants to be closed over by content_gen
+
+ my ($content_gen, $inner_args_gen);
+
+ my %args_extra; # again populated (possibly) within the if
+
+ confess "Content spec invalid, ${sig}"
+ unless defined($content->[0]) && !ref($content->[0]);
+
+ if (my ($key) = ($content->[0] =~ /^-(.*)?/)) {
+
+ # if first content value is -foo, pull it off the front and then
+ # figure out is it's a type we know how to handle
+
+ shift(@$content);
+ if ($key eq 'over') { # fragment_name over func
+ my ($fragment, $func) = @$content;
+ confess "Fragment name invalid, ${sig}" if ref($fragment);
+ my $content_meth = "render_${fragment}";
+ # grab result of func
+ # - if arrayref, render fragment per entry
+ # - if obj and can('next') call that until undef
+ # - else scream loudly
+ my ($func_key, $func_meth) = @$func;
+ $content_gen = sub {
+ my ($widget, $args) = @_;
+ my $topic = eval { $args->{$func_key}->$func_meth };
+ confess "Error calling ${func_meth} on ${func_key} argument "
+ .($args->{$func_key}||'').": $@"
+ if $@;
+ my $iter_sub;
+ if (ref $topic eq 'ARRAY') {
+ my @copy = @$topic; # non-destructive on original data
+ $iter_sub = sub { shift(@copy); };
+ } elsif (Scalar::Util::blessed($topic) && $topic->can('next')) {
+ $iter_sub = sub { $topic->next };
+ } else {
+ #confess "func(${func_key} => ${func_meth}) for topic within fragment ${fname} did not return arrayref or iterator object";
+ # Coercing to a single-arg list instead for the mo. Mistake?
+ my @copy = ($topic);
+ $iter_sub = sub { shift(@copy); };
+ }
+ my $inner_args = $inner_args_gen->($args);
+ return sub {
+ my $next = $iter_sub->();
+ return undef unless $next;
+ return sub {
+ my ($rctx) = @_;
+ local $inner_args->{'_'} = $next; # ala local $_, why copy?
+ $widget->$content_meth($rctx, $inner_args);
+ };
+ };
+ };
+ } elsif ($key eq 'string') {
+
+ # string { ... }
+
+ my $sub = $content->[0]->[0]; # string {} returns (-string => [ $cr ])
+ $content_gen = sub {
+ my ($widget, $args) = @_;
+ my $done = 0;
+ my $inner_args = $inner_args_gen->($args);
+ return sub {
+ return if $done++; # a string content only happens once
+ return sub { # setup $_{foo} etc. and alias $_ to $_{_}
+ my ($rctx) = @_;
+ local *_ = \%{$inner_args};
+ local $_ = $inner_args->{'_'};
+ $sub->($rctx);
+ };
+ };
+ };
+
+ # must also handle just $_ later for wrap
+ } else {
+ # unrecognised -foo
+ confess "Unrecognised content spec type ${key}, ${sig}";
+ }
+ } else {
+
+ # handling the renders [ qw(list of frag names), \%args ] case
+
+#warn @$content;
+ confess "Invalid content spec, ${sig}"
+ if grep { ref($_) } @$content;
+ $content_gen = sub {
+ my ($widget, $args) = @_;
+ my @fragment_methods = map { "render_${_}" } @$content;
+ my $inner_args = $inner_args_gen->($args);
+ return sub {
+ my $next = shift(@fragment_methods);
+ return undef unless $next;
+ return sub {
+ my ($rctx) = @_;
+ $widget->$next($rctx, $inner_args);
+ };
+ };
+ };
+
+ foreach my $key (@$content) {
+ my $frag_meth = "render_${key}";
+ $args_extra{$key} = sub {
+ my ($widget, $args) = @_;
+ my $inner_args = $inner_args_gen->($args);
+ return sub {
+ my ($rctx) = @_;
+ $widget->$frag_meth($rctx, $inner_args);
+ };
+ };
+ }
+ }
+
+ # populate both args generators here primarily for clarity
+
+ my $args_gen = $self->mk_args_generator($args);
+ $inner_args_gen = $self->mk_args_generator($inner_args);
+
+ my $methname = "render_${fname}";
+
+ $args_extra{'_'} = $content_gen;
+
+ my @extra_keys = keys %args_extra;
+ my @extra_gen = values %args_extra;
+
+ my $meth = sub {
+ my ($self, $rctx, $args) = @_;
+ confess "No rendering context passed" unless $rctx;
+ my $r_args = $args_gen->($args);
+#warn Dumper($r_args).' ';
+ @{$r_args}{@extra_keys} = map { $_->($self, $args); } @extra_gen;
+ $r_args->{'_'} = $content_gen->($self, $args);
+#warn Dumper($r_args).' ';
+ $rctx->render($fname, $r_args);
+ };
+
+ $class->meta->add_method($methname => $meth);
+ };
+
+ implements do_over_meth => as {
+ my ($self, $package, $class, @args) = @_;
+ #warn Dumper(\@args);
+ return (-over => @args);
+ };
+
+ implements mk_args_generator => as {
+ my ($self, $argspec) = @_;
+#warn Dumper($argspec);
+ # only handling [ $k, $v ] (func()) and -topic:$x ($_{$x}) for the moment
+
+ my $sig = 'should be: key => $_ or key => $_{name} or key => func("name", "method")';
+
+ my (@func_to, @func_spec, @copy_from, @copy_to);
+ foreach my $key (keys %$argspec) {
+ my $val = $argspec->{$key};
+ if (ref($val) eq 'ARRAY') {
+ push(@func_spec, $val);
+ push(@func_to, $key);
+ } elsif (!ref($val) && ($val =~ /^-topic:(.*)$/)) {
+ my $topic_key = $1;
+ push(@copy_from, $topic_key);
+ push(@copy_to, $key);
+ } else {
+ confess "Invalid args member for ${key}, ${sig}";
+ }
+ }
+#warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to);
+ return sub {
+ my ($outer_args) = @_;
+ my $args = { %$outer_args };
+#warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to).' ';
+ @{$args}{@copy_to} = @{$outer_args}{@copy_from};
+ @{$args}{@func_to} = (map {
+ my ($key, $meth) = @{$_};
+ $outer_args->{$key}->$meth; # [ 'a, 'b' ] ~~ ->{'a'}->b
+ } @func_spec);
+#warn Dumper($args).' ';
+ return $args;
+ };
+ };
+
+};
+
+package Reaction::UI::WidgetClass::TopicHash;
+
+use Tie::Hash;
+use base qw(Tie::StdHash);
+
+sub FETCH {
+ my ($self, $key) = @_;
+ return "-topic:${key}";
+}
+
+1;
+
+=head1 NAME
+
+Reaction::UI::WidgetClass
+
+=head1 DESCRIPTION
+
+=head1 AUTHORS
+
+See L<Reaction::Class> for authors.
+
+=head1 LICENSE
+
+See L<Reaction::Class> for the license.
+
+=cut
generated by cgit v1.2.3-54-g00ecf (git 2.45.1) at 2024-06-13 04:31:36 +0000