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 | |
20 | sub _stream_concat { |
21 | shift; # lose $self |
22 | my @streams = @_; |
23 | my $cur_stream = shift(@streams) or die "No streams passed"; |
24 | HTML::Zoom::CodeStream->new({ |
25 | code => sub { |
26 | return unless $cur_stream; |
27 | my $evt; |
28 | until (($evt) = $cur_stream->next) { |
29 | return unless $cur_stream = shift(@streams); |
30 | } |
31 | return $evt; |
32 | } |
33 | }); |
34 | } |
35 | |
36 | sub set_attribute { |
37 | my ($self, $args) = @_; |
38 | my ($name, $value) = @{$args}{qw(name value)}; |
39 | sub { |
8f962884 |
40 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
41 | my $e = exists $a->{$name}; |
42 | +{ %$evt, raw => undef, raw_attrs => undef, |
43 | attrs => { %$a, $name => $value }, |
44 | ($e # add to name list if not present |
45 | ? () |
46 | : (attr_names => [ @{$evt->{attr_names}}, $name ])) |
47 | } |
48 | }; |
49 | } |
50 | |
51 | sub add_attribute { |
52 | my ($self, $args) = @_; |
53 | my ($name, $value) = @{$args}{qw(name value)}; |
54 | sub { |
8f962884 |
55 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
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 = $args->{name}; |
72 | sub { |
8f962884 |
73 | my $a = (my $evt = $_[0])->{attrs}; |
456a815d |
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 | |
76cecb10 |
83 | sub collect { |
84 | my ($self, $options) = @_; |
85 | my ($into, $passthrough, $inside) = @{$options}{qw(into passthrough inside)}; |
86 | sub { |
87 | my ($evt, $stream) = @_; |
b4d044eb |
88 | # We wipe the contents of @$into here so that other actions depending |
89 | # on this (such as a repeater) can be invoked multiple times easily. |
90 | # I -suspect- it's better for that state reset to be managed here; if it |
91 | # ever becomes painful the decision should be revisited |
92 | if ($into) { |
93 | @$into = $inside ? () : ($evt); |
94 | } |
76cecb10 |
95 | if ($evt->{is_in_place_close}) { |
96 | return $evt if $passthrough || $inside; |
97 | return; |
98 | } |
99 | my $name = $evt->{name}; |
100 | my $depth = 1; |
101 | my $_next = $inside ? 'peek' : 'next'; |
102 | my $collector = $self->_stream_from_code(sub { |
103 | return unless $stream; |
104 | while (my ($evt) = $stream->$_next) { |
105 | $depth++ if ($evt->{type} eq 'OPEN'); |
106 | $depth-- if ($evt->{type} eq 'CLOSE'); |
107 | unless ($depth) { |
108 | undef $stream; |
109 | return if $inside; |
110 | push(@$into, $evt) if $into; |
111 | return $evt if $passthrough; |
112 | return; |
113 | } |
114 | push(@$into, $evt) if $into; |
115 | $stream->next if $inside; |
116 | return $evt if $passthrough; |
117 | } |
118 | die "Never saw closing </${name}> before end of source"; |
119 | }); |
120 | return ($passthrough||$inside) ? [ $evt, $collector ] : $collector; |
121 | }; |
122 | } |
123 | |
456a815d |
124 | sub add_before { |
125 | my ($self, $events) = @_; |
8f962884 |
126 | sub { return $self->_stream_from_array(@$events, $_[0]) }; |
456a815d |
127 | } |
128 | |
129 | sub add_after { |
130 | my ($self, $events) = @_; |
b616863d |
131 | my $coll_proto = $self->collect({ passthrough => 1 }); |
456a815d |
132 | sub { |
8f962884 |
133 | my ($evt) = @_; |
456a815d |
134 | my $emit = $self->_stream_from_array(@$events); |
b616863d |
135 | my $coll = &$coll_proto; |
995bc8be |
136 | return ref($coll) eq 'HASH' # single event, no collect |
137 | ? [ $coll, $emit ] |
138 | : [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]; |
456a815d |
139 | }; |
8f962884 |
140 | } |
456a815d |
141 | |
142 | sub prepend_inside { |
143 | my ($self, $events) = @_; |
144 | sub { |
8f962884 |
145 | my ($evt) = @_; |
456a815d |
146 | if ($evt->{is_in_place_close}) { |
147 | $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)}; |
148 | return [ $evt, $self->_stream_from_array( |
149 | @$events, { type => 'CLOSE', name => $evt->{name} } |
150 | ) ]; |
151 | } |
152 | return $self->_stream_from_array($evt, @$events); |
153 | }; |
154 | } |
155 | |
8f962884 |
156 | sub append_inside { |
157 | my ($self, $events) = @_; |
b616863d |
158 | my $coll_proto = $self->collect({ passthrough => 1, inside => 1 }); |
8f962884 |
159 | sub { |
160 | my ($evt) = @_; |
161 | if ($evt->{is_in_place_close}) { |
162 | $evt = { %$evt }; delete @{$evt}{qw(raw is_in_place_close)}; |
163 | return [ $evt, $self->_stream_from_array( |
164 | @$events, { type => 'CLOSE', name => $evt->{name} } |
165 | ) ]; |
166 | } |
b616863d |
167 | my $coll = &$coll_proto; |
8f962884 |
168 | my $emit = $self->_stream_from_array(@$events); |
169 | return [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ]; |
170 | }; |
171 | } |
172 | |
456a815d |
173 | sub replace { |
11cc25dd |
174 | my ($self, $events, $options) = @_; |
b616863d |
175 | my $coll_proto = $self->collect($options); |
456a815d |
176 | sub { |
177 | my ($evt, $stream) = @_; |
178 | my $emit = $self->_stream_from_array(@$events); |
b616863d |
179 | my $coll = &$coll_proto; |
451b3b30 |
180 | # For a straightforward replace operation we can, in fact, do the emit |
181 | # -before- the collect, and my first cut did so. However in order to |
182 | # use the captured content in generating the new content, we need |
183 | # the collect stage to happen first - and it seems highly unlikely |
184 | # that in normal operation the collect phase will take long enough |
185 | # for the difference to be noticeable |
11cc25dd |
186 | return |
187 | ($coll |
188 | ? (ref $coll eq 'ARRAY' |
451b3b30 |
189 | ? [ $coll->[0], $self->_stream_concat($coll->[1], $emit) ] |
190 | : $self->_stream_concat($coll, $emit) |
11cc25dd |
191 | ) |
192 | : $emit |
193 | ); |
456a815d |
194 | }; |
195 | } |
196 | |
456a815d |
197 | 1; |