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_to_attribute(name => 'value')
  46   #    or ->add_to_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     die "renamed to add_to_attribute. killing this entirely for 1.0";
  53 }
  54
  55 sub add_to_attribute {
  56   my $self = shift;
  57   my ($name, $value) = $self->_parse_attribute_args(@_);
  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 = (ref($args) eq 'HASH') ? $args->{name} : $args;
  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, $content, $filter, $flush_before) =
  90     @{$options}{qw(into passthrough content filter flush_before)};
  91   sub {
  92     my ($evt, $stream) = @_;
  93     # We wipe the contents of @$into here so that other actions depending
  94     # on this (such as a repeater) can be invoked multiple times easily.
  95     # I -suspect- it's better for that state reset to be managed here; if it
  96     # ever becomes painful the decision should be revisited
  97     if ($into) {
  98       @$into = $content ? () : ($evt);
  99     }
 100     if ($evt->{is_in_place_close}) {
 101       return $evt if $passthrough || $content;
 102       return;
 103     }
 104     my $name = $evt->{name};
 105     my $depth = 1;
 106     my $_next = $content ? 'peek' : 'next';
 107     $stream = do { local $_ = $stream; $filter->($stream) } if $filter;
 108     my $collector = $self->_stream_from_code(sub {
 109       return unless $stream;
 110       while (my ($evt) = $stream->$_next) {
 111         $depth++ if ($evt->{type} eq 'OPEN');
 112         $depth-- if ($evt->{type} eq 'CLOSE');
 113         unless ($depth) {
 114           undef $stream;
 115           return if $content;
 116           push(@$into, $evt) if $into;
 117           return $evt if $passthrough;
 118           return;
 119         }
 120         push(@$into, $evt) if $into;
 121         $stream->next if $content;
 122         return $evt if $passthrough;
 123       }
 124       die "Never saw closing </${name}> before end of source";
 125     });
 126     if ($flush_before) {
 127       if ($passthrough||$content) {
 128         $evt = { %$evt, flush => 1 };
 129       } else {
 130         $evt = { type => 'EMPTY', flush => 1 };
 131       }
 132     }
 133     return ($passthrough||$content||$flush_before)
 134              ? [ $evt, $collector ]
 135              : $collector;
 136   };
 137 }
 138
 139 sub collect_content {
 140   my ($self, $options) = @_;
 141   $self->collect({ %{$options||{}}, content => 1 })
 142 }
 143
 144 sub add_before {
 145   my ($self, $events) = @_;
 146   sub { return $self->_stream_from_array(@$events, $_[0]) };
 147 }
 148
 149 sub add_after {
 150   my ($self, $events) = @_;
 151   my $coll_proto = $self->collect({ passthrough => 1 });
 152   sub {
 153     my ($evt) = @_;
 154     my $emit = $self->_stream_from_array(@$events);
 155     my $coll = &$coll_proto;
 156     return ref($coll) eq 'HASH' # single event, no collect
 157       ? [ $coll, $emit ]
 158       : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 159   };
 160 }
 161
 162 sub prepend_content {
 163   my ($self, $events) = @_;
 164   sub {
 165     my ($evt) = @_;
 166     if ($evt->{is_in_place_close}) {
 167       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 168       return [ $evt, $self->_stream_from_array(
 169         @$events, { type => 'CLOSE', name => $evt->{name} }
 170       ) ];
 171     }
 172     return $self->_stream_from_array($evt, @$events);
 173   };
 174 }
 175
 176 sub append_content {
 177   my ($self, $events) = @_;
 178   my $coll_proto = $self->collect({ passthrough => 1, content => 1 });
 179   sub {
 180     my ($evt) = @_;
 181     if ($evt->{is_in_place_close}) {
 182       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
 183       return [ $evt, $self->_stream_from_array(
 184         @$events, { type => 'CLOSE', name => $evt->{name} }
 185       ) ];
 186     }
 187     my $coll = &$coll_proto;
 188     my $emit = $self->_stream_from_array(@$events);
 189     return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
 190   };
 191 }
 192
 193 sub replace {
 194   my ($self, $replace_with, $options) = @_;
 195   my $coll_proto = $self->collect($options);
 196   sub {
 197     my ($evt, $stream) = @_;
 198     my $emit = $self->_stream_from_proto($replace_with);
 199     my $coll = &$coll_proto;
 200     # if we're replacing the contents of an in place close
 201     # then we need to handle that here
 202     if ($options->{content}
 203         && ref($coll) eq 'HASH'
 204         && $coll->{is_in_place_close}
 205       ) {
 206       my $close = $stream->next;
 207       # shallow copy and nuke in place and raw (to force smart print)
 208       $_ = { %$_ }, delete @{$_}{qw(is_in_place_close raw)} for ($coll, $close);
 209       $emit = $self->_stream_concat(
 210                 $emit,
 211                 $self->_stream_from_array($close),
 212               );
 213     }
 214     # For a straightforward replace operation we can, in fact, do the emit
 215     # -before- the collect, and my first cut did so. However in order to
 216     # use the captured content in generating the new content, we need
 217     # the collect stage to happen first - and it seems highly unlikely
 218     # that in normal operation the collect phase will take long enough
 219     # for the difference to be noticeable
 220     return
 221       ($coll
 222         ? (ref $coll eq 'ARRAY' # [ event, stream ]
 223             ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]
 224             : (ref $coll eq 'HASH' # event or stream?
 225                  ? [ $coll, $emit ]
 226                  : $self->_stream_concat($coll, $emit))
 227           )
 228         : $emit
 229       );
 230   };
 231 }
 232
 233 sub replace_content {
 234   my ($self, $replace_with, $options) = @_;
 235   $self->replace($replace_with, { %{$options||{}}, content => 1 })
 236 }
 237
 238 sub repeat {
 239   my ($self, $repeat_for, $options) = @_;
 240   $options->{into} = \my @into;
 241   my @between;
 242   my $repeat_between = delete $options->{repeat_between};
 243   if ($repeat_between) {
 244     $options->{filter} = sub {
 245       $_->select($repeat_between)->collect({ into => \@between })
 246     };
 247   }
 248   my $repeater = sub {
 249     my $s = $self->_stream_from_proto($repeat_for);
 250     # We have to test $repeat_between not @between here because
 251     # at the point we're constructing our return stream @between
 252     # hasn't been populated yet - but we can test @between in the
 253     # map routine because it has been by then and that saves us doing
 254     # the extra stream construction if we don't need it.
 255     $self->_flatten_stream_of_streams(do {
 256       if ($repeat_between) {
 257         $s->map(sub {
 258               local $_ = $self->_stream_from_array(@into);
 259               (@between && $s->peek)
 260                 ? $self->_stream_concat(
 261                     $_[0]->($_), $self->_stream_from_array(@between)
 262                   )
 263                 : $_[0]->($_)
 264             })
 265       } else {
 266         $s->map(sub {
 267               local $_ = $self->_stream_from_array(@into);
 268               $_[0]->($_)
 269           })
 270       }
 271     })
 272   };
 273   $self->replace($repeater, $options);
 274 }
 275
 276 sub repeat_content {
 277   my ($self, $repeat_for, $options) = @_;
 278   $self->repeat($repeat_for, { %{$options||{}}, content => 1 })
 279 }
 280
 281 1;
 282
 283 =head1 NAME
 284
 285 HTML::Zoom::FilterBuilder - Add Filters to a Stream
 286
 287 =head1 SYNOPSIS
 288
 289 Create an L<HTML::Zoom> instance:
 290
 291   use HTML::Zoom;
 292   my $root = HTML::Zoom
 293       ->from_html(<<MAIN);
 294   <html>
 295     <head>
 296       <title>Default Title</title>
 297     </head>
 298     <body bad_attr='junk'>
 299       Default Content
 300     </body>
 301   </html>
 302   MAIN
 303
 304 Create a new attribute on the  C<body> tag:
 305
 306   $root = $root
 307     ->select('body')
 308     ->set_attribute(class=>'main');
 309
 310 Add a extra value to an existing attribute:
 311
 312   $root = $root
 313     ->select('body')
 314     ->add_to_attribute(class=>'one-column');
 315
 316 Set the content of the C<title> tag:
 317
 318   $root = $root
 319     ->select('title')
 320     ->replace_content('Hello World');
 321
 322 Set content from another L<HTML::Zoom> instance:
 323
 324   my $body = HTML::Zoom
 325       ->from_html(<<BODY);
 326   <div id="stuff">
 327       <p>Well Now</p>
 328       <p id="p2">Is the Time</p>
 329   </div>
 330   BODY
 331
 332   $root = $root
 333     ->select('body')
 334     ->replace_content($body);
 335
 336 Set an attribute on multiple matches:
 337
 338   $root = $root
 339     ->select('p')
 340     ->set_attribute(class=>'para');
 341
 342 Remove an attribute:
 343
 344   $root = $root
 345     ->select('body')
 346     ->remove_attribute('bad_attr');
 347
 348 will produce:
 349
 350 =begin testinfo
 351
 352   my $output = $root->to_html;
 353   my $expect = <<HTML;
 354
 355 =end testinfo
 356
 357   <html>
 358     <head>
 359       <title>Hello World</title>
 360     </head>
 361     <body class="main one-column"><div id="stuff">
 362       <p class="para">Well Now</p>
 363       <p id="p2" class="para">Is the Time</p>
 364   </div>
 365   </body>
 366   </html>
 367
 368 =begin testinfo
 369
 370   HTML
 371   is($output, $expect, 'Synopsis code works ok');
 372
 373 =end testinfo
 374
 375 =head1 DESCRIPTION
 376
 377 Given a L<HTML::Zoom> stream, provide methods to apply filters which
 378 alter the content of that stream.
 379
 380 =head1 METHODS
 381
 382 This class defines the following public API
 383
 384 =head2 set_attribute ( $attr=>value | {name=>$attr,value=>$value} )
 385
 386 Sets an attribute of a given name to a given value for all matching selections.
 387
 388     $html_zoom
 389       ->select('p')
 390       ->set_attribute(class=>'paragraph')
 391       ->select('div')
 392       ->set_attribute(name=>'class', value=>'divider');
 393
 394
 395 Overrides existing values, if such exist.  When multiple L</set_attribute>
 396 calls are made against the same or overlapping selection sets, the final
 397 call wins.
 398
 399 =head2 add_to_attribute ( $attr=>value | {name=>$attr,value=>$value} )
 400
 401 Adds a value to an existing attribute, or creates one if the attribute does not
 402 yet exist.
 403
 404     $html_zoom
 405       ->select('p')
 406       ->set_attribute(class=>'paragraph')
 407       ->then
 408       ->add_to_attribute(name=>'class', value=>'divider');
 409
 410 Attributes with more than one value will have a dividing space.
 411
 412 =head2 remove_attribute ( $attr | {name=>$attr} )
 413
 414 Removes an attribute and all its values.
 415
 416     $html_zoom
 417       ->select('p')
 418       ->set_attribute(class=>'paragraph')
 419       ->then
 420       ->remove_attribute('class');
 421
 422 Removes attributes from the original stream or events already added.
 423
 424 =head2 collect
 425
 426     TBD
 427
 428 =head2 collect_content
 429
 430     TBD
 431
 432 =head2 add_before
 433
 434     TBD
 435
 436 =head2 add_after
 437
 438     TBD
 439
 440 =head2 prepend_content
 441
 442     TBD
 443
 444 =head2 append_content
 445
 446     TBD
 447
 448 =head2 replace
 449
 450     TBD
 451
 452 =head2 replace_content
 453
 454 Given a L<HTML::Zoom/select> result, replace the content with a string, array
 455 or another L<HTML::Zoom> object.
 456
 457 =head2 repeat
 458
 459     TBD
 460
 461 =head2 repeat_content
 462
 463     TBD
 464
 465 =head1 ALSO SEE
 466
 467 L<HTML::Zoom>
 468
 469 =head1 AUTHORS
 470
 471 See L<HTML::Zoom> for authors.
 472
 473 =head1 LICENSE
 474
 475 See L<HTML::Zoom> for the license.
 476
 477 =cut
 478