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