Commit | Line | Data |
9d159224 |
1 | package HTML::Zoom::EventFilter; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | use Carp qw(confess); |
6 | |
7 | sub from_code { |
8 | my ($class, $code) = @_; |
9 | confess "from_code is a class method" if ref $class; |
10 | bless({ code => $code }, $class); |
11 | } |
12 | |
13 | sub next { |
14 | my $n = shift->{next} or return; |
15 | $n->${\$n->{code}}(@_); |
16 | } |
17 | |
18 | sub call { |
19 | $_[0]->{code}->(@_); |
20 | } |
21 | |
22 | sub set_next { |
23 | $_[0]->{next} = $_[1]; |
24 | $_[0]; |
25 | } |
26 | |
27 | sub get_next { $_[0]->{next} } |
28 | |
29 | sub push_next { |
30 | my ($self, $code) = @_; |
31 | $self->{next} = bless( |
32 | { code => $code, next => $self->{next} } |
33 | ); |
34 | } |
35 | |
36 | sub push_last { |
37 | my ($self, $code) = @_; |
38 | my $target = $self; |
39 | while ($target->{next} && $target->{next}{next}) { |
40 | $target = $target->{next} |
41 | } |
42 | $target->push_next($code); |
43 | } |
44 | |
45 | sub pop { |
46 | my ($self, $to) = @_; |
47 | die "$self doesn't have a next (->pop($to))" |
48 | unless $self->{next}; |
49 | my $target = $self; |
50 | until ($target->{next} eq $to) { |
51 | $target = $target->{next} || die "Didn't find $to as next of $self"; |
52 | } |
53 | $target->{next} = $to->{next}; |
54 | $_[0]; |
55 | } |
56 | |
57 | sub until_close_do_next { shift->until_close_do(next => @_) } |
58 | sub until_close_do_last { shift->until_close_do(last => @_) } |
59 | |
60 | sub until_close_do { |
61 | my ($self, $direction, $do, $before_close, $after_close) = @_; |
62 | my %depth = (OPEN => 1, CLOSE => -1, TEXT => 0); |
63 | my $count = 1; |
64 | my $outer = $self; |
65 | $self->${\"push_${direction}"}( |
66 | sub { |
67 | my ($self, $evt) = @_; |
68 | $count += $depth{$evt->{type}}; |
69 | if ($count) { |
70 | $do->(@_, $count) if $do; |
71 | return; |
72 | } |
73 | $before_close->($self, $evt) if $before_close; |
74 | $outer->pop($self)->next($evt); |
75 | $after_close->($outer, $evt) if $after_close; |
76 | } |
77 | ) |
78 | } |
79 | |
80 | sub standard_emitter { |
81 | my ($class, $out) = @_; |
82 | confess "standard_emitter is a class method" if ref $class; |
83 | $class->from_code(sub { |
84 | my ($self, $evt) = @_; |
85 | return $out->print($evt->{raw}) if defined $evt->{raw}; |
86 | if ($evt->{type} eq 'OPEN') { |
87 | $out->print( |
88 | '<' |
89 | .$evt->{name} |
90 | .(defined $evt->{raw_attrs} |
91 | ? $evt->{raw_attrs} |
92 | : do { |
93 | my @names = @{$evt->{attr_names}}; |
94 | @names |
95 | ? join(' ', '', map qq{${_}="${\$evt->{attrs}{$_}}"}, @names) |
96 | : '' |
97 | } |
98 | ) |
99 | .($evt->{is_in_place_close} ? ' /' : '') |
100 | .'>' |
101 | ); |
102 | } elsif ($evt->{type} eq 'CLOSE') { |
103 | $out->print('</'.$evt->{name}.'>'); |
104 | } else { |
105 | confess "No raw value in event and no special handling for type ".$evt->{type}; |
106 | } |
107 | }); |
108 | } |
109 | |
110 | sub selector_handler { |
111 | my ($class, $pairs) = @_; |
112 | confess "selector_handler is a class method" if ref $class; |
113 | $class->from_code(sub { |
114 | my ($self, $evt) = @_; |
115 | my $next = $self->get_next; |
116 | if ($evt->{type} eq 'OPEN') { |
117 | foreach my $p (@$pairs) { |
118 | $p->[1]->($self, $evt) if $p->[0]->($evt); |
119 | } |
120 | } |
121 | $next->call($evt); |
122 | }); |
123 | } |
124 | |
125 | sub build_selector_pair { |
126 | my ($class, $sel_spec, $action_spec) = @_; |
127 | my $selector = HTML::Zoom::SelectorParser->parse_selector($sel_spec); |
128 | my $action; |
129 | if (ref($action_spec) eq 'HASH') { |
130 | confess "hash spec must be single key" |
131 | unless keys(%$action_spec) == 1; |
132 | my ($key) = keys (%$action_spec); |
133 | $key =~ s/^-//; |
134 | $action = HTML::Zoom::ActionBuilder->build($key, values %$action_spec); |
135 | } |
136 | [ $selector, $action ]; |
137 | } |
138 | |
139 | 1; |