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 not 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     call_next => sub {
  71       confess "args passed, should be just call_next; or call_next();"
  72         if @_;
  73       $next_call->(@$fragment_args);
  74     },
  75     event_id => sub {
  76       my ($name) = @_;
  77       $_{viewport}->event_id_for($name);
  78     },
  79     event_uri => sub {
  80       my ($events) = @_;
  81       my $vp = $_{viewport};
  82       my %args = map{ $vp->event_id_for($_) => $events->{$_} } keys %$events;
  83       $vp->ctx->req->uri_with(\%args);
  84     },
  85     attrs => sub {
  86       my ($attrs) = @_;
  87       return join(' ', map {
  88         my $text = $attrs->{$_};
  89         for ($text) {
  90             s/&/&amp;/g;
  91             s/</&lt;/g;
  92             s/>/&gt;/g;
  93             s/"/&quot;/g;
  94         }
  95         qq{$_="${text}"};
  96       } keys %$attrs);
  97     },
  98   );
  99 };
 100 override default_base => sub { ('Reaction::UI::Widget') };
 101 sub handle_fragment {
 102   my ($self, $name, $proto, $code) = @_;
 103 #warn ($self, $name, $code);
 104   return ("_fragment_${name}" => $self->wrap_as_fragment($code));
 105 };
 106 sub wrap_as_fragment {
 107   my ($self, $code) = @_;
 108   return sub {
 109     local $next_call;
 110     if (ref $_[0] eq 'CODE') { # inside 'around' modifier
 111       $next_call = shift;
 112     }
 113     local $fragment_args = \@_;
 114
 115     # $self->$method($do_render, \%_, $new_args)
 116     local $current_widget = $_[0];
 117     local $do_render = $_[1];
 118     local *_ = \%{$_[2]};
 119     local $_ = $_[2]->{_};
 120     local $new_args = $_[3];
 121     $code->(@_);
 122   };
 123 };
 124
 125 __PACKAGE__->meta->make_immutable;
 126
 127
 128 1;
 129
 130 =head1 NAME
 131
 132 Reaction::UI::WidgetClass
 133
 134 =head1 DESCRIPTION
 135
 136 =head1 AUTHORS
 137
 138 See L<Reaction::Class> for authors.
 139
 140 =head1 LICENSE
 141
 142 See L<Reaction::Class> for the license.
 143
 144 =cut