Commit | Line | Data |
456a815d |
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 | |
3cdbc13f |
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 | |
456a815d |
36 | sub _stream_concat { |
3cdbc13f |
37 | shift->_stream_from_array(@_)->flatten; |
456a815d |
38 | } |
39 | |
40 | sub set_attribute { |
41 | my ($self, $args) = @_; |
42 | my ($name, $value) = @{$args}{qw(name value)}; |
43 | sub { |
8f962884 |
44 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
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 { |
8f962884 |
59 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
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 { |
8f962884 |
77 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
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 | |
76cecb10 |
87 | sub collect { |
88 | my ($self, $options) = @_; |
89 | my ($into, $passthrough, $inside) = @{$options}{qw(into passthrough inside)}; |
90 | sub { |
91 | my ($evt, $stream) = @_; |
b4d044eb |
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 | } |
76cecb10 |
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 | |
456a815d |
128 | sub add_before { |
129 | my ($self, $events) = @_; |
8f962884 |
130 | sub { return $self->_stream_from_array(@$events, $_[0]) }; |
456a815d |
131 | } |
132 | |
133 | sub add_after { |
134 | my ($self, $events) = @_; |
b616863d |
135 | my $coll_proto = $self->collect({ passthrough => 1 }); |
456a815d |
136 | sub { |
8f962884 |
137 | my ($evt) = @_; |
456a815d |
138 | my $emit = $self->_stream_from_array(@$events); |
b616863d |
139 | my $coll = &$coll_proto; |
995bc8be |
140 | return ref($coll) eq 'HASH' # single event, no collect |
141 | ? [ $coll, $emit ] |
142 | : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]; |
456a815d |
143 | }; |
8f962884 |
144 | } |
456a815d |
145 | |
146 | sub prepend_inside { |
147 | my ($self, $events) = @_; |
148 | sub { |
8f962884 |
149 | my ($evt) = @_; |
456a815d |
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 | |
8f962884 |
160 | sub append_inside { |
161 | my ($self, $events) = @_; |
b616863d |
162 | my $coll_proto = $self->collect({ passthrough => 1, inside => 1 }); |
8f962884 |
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 | } |
b616863d |
171 | my $coll = &$coll_proto; |
8f962884 |
172 | my $emit = $self->_stream_from_array(@$events); |
173 | return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]; |
174 | }; |
175 | } |
176 | |
456a815d |
177 | sub replace { |
3cdbc13f |
178 | my ($self, $replace_with, $options) = @_; |
b616863d |
179 | my $coll_proto = $self->collect($options); |
456a815d |
180 | sub { |
181 | my ($evt, $stream) = @_; |
3cdbc13f |
182 | my $emit = $self->_stream_from_proto($replace_with); |
b616863d |
183 | my $coll = &$coll_proto; |
451b3b30 |
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 |
11cc25dd |
190 | return |
191 | ($coll |
192 | ? (ref $coll eq 'ARRAY' |
451b3b30 |
193 | ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ] |
194 | : $self->_stream_concat($coll, $emit) |
11cc25dd |
195 | ) |
196 | : $emit |
197 | ); |
456a815d |
198 | }; |
199 | } |
200 | |
3cdbc13f |
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 | |
456a815d |
216 | 1; |