X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FReaction%2FUI%2FWidgetClass.pm;h=ac6feaf028a31c9985f28b5b9da78268157abf8b;hb=8b498574c015710a13644328549b298cef385f74;hp=3e283004c5359e2e4e03b817217bed863a33206d;hpb=2e3dcc8dc99e79c1b41dcc28061f1f54d36672a2;p=catagits%2FReaction.git

diff --git a/lib/Reaction/UI/WidgetClass.pm b/lib/Reaction/UI/WidgetClass.pm
index 3e28300..ac6feaf 100644
--- a/lib/Reaction/UI/WidgetClass.pm
+++ b/lib/Reaction/UI/WidgetClass.pm
@@ -5,287 +5,106 @@ use Reaction::Class;
 use Reaction::UI::Widget;
 use Data::Dumper;
 use Devel::Declare;
+use aliased 'Reaction::UI::WidgetClass::_OVER';
 
 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.
-      fragment => sub (@) { }, # placeholder rewritten by do_import
-      over => sub { -over => @_ },
-    );
-  };
-
-  after do_import => sub {
-    my ($self, $pkg, $args) = @_;
+  # for local() for fragment wrap
+  our ($next_call, $fragment_args, $current_widget, $do_render, $new_args);
 
+  after 'do_import' => sub {
+    my ($self, $package) = @_;
     Devel::Declare->install_declarator(
-      $pkg, 'fragment', DECLARE_NAME,
+      $package, 'fragment', DECLARE_NAME,
       sub { },
       sub {
-        our $FRAGMENT_CLOSURE;
-        splice(@_, 1, 1); # remove undef proto arg
-        $FRAGMENT_CLOSURE->(@_);
+        WidgetClass->handle_fragment(@_);
       }
     );
   };
 
-  overrides default_base => sub { ('Reaction::UI::Widget') };
-
-  overrides do_class_sub => sub {
-    my ($self, $package, $class) = @_;
-    # intercepts 'foo renders ...'
-    our $FRAGMENT_CLOSURE;
-    local $FRAGMENT_CLOSURE = sub {
-      $self->do_renders_meth($package, $class, @_);
-    };
-    # $_ 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(...)|$_|$_{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(...)|$_|$_{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
-
-    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]);
-
-    # 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
-      # 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
-        unless ((ref($func) eq 'ARRAY') || ($func =~ /^-topic:(.*)$/)) {
-          confess "over value wrong, should be ${sig}";
-        }
-        $content_gen = sub {
-          my ($widget, $args) = @_;
-          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
-            $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);
-          };
-        };
-      }
+  after 'setup_and_cleanup' => sub {
+    my ($self, $package) = @_;
+    {
+      no strict 'refs';
+      delete ${"${package}::"}{'fragment'};
     }
-
-    # 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);
+    #Devel::Declare->teardown_for($package);
   };
 
-  implements do_over_meth => as {
-    my ($self, $package, $class, @args) = @_;
-    #warn Dumper(\@args);
-    return (-over => @args);
+  overrides exports_for_package => sub {
+    my ($self, $package) = @_;
+    return (super(),
+      over => sub {
+        my ($collection) = @_;
+        confess "too many args, should be: over \$collection" if @_ > 1;
+        _OVER->new(collection => $collection);
+      },
+      render => sub {
+        my ($name, $over) = @_;
+
+        my $sig = "should be: render 'name' or render 'name' => over \$coll";
+        if (!defined $name) { confess "name undefined: $sig"; }
+        if (ref $name) { confess "name not string: $sig"; }
+        if (defined $over && !(blessed($over) && $over->isa(_OVER))) {
+          confess "invalid args after name, $sig";
+        }
+        $do_render->($package, $current_widget, $name, $over);
+      },
+      arg => sub {
+        my ($name, $value) = @_;
+
+        my $sig = "should be: arg 'name' => \$value";
+        if (@_ < 2) { confess "Not enough arguments, $sig"; }
+        if (!defined $name) { confess "name undefined, $sig"; }
+        if (ref $name) { confess "name is not a string, $sig"; }
+
+        $new_args->{$name} = $value;
+      },
+      call_next => sub {
+        confess "args passed, should be just call_next; or call_next();"
+          if @_;
+        $next_call->(@$fragment_args);
+      },
+      event_id => sub {
+        my ($name) = @_;
+        $_{viewport}->event_id_for($name);
+      },
+      event_uri => sub {
+        my ($events) = @_;
+        my $vp = $_{viewport};
+        my %args = map{ $vp->event_id_for($_) => $events->{$_} } keys %$events;
+        $vp->ctx->req->uri_with(\%args);
+      },
+    );
   };
 
-  implements mk_args_generator => as {
-    my ($self, $argspec) = @_;
-#warn Dumper($argspec);
-    # only handling [ $k, $v ] (func()) and -topic:$x ($_{$x}) for the moment
+  overrides default_base => sub { ('Reaction::UI::Widget') };
 
-    my $sig = 'should be: key => $_ or key => $_{name} or key => func("name", "method")';
+  implements handle_fragment => as {
+    my ($self, $name, $proto, $code) = @_;
+#warn ($self, $name, $code);
+    return ("_fragment_${name}" => $self->wrap_as_fragment($code));
+  };
 
-    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') {
-        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);
-      }  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}";
-      }
-    }
-#warn Dumper(\@func_to, \@func_spec, \@copy_from, \@copy_to);
+  implements wrap_as_fragment => as {
+    my ($self, $code) = @_;
     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);
-      #LOOK AT ME
-      @{$args}{@sub_to} = (map { $_->($outer_args) } @sub_spec);
-#warn Dumper($args).' ';
-      return $args;
+      local $next_call;
+      if (ref $_[0] eq 'CODE') { # inside 'around' modifier
+        $next_call = shift;
+      }
+      local $fragment_args = \@_;
+
+      # $self->$method($do_render, \%_, $new_args)
+      local $current_widget = $_[0];
+      local $do_render = $_[1];
+      local *_ = \%{$_[2]};
+      local $_ = $_[2]->{_};
+      local $new_args = $_[3];
+      $code->(@_);
     };
   };
 
@@ -293,20 +112,6 @@ where content spec is [ fragment_name => over (func(...)|$_|$_{keyname}), \%args
 
 1;
 
-package Reaction::UI::WidgetClass::TopicHash;
-
-use Tie::Hash;
-use base qw(Tie::StdHash);
-
-sub FETCH {
-  my ($self, $key) = @_;
-  return "-topic:${key}";
-}
-
-1;
-
-__END__;
-
 =head1 NAME
 
 Reaction::UI::WidgetClass