lib/HTML/Zoom/FilterBuilder.pm

   1 package HTML::Zoom::FilterBuilder;
   2
   3 use strict;
   4 use warnings FATAL => 'all';
   5 use base qw(HTML::Zoom::SubObject);
   6 use HTML::Zoom::CodeStream;
   7
   8 sub _stream_from_code {
   9   shift->_zconfig->stream_utils->stream_from_code(@_)
  10 }
  11
  12 sub _stream_from_array {
  13   shift->_zconfig->stream_utils->stream_from_array(@_)
  14 }
  15
  16 sub _stream_from_proto {
  17   shift->_zconfig->stream_utils->stream_from_proto(@_)
  18 }
  19
  20 sub _stream_concat {
  21   shift->_zconfig->stream_utils->stream_concat(@_)
  22 }
  23
  24 sub set_attribute {
  25   my ($self, $args) = @_;
  26   my ($name, $value) = @{$args}{qw(name value)};
  27   sub {
  28     my $a = (my $evt = $_[0])->{attrs};
  29     my $e = exists $a->{$name};
  30     +{ %$evt, raw => undef, raw_attrs => undef,
  31        attrs => { %$a, $name => $value },
  32       ($e # add to name list if not present
  33         ? ()
  34         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
  35      }
  36    };
  37 }
  38
  39 sub add_attribute {
  40   my ($self, $args) = @_;
  41   my ($name, $value) = @{$args}{qw(name value)};
  42   sub {
  43     my $a = (my $evt = $_[0])->{attrs};
  44     my $e = exists $a->{$name};
  45     +{ %$evt, raw => undef, raw_attrs => undef,
  46        attrs => {
  47          %$a,
  48          $name => join(' ', ($e ? $a->{$name} : ()), $value)
  49       },
  50       ($e # add to name list if not present
  51         ? ()
  52         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
  53     }
  54   };
  55 }
  56
  57 sub remove_attribute {
  58   my ($self, $args) = @_;
  59   my $name = $args->{name};
  60   sub {
  61     my $a = (my $evt = $_[0])->{attrs};
  62     return $evt unless exists $a->{$name};
  63     $a = { %$a }; delete $a->{$name};
  64     +{ %$evt, raw => undef, raw_attrs => undef,
  65        attrs => $a,
  66        attr_names => [ grep $_ ne $name, @{$evt->{attr_names}} ]
  67     }
  68   };
  69 }
  70
  71 sub collect {
  72   my ($self, $options) = @_;
  73   my ($into, $passthrough, $content, $filter) =
  74     @{$options}{qw(into passthrough content filter)};
  75   sub {
  76     my ($evt, $stream) = @_;
  77     # We wipe the contents of @$into here so that other actions depending
  78     # on this (such as a repeater) can be invoked multiple times easily.
  79     # I -suspect- it's better for that state reset to be managed here; if it
  80     # ever becomes painful the decision should be revisited
  81     if ($into) {
  82       @$into = $content ? () : ($evt);
  83     }
  84     if ($evt->{is_in_place_close}) {
  85       return $evt if $passthrough || $content;
  86       return;
  87     }
  88     my $name = $evt->{name};
  89     my $depth = 1;
  90     my $_next = $content ? 'peek' : 'next';
  91     $stream = do { local $_ = $stream; $filter->($stream) } if $filter;
  92     my $collector = $self->_stream_from_code(sub {
  93       return unless $stream;
  94       while (my ($evt) = $stream->$_next) {
  95         $depth++ if ($evt->{type} eq 'OPEN');
  96         $depth-- if ($evt->{type} eq 'CLOSE');
  97         unless ($depth) {
  98           undef $stream;
  99           return if $content;
 100           push(@$into, $evt) if $into;
 101           return $evt if $passthrough;
 102           return;
 103         }
 104         push(@$into, $evt) if $into;
 105         $stream->next if $content;
 106         return $evt if $passthrough;
 107       }
 108       die "Never saw closing </${name}> before end of source";
 109     });
 110     return ($passthrough||$content) ? [ $evt, $collector ] : $collector;
 111   };
 112 }
 113
 114 sub collect_content {
 115   my ($self, $options) = @_;
 116   $self->collect({ %{$options||{}}, content => 1 })
 117 }
 118
 119 sub add_before {
 120   my ($self, $events) = @_;
 121   sub { return $self->_stream_from_array(@$events, $_[0]) };
 122 }
 123
 124 sub add_after {
 125   my ($self, $events) = @_;
 126   my $coll_proto = $self->collect({ passthrough => 1 });
 127   sub {
 128     my ($evt) = @_;
 129     my $emit = $self->_stream_from_array(@$events);
 130     my $coll = &$coll_proto;
 131     return ref($coll) eq 'HASH' # single event, no collect
 132       ? [ $coll, $emit ]
 133       : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 134   };
 135 }
 136
 137 sub prepend_content {
 138   my ($self, $events) = @_;
 139   sub {
 140     my ($evt) = @_;
 141     if ($evt->{is_in_place_close}) {
 142       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 143       return [ $evt, $self->_stream_from_array(
 144         @$events, { type => 'CLOSE', name => $evt->{name} }
 145       ) ];
 146     }
 147     return $self->_stream_from_array($evt, @$events);
 148   };
 149 }
 150
 151 sub append_content {
 152   my ($self, $events) = @_;
 153   my $coll_proto = $self->collect({ passthrough => 1, content => 1 });
 154   sub {
 155     my ($evt) = @_;
 156     if ($evt->{is_in_place_close}) {
 157       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 158       return [ $evt, $self->_stream_from_array(
 159         @$events, { type => 'CLOSE', name => $evt->{name} }
 160       ) ];
 161     }
 162     my $coll = &$coll_proto;
 163     my $emit = $self->_stream_from_array(@$events);
 164     return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 165   };
 166 }
 167
 168 sub replace {
 169   my ($self, $replace_with, $options) = @_;
 170   my $coll_proto = $self->collect($options);
 171   sub {
 172     my ($evt, $stream) = @_;
 173     my $emit = $self->_stream_from_proto($replace_with);
 174     my $coll = &$coll_proto;
 175     # For a straightforward replace operation we can, in fact, do the emit
 176     # -before- the collect, and my first cut did so. However in order to
 177     # use the captured content in generating the new content, we need
 178     # the collect stage to happen first - and it seems highly unlikely
 179     # that in normal operation the collect phase will take long enough
 180     # for the difference to be noticeable
 181     return
 182       ($coll
 183         ? (ref $coll eq 'ARRAY'
 184             ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]
 185             : $self->_stream_concat($coll, $emit)
 186           )
 187         : $emit
 188       );
 189   };
 190 }
 191
 192 sub replace_content {
 193   my ($self, $replace_with, $options) = @_;
 194   $self->replace($replace_with, { %{$options||{}}, content => 1 })
 195 }
 196
 197 sub repeat {
 198   my ($self, $repeat_for, $options) = @_;
 199   $options->{into} = \my @into;
 200   my @between;
 201   my $repeat_between = delete $options->{repeat_between};
 202   if ($repeat_between) {
 203     $options->{filter} = sub {
 204       $_->select($repeat_between)->collect({ into => \@between })
 205     };
 206   }
 207   my $repeater = sub {
 208     my $s = $self->_stream_from_proto($repeat_for);
 209     # We have to test $repeat_between not @between here because
 210     # at the point we're constructing our return stream @between
 211     # hasn't been populated yet - but we can test @between in the
 212     # map routine because it has been by then and that saves us doing
 213     # the extra stream construction if we don't need it.
 214     if ($repeat_between) {
 215       $s->map(sub {
 216             local $_ = $self->_stream_from_array(@into);
 217             (@between && $s->peek)
 218               ? $self->_stream_concat(
 219                   $_[0]->($_), $self->_stream_from_array(@between)
 220                 )
 221               : $_[0]->($_)
 222           })
 223         ->flatten;
 224     } else {
 225       $s->map(sub {
 226             local $_ = $self->_stream_from_array(@into);
 227             $_[0]->($_)
 228           })
 229         ->flatten;
 230     }
 231   };
 232   $self->replace($repeater, $options);
 233 }
 234
 235 sub repeat_content {
 236   my ($self, $repeat_for, $options) = @_;
 237   $self->repeat($repeat_for, { %{$options||{}}, content => 1 })
 238 }
 239
 240 1;