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 use aliased 'Reaction::UI::WidgetClass::_OVER';
   9
  10 no warnings 'once';
  11
  12 use namespace::clean -except => [ qw(meta) ];
  13
  14
  15 # for local() for fragment wrap
  16 our ($next_call, $fragment_args, $current_widget, $do_render, $new_args);
  17
  18 after 'do_import' => sub {
  19   my ($self, $package) = @_;
  20   Devel::Declare->install_declarator(
  21     $package, 'fragment', DECLARE_NAME,
  22     sub { },
  23     sub {
  24       WidgetClass->handle_fragment(@_);
  25     }
  26   );
  27 };
  28
  29 after 'setup_and_cleanup' => sub {
  30   my ($self, $package) = @_;
  31   {
  32     no strict 'refs';
  33     delete ${"${package}::"}{'fragment'};
  34   }
  35   #Devel::Declare->teardown_for($package);
  36 };
  37 override exports_for_package => sub {
  38   my ($self, $package) = @_;
  39   return (super(),
  40     over => sub {
  41       my ($collection) = @_;
  42       confess "too many args, should be: over \$collection" if @_ > 1;
  43       _OVER->new(collection => $collection);
  44     },
  45     render => sub {
  46       my ($name, $over) = @_;
  47
  48       my $sig = "should be: render 'name' or render 'name' => over \$coll";
  49       if (!defined $name) { confess "name undefined: $sig"; }
  50       if (ref $name) { confess "name is a ${\ref $name} ref, not a plain string: $sig"; }
  51       if (defined $over && !(blessed($over) && $over->isa(_OVER))) {
  52         confess "invalid args after name, $sig";
  53       }
  54       $do_render->($package, $current_widget, $name, $over);
  55     },
  56     arg => sub {
  57       my ($name, $value) = @_;
  58
  59       my $sig = "should be: arg 'name' => \$value";
  60       if (@_ < 2) {
  61         $name ||= 'undef';
  62         $value ||= 'undef';
  63         confess "Not enough arguments, $sig, got: $name => $value";
  64       }
  65       if (!defined $name) { confess "name undefined, $sig"; }
  66       if (ref $name) { confess "name is not a string, $sig"; }
  67
  68       $new_args->{$name} = $value;
  69     },
  70     localized => sub {
  71       my($value) = @_;
  72       return $_{self}->view->localize($value);
  73     },
  74     call_next => sub {
  75       confess "args passed, should be just call_next; or call_next();"
  76         if @_;
  77       $next_call->(@$fragment_args);
  78     },
  79     event_id => sub {
  80       my ($name) = @_;
  81       $_{viewport}->event_id_for($name);
  82     },
  83     event_uri => sub {
  84       my ($events) = @_;
  85       my $vp = $_{viewport};
  86       my %args = map{ $vp->event_id_for($_) => $events->{$_} } keys %$events;
  87       $vp->ctx->req->uri_with(\%args);
  88     },
  89     attrs => sub {
  90       my ($attrs) = @_;
  91       return join(' ', map {
  92         my $text = $attrs->{$_};
  93         for ($text) {
  94             s/&/&amp;/g;
  95             s/</&lt;/g;
  96             s/>/&gt;/g;
  97             s/"/&quot;/g;
  98         }
  99         qq{$_="${text}"};
 100       } keys %$attrs);
 101     },
 102     implements => sub {
 103       my ($name, $sub) = @_;
 104       $package->meta->add_method($name, $sub);
 105     },
 106   );
 107 };
 108 override default_base => sub { ('Reaction::UI::Widget') };
 109 sub handle_fragment {
 110   my ($self, $name, $proto, $code) = @_;
 111 #warn ($self, $name, $code);
 112   return ("_fragment_${name}" => $self->wrap_as_fragment($code));
 113 };
 114 sub wrap_as_fragment {
 115   my ($self, $code) = @_;
 116   return sub {
 117     local $next_call;
 118     if (ref $_[0] eq 'CODE') { # inside 'around' modifier
 119       $next_call = shift;
 120     }
 121     local $fragment_args = \@_;
 122
 123     # $self->$method($do_render, \%_, $new_args)
 124     local $current_widget = $_[0];
 125     local $do_render = $_[1];
 126     local *_ = \%{$_[2]};
 127     local $_ = $_[2]->{_};
 128     local $new_args = $_[3];
 129     $code->(@_);
 130   };
 131 };
 132
 133 __PACKAGE__->meta->make_immutable;
 134
 135
 136 1;
 137
 138 =head1 NAME
 139
 140 Reaction::UI::WidgetClass
 141
 142 =head1 DESCRIPTION
 143
 144 =head1 AUTHORS
 145
 146 See L<Reaction::Class> for authors.
 147
 148 =head1 LICENSE
 149
 150 See L<Reaction::Class> for the license.
 151
 152 =cut