update docs
[catagits/HTML-Zoom.git] / lib / HTML / Zoom / FilterBuilder.pm
1 package HTML::Zoom::FilterBuilder;
2
3 use strictures 1;
4 use base qw(HTML::Zoom::SubObject);
5 use HTML::Zoom::CodeStream;
6
7 sub _stream_from_code {
8   shift->_zconfig->stream_utils->stream_from_code(@_)
9 }
10
11 sub _stream_from_array {
12   shift->_zconfig->stream_utils->stream_from_array(@_)
13 }
14
15 sub _stream_from_proto {
16   shift->_zconfig->stream_utils->stream_from_proto(@_)
17 }
18
19 sub _stream_concat {
20   shift->_zconfig->stream_utils->stream_concat(@_)
21 }
22
23 sub _flatten_stream_of_streams {
24   shift->_zconfig->stream_utils->flatten_stream_of_streams(@_)
25 }
26
27 sub set_attr { shift->set_attribute(@_); }
28
29 sub set_attribute {
30   my $self = shift;
31   my ($name, $value) = $self->_parse_attribute_args(@_);
32   sub {
33     my $a = (my $evt = $_[0])->{attrs};
34     my $e = exists $a->{$name};
35     +{ %$evt, raw => undef, raw_attrs => undef,
36        attrs => { %$a, $name => $value },
37       ($e # add to name list if not present
38         ? ()
39         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
40      }
41    };
42 }
43
44 sub _parse_attribute_args {
45   my $self = shift;
46   # allow ->add_to_attribute(name => 'value')
47   #    or ->add_to_attribute({ name => 'name', value => 'value' })
48
49   die "WARNING: Long form arg (name => 'class', value => 'x') is deprecated"
50     if(@_ == 1 && $_[0]->{'name'} && $_[0]->{'value'});
51   my ($name, $value) = @_ > 1 ? @_ : @{$_[0]}{qw(name value)};
52   return ($name, $self->_zconfig->parser->html_escape($value));
53 }
54
55 sub add_attribute {
56     die "renamed to add_to_attribute. killing this entirely for 1.0";
57 }
58
59 sub add_class { shift->add_to_attribute('class',@_) }
60
61 sub remove_class { shift->remove_attribute('class',@_) }
62
63 sub set_class { shift->set_attribute('class',@_) }
64
65 sub set_id { shift->set_attribute('id',@_) }
66
67 sub add_to_attribute {
68   my $self = shift;
69   my ($name, $value) = $self->_parse_attribute_args(@_);
70   sub {
71     my $a = (my $evt = $_[0])->{attrs};
72     my $e = exists $a->{$name};
73     +{ %$evt, raw => undef, raw_attrs => undef,
74        attrs => {
75          %$a,
76          $name => join(' ', ($e ? $a->{$name} : ()), $value)
77       },
78       ($e # add to name list if not present
79         ? ()
80         : (attr_names => [ @{$evt->{attr_names}}, $name ]))
81     }
82   };
83 }
84
85 sub remove_attribute {
86   my ($self, $args) = @_;
87   my $name = (ref($args) eq 'HASH') ? $args->{name} : $args;
88   sub {
89     my $a = (my $evt = $_[0])->{attrs};
90     return $evt unless exists $a->{$name};
91     $a = { %$a }; delete $a->{$name};
92     +{ %$evt, raw => undef, raw_attrs => undef,
93        attrs => $a,
94        attr_names => [ grep $_ ne $name, @{$evt->{attr_names}} ]
95     }
96   };
97 }
98
99 sub transform_attribute {
100   my $self = shift;
101   my ( $name, $code ) = @_ > 1 ? @_ : @{$_[0]}{qw(name code)};
102
103   sub {
104     my $evt = $_[0];
105     my %a = %{ $evt->{attrs} };
106     my @names = @{ $evt->{attr_names} };
107
108     my $existed_before = exists $a{$name};
109     my $v = $code->( $a{$name} );
110     my $deleted =   $existed_before && ! defined $v;
111     my $added   = ! $existed_before &&   defined $v;
112     if( $added ) {
113         push @names, $name;
114         $a{$name} = $v;
115     }
116     elsif( $deleted ) {
117         delete $a{$name};
118         @names = grep $_ ne $name, @names;
119     } else {
120         $a{$name} = $v;
121     }
122     +{ %$evt, raw => undef, raw_attrs => undef,
123        attrs => \%a,
124       ( $deleted || $added
125         ? (attr_names => \@names )
126         : () )
127      }
128    };
129 }
130
131 sub collect {
132   my ($self, $options) = @_;
133   my ($into, $passthrough, $content, $filter, $flush_before) =
134     @{$options}{qw(into passthrough content filter flush_before)};
135   sub {
136     my ($evt, $stream) = @_;
137     # We wipe the contents of @$into here so that other actions depending
138     # on this (such as a repeater) can be invoked multiple times easily.
139     # I -suspect- it's better for that state reset to be managed here; if it
140     # ever becomes painful the decision should be revisited
141     if ($into) {
142       @$into = $content ? () : ($evt);
143     }
144     if ($evt->{is_in_place_close}) {
145       return $evt if $passthrough || $content;
146       return;
147     }
148     my $name = $evt->{name};
149     my $depth = 1;
150     my $_next = $content ? 'peek' : 'next';
151     if ($filter) {
152       if ($content) {
153         $stream = do { local $_ = $stream; $filter->($stream) };
154       } else {
155         $stream = do {
156           local $_ = $self->_stream_concat(
157                        $self->_stream_from_array($evt),
158                        $stream,
159                      );
160           $filter->($_);
161         };
162         $evt = $stream->next;
163       }
164     }
165     my $collector = $self->_stream_from_code(sub {
166       return unless $stream;
167       while (my ($evt) = $stream->$_next) {
168         $depth++ if ($evt->{type} eq 'OPEN');
169         $depth-- if ($evt->{type} eq 'CLOSE');
170         unless ($depth) {
171           undef $stream;
172           return if $content;
173           push(@$into, $evt) if $into;
174           return $evt if $passthrough;
175           return;
176         }
177         push(@$into, $evt) if $into;
178         $stream->next if $content;
179         return $evt if $passthrough;
180       }
181       die "Never saw closing </${name}> before end of source";
182     });
183     if ($flush_before) {
184       if ($passthrough||$content) {
185         $evt = { %$evt, flush => 1 };
186       } else {
187         $evt = { type => 'EMPTY', flush => 1 };
188       }
189     }
190     return ($passthrough||$content||$flush_before)
191              ? [ $evt, $collector ]
192              : $collector;
193   };
194 }
195
196 sub collect_content {
197   my ($self, $options) = @_;
198   $self->collect({ %{$options||{}}, content => 1 })
199 }
200
201 sub add_before {
202   my ($self, $events) = @_;
203   my $coll_proto = $self->collect({ passthrough => 1 });
204   sub {
205     my $emit = $self->_stream_from_proto($events);
206     my $coll = &$coll_proto;
207     if($coll) {
208       if(ref $coll eq 'ARRAY') {
209         my $firstbit = $self->_stream_from_proto([$coll->[0]]);
210         return $self->_stream_concat($emit, $firstbit, $coll->[1]);
211       } elsif(ref $coll eq 'HASH') {
212         return [$emit, $coll];
213       } else {
214         return $self->_stream_concat($emit, $coll);
215       }
216     } else { return $emit }
217   }
218 }
219
220 sub add_after {
221   my ($self, $events) = @_;
222   my $coll_proto = $self->collect({ passthrough => 1 });
223   sub {
224     my ($evt) = @_;
225     my $emit = $self->_stream_from_proto($events);
226     my $coll = &$coll_proto;
227     return ref($coll) eq 'HASH' # single event, no collect
228       ? [ $coll, $emit ]
229       : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
230   };
231 }
232
233 sub prepend_content {
234   my ($self, $events) = @_;
235   my $coll_proto = $self->collect({ passthrough => 1, content => 1 });
236   sub {
237     my ($evt) = @_;
238     my $emit = $self->_stream_from_proto($events);
239     if ($evt->{is_in_place_close}) {
240       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
241       return [ $evt, $self->_stream_from_array(
242         $emit->next, { type => 'CLOSE', name => $evt->{name} }
243       ) ];
244     }
245     my $coll = &$coll_proto;
246     return [ $coll->[0], $self->_stream_concat($emit, $coll->[1]) ];
247   };
248 }
249
250 sub append_content {
251   my ($self, $events) = @_;
252   my $coll_proto = $self->collect({ passthrough => 1, content => 1 });
253   sub {
254     my ($evt) = @_;
255     my $emit = $self->_stream_from_proto($events);
256     if ($evt->{is_in_place_close}) {
257       $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)};
258       return [ $evt, $self->_stream_from_array(
259         $emit->next, { type => 'CLOSE', name => $evt->{name} }
260       ) ];
261     }
262     my $coll = &$coll_proto;
263     return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ];
264   };
265 }
266
267 sub replace {
268   my ($self, $replace_with, $options) = @_;
269   my $coll_proto = $self->collect($options);
270   sub {
271     my ($evt, $stream) = @_;
272     my $emit = $self->_stream_from_proto($replace_with);
273     my $coll = &$coll_proto;
274     # if we're replacing the contents of an in place close
275     # then we need to handle that here
276     if ($options->{content}
277         && ref($coll) eq 'HASH'
278         && $coll->{is_in_place_close}
279       ) {
280       my $close = $stream->next;
281       # shallow copy and nuke in place and raw (to force smart print)
282       $_ = { %$_ }, delete @{$_}{qw(is_in_place_close raw)} for ($coll, $close);
283       $emit = $self->_stream_concat(
284                 $emit,
285                 $self->_stream_from_array($close),
286               );
287     }
288     # For a straightforward replace operation we can, in fact, do the emit
289     # -before- the collect, and my first cut did so. However in order to
290     # use the captured content in generating the new content, we need
291     # the collect stage to happen first - and it seems highly unlikely
292     # that in normal operation the collect phase will take long enough
293     # for the difference to be noticeable
294     return
295       ($coll
296         ? (ref $coll eq 'ARRAY' # [ event, stream ]
297             ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]
298             : (ref $coll eq 'HASH' # event or stream?
299                  ? [ $coll, $emit ]
300                  : $self->_stream_concat($coll, $emit))
301           )
302         : $emit
303       );
304   };
305 }
306
307 sub replace_content {
308   my ($self, $replace_with, $options) = @_;
309   $self->replace($replace_with, { %{$options||{}}, content => 1 })
310 }
311
312 sub repeat {
313   my ($self, $repeat_for, $options) = @_;
314   $options->{into} = \my @into;
315   my @between;
316   my $repeat_between = delete $options->{repeat_between};
317   if ($repeat_between) {
318     $options->{filter} = sub {
319       $_->select($repeat_between)->collect({ into => \@between })
320     }
321   }
322   my $repeater = sub {
323     my $s = $self->_stream_from_proto($repeat_for);
324     # We have to test $repeat_between not @between here because
325     # at the point we're constructing our return stream @between
326     # hasn't been populated yet - but we can test @between in the
327     # map routine because it has been by then and that saves us doing
328     # the extra stream construction if we don't need it.
329     $self->_flatten_stream_of_streams(do {
330       if ($repeat_between) {
331         $s->map(sub {
332               local $_ = $self->_stream_from_array(@into);
333               (@between && $s->peek)
334                 ? $self->_stream_concat(
335                     $_[0]->($_), $self->_stream_from_array(@between)
336                   )
337                 : $_[0]->($_)
338             })
339       } else {
340         $s->map(sub {
341               local $_ = $self->_stream_from_array(@into);
342               $_[0]->($_)
343           })
344       }
345     })
346   };
347   $self->replace($repeater, $options);
348 }
349
350 sub repeat_content {
351   my ($self, $repeat_for, $options) = @_;
352   $self->repeat($repeat_for, { %{$options||{}}, content => 1 })
353 }
354
355 1;
356
357 =head1 NAME
358
359 HTML::Zoom::FilterBuilder - Add Filters to a Stream
360
361 =head1 SYNOPSIS
362
363 Create an L<HTML::Zoom> instance:
364
365   use HTML::Zoom;
366   my $root = HTML::Zoom
367       ->from_html(<<MAIN);
368   <html>
369     <head>
370       <title>Default Title</title>
371     </head>
372     <body bad_attr='junk'>
373       Default Content
374     </body>
375   </html>
376   MAIN
377
378 Create a new attribute on the  C<body> tag:
379
380   $root = $root
381     ->select('body')
382     ->set_attribute(class=>'main');
383
384 Add a extra value to an existing attribute:
385
386   $root = $root
387     ->select('body')
388     ->add_to_attribute(class=>'one-column');
389
390 Set the content of the C<title> tag:
391
392   $root = $root
393     ->select('title')
394     ->replace_content('Hello World');
395
396 Set content from another L<HTML::Zoom> instance:
397
398   my $body = HTML::Zoom
399       ->from_html(<<BODY);
400   <div id="stuff">
401       <p>Well Now</p>
402       <p id="p2">Is the Time</p>
403   </div>
404   BODY
405
406   $root = $root
407     ->select('body')
408     ->replace_content($body);
409
410 Set an attribute on multiple matches:
411
412   $root = $root
413     ->select('p')
414     ->set_attribute(class=>'para');
415
416 Remove an attribute:
417
418   $root = $root
419     ->select('body')
420     ->remove_attribute('bad_attr');
421
422 will produce:
423
424 =begin testinfo
425
426   my $output = $root->to_html;
427   my $expect = <<HTML;
428
429 =end testinfo
430
431   <html>
432     <head>
433       <title>Hello World</title>
434     </head>
435     <body class="main one-column"><div id="stuff">
436       <p class="para">Well Now</p>
437       <p id="p2" class="para">Is the Time</p>
438   </div>
439   </body>
440   </html>
441
442 =begin testinfo
443
444   HTML
445   is($output, $expect, 'Synopsis code works ok');
446
447 =end testinfo
448
449 =head1 DESCRIPTION
450
451 Given a L<HTML::Zoom> stream, provide methods to apply filters which
452 alter the content of that stream.
453
454 =head1 METHODS
455
456 This class defines the following public API
457
458 =head2 set_attribute
459
460 Sets an attribute of a given name to a given value for all matching selections.
461
462     $html_zoom
463       ->select('p')
464       ->set_attribute(class=>'paragraph')
465       ->select('div')
466       ->set_attribute({class=>'paragraph', name=>'divider'});
467
468 Overrides existing values, if such exist.  When multiple L</set_attribute>
469 calls are made against the same or overlapping selection sets, the final
470 call wins.
471
472 =head2 add_to_attribute
473
474 Adds a value to an existing attribute, or creates one if the attribute does not
475 yet exist.  You may call this method with either an Array or HashRef of Args.
476
477     $html_zoom
478       ->select('p')
479       ->set_attribute({class => 'paragraph', name => 'test'})
480       ->then
481       ->add_to_attribute(class=>'divider');
482
483 Attributes with more than one value will have a dividing space.
484
485 =head2 remove_attribute
486
487 Removes an attribute and all its values.
488
489     $html_zoom
490       ->select('p')
491       ->set_attribute(class=>'paragraph')
492       ->then
493       ->remove_attribute('class');
494
495 Removes attributes from the original stream or events already added.
496
497 =head2 transform_attribute
498
499 Transforms (or creates or deletes) an attribute by running the passed
500 coderef on it.  If the coderef returns nothing, the attribute is
501 removed.
502
503     $html_zoom
504       ->select('a')
505       ->transform_attribute( href => sub {
506             ( my $a = shift ) =~ s/localhost/example.com/;
507             return $a;
508           },
509         );
510
511 =head2 collect
512
513 Collects and extracts results of L<HTML::Zoom/select>.  It takes the following
514 optional common options as hash reference.
515
516 =over
517
518 =item into [ARRAY REFERENCE]
519
520 Where to save collected events (selected elements).
521
522     $z1->select('#main-content')
523        ->collect({ into => \@body })
524        ->run;
525     $z2->select('#main-content')
526        ->replace(\@body)
527        ->memoize;
528
529 =item filter [CODE]
530
531 Run filter on collected elements (locally setting $_ to stream, and passing
532 stream as an argument to given code reference).  Filtered stream would be
533 returned.
534
535     $z->select('.outer')
536       ->collect({
537         filter => sub { $_->select('.inner')->replace_content('bar!') },
538         passthrough => 1,
539       })
540
541 It can be used to further filter selection.  For example
542
543     $z->select('tr')
544       ->collect({
545         filter => sub { $_->select('td') },
546         passthrough => 1,
547       })
548
549 is equivalent to (not implemented yet) descendant selector combination, i.e.
550
551     $z->select('tr td')
552
553 =item passthrough [BOOLEAN]
554
555 Extract copy of elements; the stream is unchanged (it does not remove collected
556 elements).  For example without 'passthrough'
557
558     HTML::Zoom->from_html('<foo><bar /></foo>')
559       ->select('foo')
560       ->collect({ content => 1 })
561       ->to_html
562
563 returns '<foo></foo>', while with C<passthrough> option
564
565     HTML::Zoom->from_html('<foo><bar /></foo>')
566       ->select('foo')
567       ->collect({ content => 1, passthough => 1 })
568       ->to_html
569
570 returns '<foo><bar /></foo>'.
571
572 =item content [BOOLEAN]
573
574 Collect content of the element, and not the element itself.
575
576 For example
577
578     HTML::Zoom->from_html('<h1>Title</h1><p>foo</p>')
579       ->select('h1')
580       ->collect
581       ->to_html
582
583 would return '<p>foo</p>', while
584
585     HTML::Zoom->from_html('<h1>Title</h1><p>foo</p>')
586       ->select('h1')
587       ->collect({ content => 1 })
588       ->to_html
589
590 would return '<h1></h1><p>foo</p>'.
591
592 See also L</collect_content>.
593
594 =item flush_before [BOOLEAN]
595
596 Generate C<flush> event before collecting, to ensure that the HTML generated up
597 to selected element being collected is flushed throught to the browser.  Usually
598 used in L</repeat> or L</repeat_content>.
599
600 =back
601
602 =head2 collect_content
603
604 Collects contents of L<HTML::Zoom/select> result.
605
606     HTML::Zoom->from_file($foo)
607               ->select('#main-content')
608               ->collect_content({ into => \@foo_body })
609               ->run;
610     $z->select('#foo')
611       ->replace_content(\@foo_body)
612       ->memoize;
613
614 Equivalent to running L</collect> with C<content> option set.
615
616 =head2 add_before
617
618 Given a L<HTML::Zoom/select> result, add given content (which might be string,
619 array or another L<HTML::Zoom> object) before it.
620
621     $html_zoom
622         ->select('input[name="foo"]')
623         ->add_before(\ '<span class="warning">required field</span>');
624
625 =head2 add_after
626
627 Like L</add_before>, only after L<HTML::Zoom/select> result.
628
629     $html_zoom
630         ->select('p')
631         ->add_after("\n\n");
632
633 You can add zoom events directly
634
635     $html_zoom
636         ->select('p')
637         ->add_after([ { type => 'TEXT', raw => 'O HAI' } ]);
638
639 =head2 prepend_content
640
641 Similar to add_before, but adds the content to the match.
642
643   HTML::Zoom
644     ->from_html(q[<p>World</p>])
645     ->select('p')
646     ->prepend_content("Hello ")
647     ->to_html
648     
649   ## <p>Hello World</p>
650   
651 Acceptable values are strings, scalar refs and L<HTML::Zoom> objects
652
653 =head2 append_content
654
655 Similar to add_after, but adds the content to the match.
656
657   HTML::Zoom
658     ->from_html(q[<p>Hello </p>])
659     ->select('p')
660     ->prepend_content("World")
661     ->to_html
662     
663   ## <p>Hello World</p>
664
665 Acceptable values are strings, scalar refs and L<HTML::Zoom> objects
666
667 =head2 replace
668
669 Given a L<HTML::Zoom/select> result, replace it with a string, array or another
670 L<HTML::Zoom> object.  It takes the same optional common options as L</collect>
671 (via hash reference).
672
673 =head2 replace_content
674
675 Given a L<HTML::Zoom/select> result, replace the content with a string, array
676 or another L<HTML::Zoom> object.
677
678     $html_zoom
679       ->select('title, #greeting')
680       ->replace_content('Hello world!');
681
682 =head2 repeat
683
684 For a given selection, repeat over transformations, typically for the purposes
685 of populating lists.  Takes either an array of anonymous subroutines or a zoom-
686 able object consisting of transformation.
687
688 Example of array reference style (when it doesn't matter that all iterations are
689 pre-generated)
690
691     $zoom->select('table')->repeat([
692       map {
693         my $elem = $_;
694         sub {
695           $_->select('td')->replace_content($e);
696         }
697       } @list
698     ]);
699     
700 Subroutines would be run with $_ localized to result of L<HTML::Zoom/select> (of
701 collected elements), and with said result passed as parameter to subroutine.
702
703 You might want to use CodeStream when you don't have all elements upfront
704
705     $zoom->select('.contents')->repeat(sub {
706       HTML::Zoom::CodeStream->new({
707         code => sub {
708           while (my $line = $fh->getline) {
709             return sub {
710               $_->select('.lno')->replace_content($fh->input_line_number)
711                 ->select('.line')->replace_content($line)
712             }
713           }
714           return
715         },
716       })
717     });
718
719 In addition to common options as in L</collect>, it also supports:
720
721 =over
722
723 =item repeat_between [SELECTOR]
724
725 Selects object to be repeated between items.  In the case of array this object
726 is put between elements, in case of iterator it is put between results of
727 subsequent iterations, in the case of streamable it is put between events
728 (->to_stream->next).
729
730 See documentation for L</repeat_content>
731
732 =back
733
734 =head2 repeat_content
735
736 Given a L<HTML::Zoom/select> result, run provided iterator passing content of
737 this result to this iterator.  Accepts the same options as L</repeat>.
738
739 Equivalent to using C<contents> option with L</repeat>.
740
741     $html_zoom
742        ->select('#list')
743        ->repeat_content(
744           [
745              sub {
746                 $_->select('.name')->replace_content('Matt')
747                   ->select('.age')->replace_content('26')
748              },
749              sub {
750                 $_->select('.name')->replace_content('Mark')
751                   ->select('.age')->replace_content('0x29')
752              },
753              sub {
754                 $_->select('.name')->replace_content('Epitaph')
755                   ->select('.age')->replace_content('<redacted>')
756              },
757           ],
758           { repeat_between => '.between' }
759        );
760
761
762 =head1 ALSO SEE
763
764 L<HTML::Zoom>
765
766 =head1 AUTHORS
767
768 See L<HTML::Zoom> for authors.
769
770 =head1 LICENSE
771
772 See L<HTML::Zoom> for the license.
773
774 =cut
775