(no commit message)

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

diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm
index 9e40936..3e28300 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