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 _flatten_stream_of_streams {
  25   shift->_zconfig->stream_utils->flatten_stream_of_streams(@_)
  26 }
  27
  28 sub set_attribute {
  29   my $self = shift;
  30   my ($name, $value) = $self->_parse_attribute_args(@_);
  31   sub {
  32     my $a = (my $evt = $_[0])->{attrs};
  33     my $e = exists $a->{$name};
  34     +{ %$evt, raw => undef, raw_attrs => undef,
  35        attrs => { %$a, $name => $value },
  36       ($e # add to name list if not present
  37         ? ()
  38         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
  39      }
  40    };
  41 }
  42
  43 sub _parse_attribute_args {
  44   my $self = shift;
  45   # allow ->add_attribute(name => 'value')
  46   #    or ->add_attribute({ name => 'name', value => 'value' })
  47   my ($name, $value) = @_ > 1 ? @_ : @{$_[0]}{qw(name value)};
  48   return ($name, $self->_zconfig->parser->html_escape($value));
  49 }
  50
  51 sub add_attribute {
  52   my $self = shift;
  53   my ($name, $value) = $self->_parse_attribute_args(@_);
  54   sub {
  55     my $a = (my $evt = $_[0])->{attrs};
  56     my $e = exists $a->{$name};
  57     +{ %$evt, raw => undef, raw_attrs => undef,
  58        attrs => {
  59          %$a,
  60          $name => join(' ', ($e ? $a->{$name} : ()), $value)
  61       },
  62       ($e # add to name list if not present
  63         ? ()
  64         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
  65     }
  66   };
  67 }
  68
  69 sub remove_attribute {
  70   my ($self, $args) = @_;
  71   my $name = (ref($args) eq 'HASH') ? $args->{name} : $args;
  72   sub {
  73     my $a = (my $evt = $_[0])->{attrs};
  74     return $evt unless exists $a->{$name};
  75     $a = { %$a }; delete $a->{$name};
  76     +{ %$evt, raw => undef, raw_attrs => undef,
  77        attrs => $a,
  78        attr_names => [ grep $_ ne $name, @{$evt->{attr_names}} ]
  79     }
  80   };
  81 }
  82
  83 sub collect {
  84   my ($self, $options) = @_;
  85   my ($into, $passthrough, $content, $filter, $flush_before) =
  86     @{$options}{qw(into passthrough content filter flush_before)};
  87   sub {
  88     my ($evt, $stream) = @_;
  89     # We wipe the contents of @$into here so that other actions depending
  90     # on this (such as a repeater) can be invoked multiple times easily.
  91     # I -suspect- it's better for that state reset to be managed here; if it
  92     # ever becomes painful the decision should be revisited
  93     if ($into) {
  94       @$into = $content ? () : ($evt);
  95     }
  96     if ($evt->{is_in_place_close}) {
  97       return $evt if $passthrough || $content;
  98       return;
  99     }
 100     my $name = $evt->{name};
 101     my $depth = 1;
 102     my $_next = $content ? 'peek' : 'next';
 103     $stream = do { local $_ = $stream; $filter->($stream) } if $filter;
 104     my $collector = $self->_stream_from_code(sub {
 105       return unless $stream;
 106       while (my ($evt) = $stream->$_next) {
 107         $depth++ if ($evt->{type} eq 'OPEN');
 108         $depth-- if ($evt->{type} eq 'CLOSE');
 109         unless ($depth) {
 110           undef $stream;
 111           return if $content;
 112           push(@$into, $evt) if $into;
 113           return $evt if $passthrough;
 114           return;
 115         }
 116         push(@$into, $evt) if $into;
 117         $stream->next if $content;
 118         return $evt if $passthrough;
 119       }
 120       die "Never saw closing </${name}> before end of source";
 121     });
 122     if ($flush_before) {
 123       if ($passthrough||$content) {
 124         $evt = { %$evt, flush => 1 };
 125       } else {
 126         $evt = { type => 'EMPTY', flush => 1 };
 127       }
 128     }
 129     return ($passthrough||$content||$flush_before)
 130              ? [ $evt, $collector ]
 131              : $collector;
 132   };
 133 }
 134
 135 sub collect_content {
 136   my ($self, $options) = @_;
 137   $self->collect({ %{$options||{}}, content => 1 })
 138 }
 139
 140 sub add_before {
 141   my ($self, $events) = @_;
 142   sub { return $self->_stream_from_array(@$events, $_[0]) };
 143 }
 144
 145 sub add_after {
 146   my ($self, $events) = @_;
 147   my $coll_proto = $self->collect({ passthrough => 1 });
 148   sub {
 149     my ($evt) = @_;
 150     my $emit = $self->_stream_from_array(@$events);
 151     my $coll = &$coll_proto;
 152     return ref($coll) eq 'HASH' # single event, no collect
 153       ? [ $coll, $emit ]
 154       : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 155   };
 156 }
 157
 158 sub prepend_content {
 159   my ($self, $events) = @_;
 160   sub {
 161     my ($evt) = @_;
 162     if ($evt->{is_in_place_close}) {
 163       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 164       return [ $evt, $self->_stream_from_array(
 165         @$events, { type => 'CLOSE', name => $evt->{name} }
 166       ) ];
 167     }
 168     return $self->_stream_from_array($evt, @$events);
 169   };
 170 }
 171
 172 sub append_content {
 173   my ($self, $events) = @_;
 174   my $coll_proto = $self->collect({ passthrough => 1, content => 1 });
 175   sub {
 176     my ($evt) = @_;
 177     if ($evt->{is_in_place_close}) {
 178       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 179       return [ $evt, $self->_stream_from_array(
 180         @$events, { type => 'CLOSE', name => $evt->{name} }
 181       ) ];
 182     }
 183     my $coll = &$coll_proto;
 184     my $emit = $self->_stream_from_array(@$events);
 185     return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 186   };
 187 }
 188
 189 sub replace {
 190   my ($self, $replace_with, $options) = @_;
 191   my $coll_proto = $self->collect($options);
 192   sub {
 193     my ($evt, $stream) = @_;
 194     my $emit = $self->_stream_from_proto($replace_with);
 195     my $coll = &$coll_proto;
 196     # if we're replacing the contents of an in place close
 197     # then we need to handle that here
 198     if ($options->{content}
 199         && ref($coll) eq 'HASH'
 200         && $coll->{is_in_place_close}
 201       ) {
 202       my $close = $stream->next;
 203       # shallow copy and nuke in place and raw (to force smart print)
 204       $_ = { %$_ }, delete @{$_}{qw(is_in_place_close raw)} for ($coll, $close);
 205       $emit = $self->_stream_concat(
 206                 $emit,
 207                 $self->_stream_from_array($close),
 208               );
 209     }
 210     # For a straightforward replace operation we can, in fact, do the emit
 211     # -before- the collect, and my first cut did so. However in order to
 212     # use the captured content in generating the new content, we need
 213     # the collect stage to happen first - and it seems highly unlikely
 214     # that in normal operation the collect phase will take long enough
 215     # for the difference to be noticeable
 216     return
 217       ($coll
 218         ? (ref $coll eq 'ARRAY' # [ event, stream ]
 219             ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]
 220             : (ref $coll eq 'HASH' # event or stream?
 221                  ? [ $coll, $emit ]
 222                  : $self->_stream_concat($coll, $emit))
 223           )
 224         : $emit
 225       );
 226   };
 227 }
 228
 229 sub replace_content {
 230   my ($self, $replace_with, $options) = @_;
 231   $self->replace($replace_with, { %{$options||{}}, content => 1 })
 232 }
 233
 234 sub repeat {
 235   my ($self, $repeat_for, $options) = @_;
 236   $options->{into} = \my @into;
 237   my @between;
 238   my $repeat_between = delete $options->{repeat_between};
 239   if ($repeat_between) {
 240     $options->{filter} = sub {
 241       $_->select($repeat_between)->collect({ into => \@between })
 242     };
 243   }
 244   my $repeater = sub {
 245     my $s = $self->_stream_from_proto($repeat_for);
 246     # We have to test $repeat_between not @between here because
 247     # at the point we're constructing our return stream @between
 248     # hasn't been populated yet - but we can test @between in the
 249     # map routine because it has been by then and that saves us doing
 250     # the extra stream construction if we don't need it.
 251     $self->_flatten_stream_of_streams(do {
 252       if ($repeat_between) {
 253         $s->map(sub {
 254               local $_ = $self->_stream_from_array(@into);
 255               (@between && $s->peek)
 256                 ? $self->_stream_concat(
 257                     $_[0]->($_), $self->_stream_from_array(@between)
 258                   )
 259                 : $_[0]->($_)
 260             })
 261       } else {
 262         $s->map(sub {
 263               local $_ = $self->_stream_from_array(@into);
 264               $_[0]->($_)
 265           })
 266       }
 267     })
 268   };
 269   $self->replace($repeater, $options);
 270 }
 271
 272 sub repeat_content {
 273   my ($self, $repeat_for, $options) = @_;
 274   $self->repeat($repeat_for, { %{$options||{}}, content => 1 })
 275 }
 276
 277 1;
 278
 279 =head1 NAME
 280
 281 HTML::Zoom::FilterBuilder - Add Filters to a Stream
 282
 283 =head1 SYNOPSIS
 284
 285   use HTML::Zoom;
 286   my $root = HTML::Zoom
 287       ->from_html(<<MAIN);
 288   <html>
 289     <head>
 290       <title>Default Title</title>
 291     </head>
 292     <body>
 293       Default Content
 294     </body>
 295   </html>
 296   MAIN
 297
 298   my $body = HTML::Zoom
 299       ->from_html(<<BODY);
 300   <div id="stuff">
 301       <p>Stuff</p>
 302   </div>
 303   BODY
 304
 305   my $output =  $root
 306   ->select('title')
 307   ->replace_content('Hello World')
 308   ->select('body')
 309   ->replace_content($body)
 310   ->to_html;
 311
 312 will produce:
 313
 314 =begin testinfo
 315
 316   my $expect = <<HTML;
 317
 318 =end testinfo
 319
 320   <html>
 321     <head>
 322       <title>Hello World</title>
 323     </head>
 324     <body><div id="stuff">
 325       <p>Stuff</p>
 326   </div>
 327   </body>
 328   </html>
 329
 330 =begin testinfo
 331
 332   HTML
 333   is($output, $expect, 'Synopsis code works ok');
 334
 335 =end testinfo
 336
 337 =head1 DESCRIPTION
 338
 339 Given a L<HTML::Zoom> stream, provide methods to apply filters which
 340 alter the content of that stream.
 341
 342 =head1 METHODS
 343
 344 This class defines the following public API
 345
 346 =head2 set_attribute
 347
 348     TBD
 349
 350 =head2 add_attribute
 351
 352     TBD
 353
 354 =head2 remove_attribute
 355
 356     TBD
 357
 358 =head2 collect
 359
 360     TBD
 361
 362 =head2 collect_content
 363
 364     TBD
 365
 366 =head2 add_before
 367
 368     TBD
 369
 370 =head2 add_after
 371
 372     TBD
 373
 374 =head2 prepend_content
 375
 376     TBD
 377
 378 =head2 append_content
 379
 380     TBD
 381
 382 =head2 replace
 383
 384     TBD
 385
 386 =head2 replace_content
 387
 388 Given a L<HTML::Zoom/select> result, replace the content with a string, array
 389 or another L<HTML::Zoom> object.
 390
 391 =head2 repeat
 392
 393     TBD
 394
 395 =head2 repeat_content
 396
 397     TBD
 398
 399 =head1 ALSO SEE
 400
 401 L<HTML::Zoom>
 402
 403 =head1 AUTHORS
 404
 405 See L<HTML::Zoom> for authors.
 406
 407 =head1 LICENSE
 408
 409 See L<HTML::Zoom> for the license.
 410
 411 =cut
 412