lib/HTML/Zoom/FilterBuilder.pm

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