widget now passes layoutset to rendering context

[catagits/Reaction.git] / lib / Reaction / UI / WidgetClass.pm

diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm
index 9eadc35..ba8f70a 100644 (file)
--- a/lib/Reaction/UI/WidgetClass.pm
+++ b/lib/Reaction/UI/WidgetClass.pm
@@ -4,6 +4,7 @@ use Reaction::ClassExporter;
 use Reaction::Class;
 use Reaction::UI::Widget;
 use Data::Dumper;
+use Devel::Declare;
 
 no warnings 'once';
 
@@ -23,6 +24,22 @@ class WidgetClass, which {
               }, # XXX zis is not ze grand design. OBSERVABLE.
       string => sub (&) { -string => [ @_ ] }, # meh (maybe &;@ later?)
       wrap => sub { $self->do_wrap_sub($package, @_); }, # should have class.
+      fragment => sub (@) { }, # placeholder rewritten by do_import
+      over => sub { -over => @_ },
+    );
+  };
+
+  after do_import => sub {
+    my ($self, $pkg, $args) = @_;
+
+    Devel::Declare->install_declarator(
+      $pkg, 'fragment', DECLARE_NAME,
+      sub { },
+      sub {
+        our $FRAGMENT_CLOSURE;
+        splice(@_, 1, 1); # remove undef proto arg
+        $FRAGMENT_CLOSURE->(@_);
+      }
     );
   };
 
@@ -31,18 +48,9 @@ class WidgetClass, which {
   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, @_);
+    our $FRAGMENT_CLOSURE;
+    local $FRAGMENT_CLOSURE = sub {
+      $self->do_renders_meth($package, $class, @_);
     };
     # $_ returns '-topic:_', $_{foo} returns '-topic:foo'
     local $_ = '-topic:_';
@@ -65,11 +73,11 @@ class WidgetClass, which {
       if (defined($args) && (ref($args) ne 'HASH'));
 
     $sig .= '
-  where content spec is [ fragment_name over func(...), \%args? ]
+where content spec is [ fragment_name => over (func(...)|$_|$_{keyname}), \%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), { ... } ]
+    # [ blah over (func(...)|$_|$_{keyname}), { ... } ] 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
@@ -81,6 +89,13 @@ class WidgetClass, which {
     confess "Content spec invalid, ${sig}"
       unless defined($content->[0]) && !ref($content->[0]);
 
+    # new-style over gives 'frag, -over, $func'. massage.
+
+    if (defined($content->[1]) && !ref($content->[1])
+        && ($content->[1] eq '-over')) {
+      @$content[0,1] = @$content[1,0];
+    }
+
     if (my ($key) = ($content->[0] =~ /^-(.*)?/)) {
 
       # if first content value is -foo, pull it off the front and then
@@ -95,13 +110,23 @@ class WidgetClass, which {
         # - if arrayref, render fragment per entry
         # - if obj and can('next') call that until undef
         # - else scream loudly
-        my ($func_key, $func_meth) = @$func;
+        unless ((ref($func) eq 'ARRAY') || ($func =~ /^-topic:(.*)$/)) {
+          confess "over value wrong, should be ${sig}";
+        }
         $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 $topic;
+          if (ref($func) eq 'ARRAY') {
+            my ($func_key, $func_meth)  = @$func;
+            $topic = eval { $args->{$func_key}->$func_meth };
+            confess "Error calling ${func_meth} on ${func_key} argument "
+              .($args->{$func_key}||'').": $@"
+                if $@;
+          } elsif ($func =~ /^-topic:(.*)$/) {
+            $topic = $args->{$1};
+          } else {
+            confess "Shouldn't get here";
+          }
           my $iter_sub;
           if (ref $topic eq 'ARRAY') {
             my @copy = @$topic; # non-destructive on original data
@@ -144,7 +169,7 @@ class WidgetClass, which {
             };
           };
         };
-            
+
       # must also handle just $_ later for wrap
       } else {
         # unrecognised -foo
@@ -195,7 +220,7 @@ class WidgetClass, which {
 
     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;
@@ -204,7 +229,7 @@ class WidgetClass, which {
       @{$r_args}{@extra_keys} = map { $_->($self, $args); } @extra_gen;
       $r_args->{'_'} = $content_gen->($self, $args);
 #warn Dumper($r_args).' ';
-      $rctx->render($fname, $r_args);
+      $rctx->render($self->layout_set, $fname, $r_args);
     };
 
     $class->meta->add_method($methname => $meth);
@@ -223,7 +248,7 @@ class WidgetClass, which {
 
     my $sig = 'should be: key => $_ or key => $_{name} or key => func("name", "method")';
 
-    my (@func_to, @func_spec, @copy_from, @copy_to);
+    my (@func_to, @func_spec, @copy_from, @copy_to, @sub_spec, @sub_to);
     foreach my $key (keys %$argspec) {
       my $val = $argspec->{$key};
       if (ref($val) eq 'ARRAY') {
@@ -233,6 +258,16 @@ class WidgetClass, which {
         my $topic_key = $1;
         push(@copy_from, $topic_key);
         push(@copy_to, $key);
+      }  elsif (ref($val) eq 'CODE') {
+      #LOOK AT ME
+        my $sub = sub{
+          my $inner_args = shift;
+          local *_ = \%{$inner_args};
+          local $_ = $inner_args->{'_'};
+          return $val->();
+        };
+        push(@sub_spec, $sub);
+        push(@sub_to, $key);
       } else {
         confess "Invalid args member for ${key}, ${sig}";
       }
@@ -247,13 +282,17 @@ class WidgetClass, which {
         my ($key, $meth) = @{$_};
         $outer_args->{$key}->$meth; # [ 'a, 'b' ] ~~ ->{'a'}->b
       } @func_spec);
+      #LOOK AT ME
+      @{$args}{@sub_to} = (map { $_->($outer_args) } @sub_spec);
 #warn Dumper($args).' ';
       return $args;
     };
   };
-      
+
 };
 
+1;
+
 package Reaction::UI::WidgetClass::TopicHash;
 
 use Tie::Hash;
@@ -266,6 +305,8 @@ sub FETCH {
 
 1;
 
+__END__;
+
 =head1 NAME
 
 Reaction::UI::WidgetClass