blib/lib/Parse/BBCode.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 506 | 510 | 99.2 |
branch | 196 | 210 | 93.3 |
condition | 101 | 125 | 80.8 |
subroutine | 31 | 31 | 100.0 |
pod | 10 | 10 | 100.0 |
total | 844 | 886 | 95.2 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Parse::BBCode; | ||||||
2 | $Parse::BBCode::VERSION = '0.15_001'; # TRIAL | ||||||
3 | |||||||
4 | 14 | 14 | 162578 | $Parse::BBCode::VERSION = '0.15001';use strict; | |||
14 | 18 | ||||||
14 | 346 | ||||||
5 | 14 | 14 | 47 | use warnings; | |||
14 | 16 | ||||||
14 | 290 | ||||||
6 | 14 | 14 | 4754 | use Parse::BBCode::Tag; | |||
14 | 82 | ||||||
14 | 69 | ||||||
7 | 14 | 14 | 5450 | use Parse::BBCode::HTML qw/ &defaults &default_escapes &optional /; | |||
14 | 28 | ||||||
14 | 1745 | ||||||
8 | 14 | 14 | 82 | use base 'Class::Accessor::Fast'; | |||
14 | 15 | ||||||
14 | 1117 | ||||||
9 | __PACKAGE__->follow_best_practice; | ||||||
10 | __PACKAGE__->mk_accessors(qw/ | ||||||
11 | tags allowed compiled plain strict_attributes close_open_tags error | ||||||
12 | tree escapes direct_attribute params url_finder text_processor linebreaks | ||||||
13 | smileys attribute_parser strip_linebreaks attribute_quote /); | ||||||
14 | #use Data::Dumper; | ||||||
15 | 14 | 14 | 57 | use Carp; | |||
14 | 15 | ||||||
14 | 29445 | ||||||
16 | my $scalar_util = eval "require Scalar::Util; 1"; | ||||||
17 | |||||||
18 | my %defaults = ( | ||||||
19 | strict_attributes => 1, | ||||||
20 | direct_attribute => 1, | ||||||
21 | linebreaks => 1, | ||||||
22 | smileys => 0, | ||||||
23 | url_finder => 0, | ||||||
24 | strip_linebreaks => 1, | ||||||
25 | attribute_quote => '"', | ||||||
26 | ); | ||||||
27 | sub new { | ||||||
28 | 37 | 37 | 1 | 12754 | my ($class, $args) = @_; | ||
29 | 37 | 100 | 92 | $args ||= {}; | |||
30 | 37 | 106 | my %args = %$args; | ||||
31 | 37 | 100 | 92 | unless ($args{tags}) { | |||
32 | 6 | 20 | $args{tags} = { $class->defaults }; | ||||
33 | } | ||||||
34 | else { | ||||||
35 | 31 | 28 | $args{tags} = { %{ $args{tags} } }; | ||||
31 | 110 | ||||||
36 | } | ||||||
37 | 37 | 100 | 82 | unless ($args{escapes}) { | |||
38 | 34 | 108 | $args{escapes} = {$class->default_escapes }; | ||||
39 | } | ||||||
40 | else { | ||||||
41 | 3 | 3 | $args{escapes} = { %{ $args{escapes} } } | ||||
3 | 8 | ||||||
42 | } | ||||||
43 | 37 | 322 | my $self = $class->SUPER::new({ | ||||
44 | %defaults, | ||||||
45 | %args | ||||||
46 | }); | ||||||
47 | 37 | 346 | $self->set_allowed([ grep { length } keys %{ $self->get_tags } ]); | ||||
283 | 477 | ||||||
37 | 103 | ||||||
48 | 37 | 230 | $self->_compile_tags; | ||||
49 | 37 | 223 | return $self; | ||||
50 | } | ||||||
51 | |||||||
52 | my $re_split = qr{ % (?:\{ (?:[a-zA-Z\|]+) \})? (?:attr|[Aas]) }x; | ||||||
53 | my $re_cmp = qr{ % (?:\{ ([a-zA-Z\|]+) \})? (attr|[Aas]) }x; | ||||||
54 | |||||||
55 | sub forbid { | ||||||
56 | 2 | 2 | 1 | 1130 | my ($self, @tags) = @_; | ||
57 | 2 | 8 | my $allowed = $self->get_allowed; | ||||
58 | 2 | 10 | my $re = join '|', map { quotemeta } @tags; | ||||
2 | 9 | ||||||
59 | 2 | 4 | @$allowed = grep { ! m/^(?:$re)\z/ } @$allowed; | ||||
27 | 78 | ||||||
60 | } | ||||||
61 | |||||||
62 | sub permit { | ||||||
63 | 3 | 3 | 1 | 1457 | my ($self, @tags) = @_; | ||
64 | 3 | 12 | my $allowed = $self->get_allowed; | ||||
65 | 3 | 13 | my %seen; | ||||
66 | @$allowed = grep { | ||||||
67 | 3 | 50 | 6 | !$seen{$_}++ && $self->get_tags->{$_}; | |||
42 | 212 | ||||||
68 | } (@$allowed, @tags); | ||||||
69 | } | ||||||
70 | |||||||
71 | sub _compile_tags { | ||||||
72 | 37 | 37 | 39 | my ($self) = @_; | |||
73 | # unless ($self->get_compiled) { | ||||||
74 | { | ||||||
75 | 37 | 35 | my $defs = $self->get_tags; | ||||
37 | 61 | ||||||
76 | |||||||
77 | # get definition for how text should be rendered which is not in tags | ||||||
78 | 37 | 104 | my $plain; | ||||
79 | 37 | 100 | 78 | if (exists $defs->{""}) { | |||
80 | 9 | 13 | $plain = delete $defs->{""}; | ||||
81 | 9 | 100 | 37 | if (ref $plain eq 'CODE') { | |||
82 | 8 | 27 | $self->set_plain($plain); | ||||
83 | } | ||||||
84 | } | ||||||
85 | else { | ||||||
86 | 28 | 63 | my $url_finder = $self->get_url_finder; | ||||
87 | 28 | 109 | my $linebreaks = $self->get_linebreaks; | ||||
88 | 28 | 105 | my $smileys = $self->get_smileys; | ||||
89 | 28 | 100 | 118 | if ($url_finder) { | |||
90 | 6 | 6 | my $result = eval { require URI::Find; 1 }; | ||||
6 | 27 | ||||||
6 | 7 | ||||||
91 | 6 | 50 | 13 | unless ($result) { | |||
92 | 0 | 0 | undef $url_finder; | ||||
93 | } | ||||||
94 | } | ||||||
95 | 28 | 45 | my $escape = \&Parse::BBCode::escape_html; | ||||
96 | 28 | 29 | my $post_processor_1 = $escape; | ||||
97 | 28 | 42 | my $post_processor; | ||||
98 | 28 | 66 | my $text_processor = $self->get_text_processor; | ||||
99 | 28 | 100 | 109 | if ($text_processor) { | |||
100 | 5 | 5 | $post_processor_1 = $text_processor; | ||||
101 | } | ||||||
102 | 28 | 100 | 66 | 80 | if ($smileys and ref($smileys->{icons}) eq 'HASH') { | ||
103 | $smileys = { | ||||||
104 | icons => $smileys->{icons}, | ||||||
105 | base_url => $smileys->{base_url} || '/smileys/', | ||||||
106 | 1 | 50 | 6 | format => $smileys->{format} || ' |
|||
50 | |||||||
107 | }; | ||||||
108 | 4 | 8 | my $re = join '|', map { quotemeta $_ } sort { length $b <=> length $a } | ||||
5 | 5 | ||||||
109 | 1 | 2 | keys %{ $smileys->{icons} }; | ||||
1 | 4 | ||||||
110 | my $code = sub { | ||||||
111 | 4 | 4 | 5 | my ($text, $post_processor) = @_; | |||
112 | 4 | 3 | my $out = ''; | ||||
113 | 4 | 60 | while ($text =~ s/\A (^|.*?[\s]) ($re) (?=[\s]|$)//xsm) { | ||||
114 | 7 | 13 | my ($pre, $emo) = ($1, $2); | ||||
115 | 7 | 11 | my $url = "$smileys->{base_url}$smileys->{icons}->{$emo}"; | ||||
116 | 7 | 7 | my $emo_escaped = Parse::BBCode::escape_html($emo); | ||||
117 | 7 | 18 | my $image_tag = sprintf $smileys->{format}, $url, $emo_escaped; | ||||
118 | 7 | 11 | $out .= $post_processor_1->($pre) . $image_tag; | ||||
119 | } | ||||||
120 | 4 | 6 | $out .= $post_processor_1->($text); | ||||
121 | 4 | 5 | return $out; | ||||
122 | 1 | 7 | }; | ||||
123 | 1 | 2 | $post_processor = $code; | ||||
124 | } | ||||||
125 | else { | ||||||
126 | 27 | 28 | $post_processor = $post_processor_1; | ||||
127 | } | ||||||
128 | |||||||
129 | 28 | 100 | 43 | if ($url_finder) { | |||
130 | 6 | 5 | my $url_find_sub; | ||||
131 | 6 | 100 | 10 | if (ref($url_finder) eq 'CODE') { | |||
132 | 1 | 2 | $url_find_sub = $url_finder; | ||||
133 | } | ||||||
134 | else { | ||||||
135 | 5 | 100 | 8 | unless (ref($url_finder) eq 'HASH') { | |||
136 | 1 | 3 | $url_finder = { | ||||
137 | max_length => 50, | ||||||
138 | format => '%s', | ||||||
139 | }; | ||||||
140 | } | ||||||
141 | 5 | 50 | 8 | my $max_url = $url_finder->{max_length} || 0; | |||
142 | 5 | 6 | my $format = $url_finder->{format}; | ||||
143 | my $finder = URI::Find->new(sub { | ||||||
144 | 2 | 2 | 5698 | my ($url) = @_; | |||
145 | 2 | 1 | my $title = $url; | ||||
146 | 2 | 100 | 66 | 8 | if ($max_url and length($title) > $max_url) { | ||
147 | 1 | 6 | $title = substr($title, 0, $max_url) . "..."; | ||||
148 | } | ||||||
149 | 2 | 11 | my $escaped = Parse::BBCode::escape_html($url); | ||||
150 | 2 | 3 | my $escaped_title = Parse::BBCode::escape_html($title); | ||||
151 | 2 | 6 | my $href = sprintf $format, $escaped, $title; | ||||
152 | 2 | 10 | return $href; | ||||
153 | 5 | 25 | }); | ||||
154 | $url_find_sub = sub { | ||||||
155 | 5 | 5 | 6 | my ($ref_content, $post, $info) = @_; | |||
156 | 5 | 19 | $finder->find($ref_content, sub { $post->($_[0], $info) }); | ||||
2 | 54 | ||||||
157 | 5 | 42 | }; | ||||
158 | } | ||||||
159 | $plain = sub { | ||||||
160 | 9 | 9 | 9 | my ($parser, $attr, $content, $info) = @_; | |||
161 | 9 | 100 | 14 | unless ($info->{classes}->{url}) { | |||
162 | 6 | 9 | $url_find_sub->(\$content, $post_processor, $info); | ||||
163 | } | ||||||
164 | else { | ||||||
165 | 3 | 4 | $content = $post_processor->($content); | ||||
166 | } | ||||||
167 | 9 | 100 | 979 | $content =~ s/\r?\n|\r/ \n/g if $linebreaks; |
|||
168 | 9 | 18 | $content; | ||||
169 | 6 | 16 | }; | ||||
170 | } | ||||||
171 | else { | ||||||
172 | $plain = sub { | ||||||
173 | 234 | 234 | 199 | my ($parser, $attr, $content, $info) = @_; | |||
174 | 234 | 255 | my $text = $post_processor->($content, $info); | ||||
175 | 234 | 100 | 698 | $text =~ s/\r?\n|\r/ \n/g if $linebreaks; |
|||
176 | 234 | 354 | $text; | ||||
177 | 22 | 81 | }; | ||||
178 | } | ||||||
179 | 28 | 73 | $self->set_plain($plain); | ||||
180 | } | ||||||
181 | |||||||
182 | # now compile the rest of definitions | ||||||
183 | 37 | 198 | for my $key (keys %$defs) { | ||||
184 | 274 | 255 | my $def = $defs->{$key}; | ||||
185 | #warn __PACKAGE__.':'.__LINE__.": $key: $def\n"; | ||||||
186 | 274 | 100 | 66 | 472 | if (not ref $def) { | ||
100 | |||||||
187 | 186 | 262 | my $new_def = $self->_compile_def($def); | ||||
188 | 186 | 185 | $defs->{$key} = $new_def; | ||||
189 | } | ||||||
190 | elsif (not exists $def->{code} and exists $def->{output}) { | ||||||
191 | 8 | 13 | my $new_def = $self->_compile_def($def); | ||||
192 | 8 | 10 | $defs->{$key} = $new_def; | ||||
193 | } | ||||||
194 | 274 | 100 | 418 | $defs->{$key}->{class} ||= 'inline'; | |||
195 | 274 | 100 | 459 | $defs->{$key}->{classic} = 1 unless defined $defs->{$key}->{classic}; | |||
196 | 274 | 100 | 439 | $defs->{$key}->{close} = 1 unless defined $defs->{$key}->{close}; | |||
197 | } | ||||||
198 | 37 | 119 | $self->set_compiled(1); | ||||
199 | } | ||||||
200 | } | ||||||
201 | |||||||
202 | sub _compile_def { | ||||||
203 | 194 | 194 | 171 | my ($self, $def) = @_; | |||
204 | 194 | 323 | my $esc = $self->get_escapes; | ||||
205 | 194 | 528 | my $parse = 0; | ||||
206 | 194 | 187 | my $new_def = {}; | ||||
207 | 194 | 144 | my $output = $def; | ||||
208 | 194 | 136 | my $close = 1; | ||||
209 | 194 | 143 | my $class = 'inline'; | ||||
210 | 194 | 100 | 248 | if (ref $def eq 'HASH') { | |||
211 | 8 | 19 | $new_def = { %$def }; | ||||
212 | 8 | 14 | $output = delete $new_def->{output}; | ||||
213 | 8 | 5 | $parse = $new_def->{parse}; | ||||
214 | 8 | 100 | 17 | $close = $new_def->{close} if exists $new_def->{close}; | |||
215 | 8 | 100 | 14 | $class = $new_def->{class} if exists $new_def->{class}; | |||
216 | } | ||||||
217 | else { | ||||||
218 | } | ||||||
219 | # we have a string, compile | ||||||
220 | #warn __PACKAGE__.':'.__LINE__.": $key => $output\n"; | ||||||
221 | 194 | 100 | 474 | if ($output =~ s/^(inline|block|url)://) { | |||
222 | 43 | 69 | $class = $1; | ||||
223 | } | ||||||
224 | 194 | 1315 | my @parts = split m!($re_split)!, $output; | ||||
225 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@parts], ['parts']); | ||||||
226 | 194 | 154 | my @compiled; | ||||
227 | 194 | 205 | for my $p (@parts) { | ||||
228 | 775 | 100 | 1885 | if ($p =~ m/$re_cmp/) { | |||
229 | 305 | 422 | my ($escape, $type) = ($1, $2); | ||||
230 | 305 | 100 | 575 | $escape ||= 'parse'; | |||
231 | 305 | 408 | my @escapes = split /\|/, $escape; | ||||
232 | 305 | 100 | 252 | if (grep { $_ eq 'parse' } @escapes) { | |||
309 | 663 | ||||||
233 | 161 | 125 | $parse = 1; | ||||
234 | } | ||||||
235 | 305 | 619 | push @compiled, [\@escapes, $type]; | ||||
236 | } | ||||||
237 | else { | ||||||
238 | 470 | 597 | push @compiled, $p; | ||||
239 | } | ||||||
240 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@compiled], ['compiled']); | ||||||
241 | } | ||||||
242 | my $code = sub { | ||||||
243 | 247 | 247 | 290 | my ($self, $attr, $string, $fallback, $tag) = @_; | |||
244 | 247 | 229 | my $out = ''; | ||||
245 | 247 | 236 | for my $c (@compiled) { | ||||
246 | |||||||
247 | # just text | ||||||
248 | 852 | 100 | 896 | unless (ref $c) { | |||
249 | 525 | 557 | $out .= $c; | ||||
250 | } | ||||||
251 | # tag attribute or content | ||||||
252 | else { | ||||||
253 | 327 | 398 | my ($escapes, $type) = @$c; | ||||
254 | 327 | 397 | my @escapes = @$escapes; | ||||
255 | 327 | 224 | my $var = ''; | ||||
256 | 327 | 480 | my $attributes = $tag->get_attr; | ||||
257 | 327 | 100 | 100 | 1539 | if ($type eq 'attr' and @$attributes > 1) { | ||
100 | |||||||
100 | |||||||
100 | |||||||
258 | 4 | 4 | my $name = shift @escapes; | ||||
259 | 4 | 10 | for my $item (@$attributes[1 .. $#$attributes]) { | ||||
260 | 4 | 50 | 7 | if ($item->[0] eq $name) { | |||
261 | 4 | 8 | $var = $item->[1]; | ||||
262 | 4 | 5 | last; | ||||
263 | } | ||||||
264 | } | ||||||
265 | } | ||||||
266 | elsif ($type eq 'a') { | ||||||
267 | 13 | 15 | $var = $attr; | ||||
268 | } | ||||||
269 | elsif ($type eq 'A') { | ||||||
270 | 61 | 58 | $var = $fallback; | ||||
271 | } | ||||||
272 | elsif ($type eq 's') { | ||||||
273 | 248 | 100 | 378 | if (ref $string eq 'SCALAR') { | |||
274 | # this text is already finished and escaped | ||||||
275 | 239 | 232 | $string = $$string; | ||||
276 | } | ||||||
277 | 248 | 205 | $var = $string; | ||||
278 | } | ||||||
279 | 327 | 290 | for my $e (@escapes) { | ||||
280 | 324 | 290 | my $sub = $esc->{$e}; | ||||
281 | 324 | 100 | 487 | if ($sub) { | |||
282 | 95 | 207 | $var = $sub->($self, $c, $var); | ||||
283 | 95 | 100 | 340 | unless (defined $var) { | |||
284 | # if escape returns undef, we return it unparsed | ||||||
285 | return $tag->get_start | ||||||
286 | . (join '', map { | ||||||
287 | 14 | 35 | $self->_render_tree($_); | ||||
288 | 8 | 58 | } @{ $tag->get_content }) | ||||
8 | 31 | ||||||
289 | . $tag->get_end; | ||||||
290 | } | ||||||
291 | } | ||||||
292 | } | ||||||
293 | 319 | 455 | $out .= $var; | ||||
294 | } | ||||||
295 | } | ||||||
296 | 239 | 294 | return $out; | ||||
297 | 194 | 820 | }; | ||||
298 | 194 | 250 | $new_def->{parse} = $parse; | ||||
299 | 194 | 173 | $new_def->{code} = $code; | ||||
300 | 194 | 173 | $new_def->{close} = $close; | ||||
301 | 194 | 192 | $new_def->{class} = $class; | ||||
302 | 194 | 351 | return $new_def; | ||||
303 | } | ||||||
304 | |||||||
305 | sub _render_text { | ||||||
306 | 562 | 562 | 493 | my ($self, $tag, $text, $info) = @_; | |||
307 | #warn __PACKAGE__.':'.__LINE__.": text '$text'\n"; | ||||||
308 | 562 | 100 | 765 | defined (my $code = $self->get_plain) or return $text; | |||
309 | 559 | 1861 | return $code->($self, $tag, $text, $info); | ||||
310 | } | ||||||
311 | |||||||
312 | sub parse { | ||||||
313 | 199 | 199 | 1 | 231 | my ($self, $text, $params) = @_; | ||
314 | 199 | 100 | 392 | my $parse_attributes = $self->get_attribute_parser ? $self->get_attribute_parser : $self->can('parse_attributes'); | |||
315 | 199 | 1247 | $self->set_error(undef); | ||||
316 | 199 | 920 | my $defs = $self->get_tags; | ||||
317 | 199 | 50 | 621 | my $tags = $self->get_allowed || [keys %$defs]; | |||
318 | 199 | 675 | my @classic_tags = grep { $defs->{$_}->{classic} } @$tags; | ||||
2305 | 2384 | ||||||
319 | 199 | 183 | my @short_tags = grep { $defs->{$_}->{short} } @$tags; | ||||
2305 | 1739 | ||||||
320 | 199 | 490 | my $re_classic = join '|', map { quotemeta } sort {length $b <=> length $a } @classic_tags; | ||||
2295 | 2259 | ||||||
6066 | 3961 | ||||||
321 | #$re_classic = qr/$re_classic/i; | ||||||
322 | 199 | 407 | my $re_short = join '|', map { quotemeta } sort {length $b <=> length $a } @short_tags; | ||||
30 | 30 | ||||||
30 | 26 | ||||||
323 | #$re_short = qr/$re_short/i; | ||||||
324 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$re], ['re']); | ||||||
325 | 199 | 168 | my @tags; | ||||
326 | 199 | 154 | my $out = ''; | ||||
327 | 199 | 137 | my @opened; | ||||
328 | 199 | 143 | my $current_open_re = ''; | ||||
329 | my $callback_found_text = sub { | ||||||
330 | 350 | 350 | 337 | my ($text) = @_; | |||
331 | 350 | 100 | 422 | if (@opened) { | |||
332 | 128 | 118 | my $o = $opened[-1]; | ||||
333 | 128 | 266 | $o->add_content($text); | ||||
334 | } | ||||||
335 | else { | ||||||
336 | 222 | 100 | 100 | 649 | if (@tags and !ref $tags[-1]) { | ||
337 | # text tag, concatenate | ||||||
338 | 14 | 22 | $tags[-1] .= $text; | ||||
339 | } | ||||||
340 | else { | ||||||
341 | 208 | 299 | push @tags, $text; | ||||
342 | } | ||||||
343 | } | ||||||
344 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); | ||||||
345 | 199 | 1218 | }; | ||||
346 | 199 | 160 | my $callback_found_tag; | ||||
347 | 199 | 155 | my $in_url = 0; | ||||
348 | $callback_found_tag = sub { | ||||||
349 | 352 | 352 | 335 | my ($tag) = @_; | |||
350 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']); | ||||||
351 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); | ||||||
352 | 352 | 100 | 549 | if (@opened) { | |||
100 | |||||||
353 | 147 | 151 | my $o = $opened[-1]; | ||||
354 | 147 | 202 | my $class = $o->get_class; | ||||
355 | #warn __PACKAGE__.':'.__LINE__.": tag $tag\n"; | ||||||
356 | 147 | 100 | 100 | 1074 | if (ref $tag and $class =~ m/inline|url/ and $tag->get_class eq 'block') { | ||
100 | 100 | ||||||
357 | 6 | 27 | $self->_add_error('block_inline', $tag); | ||||
358 | 6 | 18 | pop @opened; | ||||
359 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$o], ['o']); | ||||||
360 | 6 | 100 | 10 | if ($self->get_close_open_tags) { | |||
361 | # we close the tag for you | ||||||
362 | 2 | 8 | $self->_finish_tag($o, '[/' . $o->get_name . ']', 1); | ||||
363 | 2 | 10 | $callback_found_tag->($o); | ||||
364 | 2 | 6 | $callback_found_tag->($tag); | ||||
365 | } | ||||||
366 | else { | ||||||
367 | # nope, no automatic closing, invalidate all | ||||||
368 | # open inline tags before | ||||||
369 | 4 | 18 | my @red = $o->_reduce; | ||||
370 | 4 | 22 | $callback_found_tag->($_) for @red; | ||||
371 | 4 | 9 | $callback_found_tag->($tag); | ||||
372 | } | ||||||
373 | } | ||||||
374 | elsif (ref $tag) { | ||||||
375 | 121 | 432 | my $def = $defs->{lc $tag->get_name}; | ||||
376 | 121 | 348 | my $parse = $def->{parse}; | ||||
377 | 121 | 100 | 138 | if ($parse) { | |||
378 | 112 | 160 | $o->add_content($tag); | ||||
379 | } | ||||||
380 | else { | ||||||
381 | 9 | 22 | my $content = $tag->get_content; | ||||
382 | 9 | 24 | my $string = ''; | ||||
383 | 9 | 12 | for my $c (@$content) { | ||||
384 | 8 | 100 | 14 | if (ref $c) { | |||
385 | 1 | 3 | $string .= $c->raw_text( auto_close => 0 ); | ||||
386 | } | ||||||
387 | else { | ||||||
388 | 7 | 11 | $string .= $c; | ||||
389 | } | ||||||
390 | } | ||||||
391 | 9 | 19 | $tag->set_content([$string]); | ||||
392 | 9 | 39 | $o->add_content($tag); | ||||
393 | } | ||||||
394 | } | ||||||
395 | else { | ||||||
396 | 20 | 36 | $o->add_content($tag); | ||||
397 | } | ||||||
398 | } | ||||||
399 | elsif (ref $tag) { | ||||||
400 | 198 | 317 | my $def = $defs->{lc $tag->get_name}; | ||||
401 | 198 | 603 | my $parse = $def->{parse}; | ||||
402 | 198 | 100 | 216 | if ($parse) { | |||
403 | 162 | 177 | push @tags, $tag; | ||||
404 | } | ||||||
405 | else { | ||||||
406 | 36 | 61 | my $content = $tag->get_content; | ||||
407 | 36 | 103 | my $string = ''; | ||||
408 | 36 | 99 | for my $c (@$content) { | ||||
409 | 35 | 100 | 91 | if (ref $c) { | |||
410 | 2 | 5 | $string .= $c->raw_text( auto_close => 0 ); | ||||
411 | } | ||||||
412 | else { | ||||||
413 | 33 | 52 | $string .= $c; | ||||
414 | } | ||||||
415 | } | ||||||
416 | 36 | 76 | $tag->set_content([$string]); | ||||
417 | 36 | 138 | push @tags, $tag; | ||||
418 | } | ||||||
419 | } | ||||||
420 | else { | ||||||
421 | 7 | 9 | push @tags, $tag; | ||||
422 | } | ||||||
423 | $current_open_re = join '|', map { | ||||||
424 | 352 | 722 | quotemeta $_->get_name | ||||
187 | 357 | ||||||
425 | } @opened; | ||||||
426 | |||||||
427 | 199 | 660 | }; | ||||
428 | 199 | 236 | my @class = 'block'; | ||||
429 | 199 | 100 | 776 | while (defined $text and length $text) { | |||
430 | 550 | 570 | $in_url = grep { $_->get_class eq 'url' } @opened; | ||||
544 | 1101 | ||||||
431 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$in_url], ['in_url']); | ||||||
432 | #warn __PACKAGE__.':'.__LINE__.": ============= match $text\n"; | ||||||
433 | 550 | 1099 | my $tag; | ||||
434 | 550 | 405 | my ($before, $tag1, $tag2, $after); | ||||
435 | 550 | 100 | 66 | 3025 | if ($re_classic and $re_short) { | ||
50 | 33 | ||||||
50 | 33 | ||||||
436 | 29 | 281 | ($before, $tag1, $tag2, $after) = split m{ | ||||
437 | (?: | ||||||
438 | \[ ($re_short) (?=://) | ||||||
439 | | | ||||||
440 | \[ ($re_classic) (?=\b|\]|\=) | ||||||
441 | ) | ||||||
442 | }ix, $text, 2; | ||||||
443 | } | ||||||
444 | elsif (! $re_classic and $re_short) { | ||||||
445 | 0 | 0 | ($before, $tag1, $after) = split m{ | ||||
446 | \[ ($re_short) (?=://) | ||||||
447 | }ix, $text, 2; | ||||||
448 | } | ||||||
449 | elsif ($re_classic and !$re_short) { | ||||||
450 | 521 | 4508 | ($before, $tag2, $after) = split m{ | ||||
451 | \[ ($re_classic) (?=\b|\]|\=) | ||||||
452 | }ix, $text, 2; | ||||||
453 | } | ||||||
454 | 14 | 14 | 74 | { no warnings; | |||
14 | 22 | ||||||
14 | 27674 | ||||||
0 | 0 | ||||||
455 | # warn __PACKAGE__.':'.__LINE__.": $before, $tag1, $tag2, $after)\n"; | ||||||
456 | #warn __PACKAGE__.':'.__LINE__.": RE: $current_open_re\n"; | ||||||
457 | } | ||||||
458 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); | ||||||
459 | 550 | 100 | 579 | if (length $before) { | |||
550 | 794 | ||||||
460 | # look if it contains a closing tag | ||||||
461 | #warn __PACKAGE__.':'.__LINE__.": BEFORE $before\n"; | ||||||
462 | 339 | 100 | 4037 | while (length $current_open_re and $before =~ s# (.*?) (\[ / ($current_open_re) \]) ##ixs) { | |||
463 | # found closing tag | ||||||
464 | 219 | 1716 | my ($content, $end, $name) = ($1, $2, $3); | ||||
465 | #warn __PACKAGE__.':'.__LINE__.": found closing tag $name!\n"; | ||||||
466 | 219 | 172 | my $f; | ||||
467 | # try to find the matching opening tag | ||||||
468 | my @not_close; | ||||||
469 | 219 | 324 | while (@opened) { | ||||
470 | 262 | 269 | my $try = pop @opened; | ||||
471 | $current_open_re = join '|', map { | ||||||
472 | 262 | 297 | quotemeta $_->get_name | ||||
167 | 391 | ||||||
473 | } @opened; | ||||||
474 | 262 | 100 | 766 | if ($try->get_name eq lc $name) { | |||
100 | |||||||
475 | 219 | 683 | $f = $try; | ||||
476 | 219 | 239 | last; | ||||
477 | } | ||||||
478 | elsif (!$try->get_close) { | ||||||
479 | 33 | 225 | $self->_finish_tag($try, ''); | ||||
480 | 33 | 76 | unshift @not_close, $try; | ||||
481 | } | ||||||
482 | else { | ||||||
483 | # unbalanced | ||||||
484 | 10 | 89 | $self->_add_error('unclosed', $try); | ||||
485 | 10 | 100 | 47 | if ($self->get_close_open_tags) { | |||
486 | # close | ||||||
487 | 1 | 4 | $f = $try; | ||||
488 | 1 | 2 | unshift @not_close, $try; | ||||
489 | 1 | 50 | 4 | if (@opened) { | |||
490 | 1 | 3 | $opened[-1]->add_content(''); | ||||
491 | } | ||||||
492 | 1 | 3 | $self->_finish_tag($try, '[/'. $try->get_name() .']', 1); | ||||
493 | } | ||||||
494 | else { | ||||||
495 | # just add unparsed text | ||||||
496 | 9 | 51 | $callback_found_tag->($_) for $try->_reduce; | ||||
497 | } | ||||||
498 | } | ||||||
499 | } | ||||||
500 | 219 | 100 | 352 | if (@not_close) { | |||
501 | 28 | 99 | $not_close[-1]->add_content($content); | ||||
502 | } | ||||||
503 | 219 | 298 | for my $n (@not_close) { | ||||
504 | 34 | 59 | $f->add_content($n); | ||||
505 | #$callback_found_tag->($n); | ||||||
506 | } | ||||||
507 | # add text before closing tag as content to the current open tag | ||||||
508 | 219 | 50 | 305 | if ($f) { | |||
509 | 219 | 100 | 297 | unless (@not_close) { | |||
510 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']); | ||||||
511 | 191 | 360 | $f->add_content( $content ); | ||||
512 | } | ||||||
513 | # TODO | ||||||
514 | 219 | 312 | $self->_finish_tag($f, $end); | ||||
515 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']); | ||||||
516 | 219 | 257 | $callback_found_tag->($f); | ||||
517 | } | ||||||
518 | } | ||||||
519 | # warn __PACKAGE__." === before='$before' ($tag)\n"; | ||||||
520 | 339 | 746 | $callback_found_text->($before); | ||||
521 | } | ||||||
522 | |||||||
523 | 550 | 100 | 751 | if (defined $tag1) { | |||
524 | 10 | 9 | $in_url = grep { $_->get_class eq 'url' } @opened; | ||||
2 | 3 | ||||||
525 | # short tag | ||||||
526 | # $callback_found_text->($before) if length $before; | ||||||
527 | 10 | 100 | 47 | if ($after =~ s{ :// ([^\[]+) \] }{}x) { | |||
528 | 8 | 12 | my $content = $1; | ||||
529 | 8 | 13 | my ($attr, $title) = split /\|/, $content, 2; | ||||
530 | my $tag = $self->new_tag({ | ||||||
531 | name => lc $tag1, | ||||||
532 | attr => [[$attr]], | ||||||
533 | attr_raw => $attr, | ||||||
534 | content => [(defined $title and length $title) ? $title : ()], | ||||||
535 | start => "[$tag1://$content]", | ||||||
536 | close => 0, | ||||||
537 | class => $defs->{lc $tag1}->{class}, | ||||||
538 | single => $defs->{lc $tag1}->{single}, | ||||||
539 | 8 | 100 | 66 | 86 | in_url => $in_url, | ||
540 | type => 'short', | ||||||
541 | }); | ||||||
542 | 8 | 100 | 66 | 94 | if ($in_url and $tag->get_class eq 'url') { | ||
543 | 1 | 7 | $callback_found_text->($tag->get_start); | ||||
544 | } | ||||||
545 | else { | ||||||
546 | 7 | 9 | $callback_found_tag->($tag); | ||||
547 | } | ||||||
548 | } | ||||||
549 | else { | ||||||
550 | 2 | 5 | $callback_found_text->("[$tag1"); | ||||
551 | } | ||||||
552 | 10 | 14 | $text = $after; | ||||
553 | 10 | 33 | next; | ||||
554 | } | ||||||
555 | 540 | 414 | $tag = $tag2; | ||||
556 | |||||||
557 | |||||||
558 | 540 | 467 | $in_url = grep { $_->get_class eq 'url' } @opened; | ||||
275 | 552 | ||||||
559 | |||||||
560 | 540 | 100 | 1091 | if ($after) { | |||
100 | |||||||
561 | # found start of a tag | ||||||
562 | #warn __PACKAGE__.':'.__LINE__.": find attribute for $tag\n"; | ||||||
563 | 373 | 776 | my ($ok, $attributes, $attr_string, $end) = $self->$parse_attributes( | ||||
564 | text => \$after, | ||||||
565 | tag => lc $tag, | ||||||
566 | ); | ||||||
567 | 373 | 100 | 657 | if ($ok) { | |||
568 | 367 | 270 | my $attr = $attr_string; | ||||
569 | 367 | 50 | 497 | $attr = '' unless defined $attr; | |||
570 | #warn __PACKAGE__.':'.__LINE__.": found attribute for $tag: $attr\n"; | ||||||
571 | 367 | 533 | my $close = $defs->{lc $tag}->{close}; | ||||
572 | 367 | 356 | my $def = $defs->{lc $tag}; | ||||
573 | my $open = $self->new_tag({ | ||||||
574 | name => lc $tag, | ||||||
575 | attr => $attributes, | ||||||
576 | attr_raw => $attr_string, | ||||||
577 | content => [], | ||||||
578 | start => "[$tag$attr]", | ||||||
579 | close => $close, | ||||||
580 | class => $defs->{lc $tag}->{class}, | ||||||
581 | single => $defs->{lc $tag}->{single}, | ||||||
582 | 367 | 2334 | in_url => $in_url, | ||||
583 | type => 'classic', | ||||||
584 | }); | ||||||
585 | 367 | 3638 | my $success = 1; | ||||
586 | 367 | 100 | 581 | my $nested_url = $in_url && $open->get_class eq 'url'; | |||
587 | { | ||||||
588 | 367 | 320 | my $last = $opened[-1]; | ||||
367 | 282 | ||||||
589 | 367 | 100 | 100 | 762 | if ($last and not $last->get_close and not $close) { | ||
100 | |||||||
590 | 34 | 213 | $self->_finish_tag($last, ''); | ||||
591 | # tag which should not have closing tag | ||||||
592 | 34 | 28 | pop @opened; | ||||
593 | 34 | 46 | $callback_found_tag->($last); | ||||
594 | } | ||||||
595 | } | ||||||
596 | 367 | 100 | 66 | 1218 | if ($open->get_single && !$nested_url) { | ||
100 | |||||||
597 | 3 | 17 | $self->_finish_tag($open, ''); | ||||
598 | 3 | 4 | $callback_found_tag->($open); | ||||
599 | } | ||||||
600 | elsif (!$nested_url) { | ||||||
601 | 363 | 1451 | push @opened, $open; | ||||
602 | 363 | 366 | my $def = $defs->{lc $tag}; | ||||
603 | #warn __PACKAGE__.':'.__LINE__.": $tag $def\n"; | ||||||
604 | 363 | 317 | my $parse = $def->{parse}; | ||||
605 | 363 | 100 | 373 | if ($parse) { | |||
606 | $current_open_re = join '|', map { | ||||||
607 | 319 | 309 | quotemeta $_->get_name | ||||
528 | 1128 | ||||||
608 | } @opened; | ||||||
609 | } | ||||||
610 | else { | ||||||
611 | #warn __PACKAGE__.':'.__LINE__.": noparse, find content\n"; | ||||||
612 | # just search for closing tag | ||||||
613 | 44 | 100 | 434 | if ($after =~ s# (.*?) (\[ / $tag \]) ##ixs) { | |||
614 | 39 | 68 | my $content = $1; | ||||
615 | 39 | 46 | my $end = $2; | ||||
616 | #warn __PACKAGE__.':'.__LINE__.": CONTENT $content\n"; | ||||||
617 | 39 | 40 | my $finished = pop @opened; | ||||
618 | 39 | 104 | $finished->set_content([$content]); | ||||
619 | 39 | 180 | $self->_finish_tag($finished, $end); | ||||
620 | 39 | 56 | $callback_found_tag->($finished); | ||||
621 | } | ||||||
622 | else { | ||||||
623 | #warn __PACKAGE__.':'.__LINE__.": nope '$after'\n"; | ||||||
624 | } | ||||||
625 | } | ||||||
626 | } | ||||||
627 | else { | ||||||
628 | 1 | 8 | $callback_found_text->($open->get_start); | ||||
629 | } | ||||||
630 | |||||||
631 | } | ||||||
632 | else { | ||||||
633 | # unclosed tag | ||||||
634 | 6 | 15 | $callback_found_text->("[$tag$attr_string$end"); | ||||
635 | } | ||||||
636 | } | ||||||
637 | elsif ($tag) { | ||||||
638 | #warn __PACKAGE__.':'.__LINE__.": end\n"; | ||||||
639 | 1 | 4 | $callback_found_text->("[$tag"); | ||||
640 | } | ||||||
641 | 540 | 2717 | $text = $after; | ||||
642 | #sleep 1; | ||||||
643 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']); | ||||||
644 | } | ||||||
645 | # warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']); | ||||||
646 | 199 | 100 | 361 | if ($self->get_close_open_tags) { | |||
647 | 8 | 34 | while (my $opened = pop @opened) { | ||||
648 | 11 | 38 | $self->_add_error('unclosed', $opened); | ||||
649 | 11 | 46 | $self->_finish_tag($opened, '[/' . $opened->get_name . ']', 1); | ||||
650 | 11 | 16 | $callback_found_tag->($opened); | ||||
651 | } | ||||||
652 | } | ||||||
653 | else { | ||||||
654 | 191 | 779 | while (my $opened = shift @opened) { | ||||
655 | 11 | 27 | my @text = $opened->_reduce; | ||||
656 | 11 | 55 | push @tags, @text; | ||||
657 | } | ||||||
658 | } | ||||||
659 | 199 | 50 | 258 | if ($scalar_util) { | |||
660 | 199 | 2129 | Scalar::Util::weaken($callback_found_tag); | ||||
661 | } | ||||||
662 | else { | ||||||
663 | # just to make sure no memleak if there's no Scalar::Util | ||||||
664 | 0 | 0 | undef $callback_found_tag; | ||||
665 | } | ||||||
666 | #warn __PACKAGE__.':'.__LINE__.": !!!!!!!!!!!! left text: '$text'\n"; | ||||||
667 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']); | ||||||
668 | 199 | 829 | my $tree = $self->new_tag({ | ||||
669 | name => '', | ||||||
670 | content => [@tags], | ||||||
671 | start => '', | ||||||
672 | class => 'block', | ||||||
673 | attr => [[]], | ||||||
674 | }); | ||||||
675 | 199 | 1813 | $tree->_init_info({}); | ||||
676 | 199 | 1008 | return $tree; | ||||
677 | } | ||||||
678 | |||||||
679 | sub new_tag { | ||||||
680 | 574 | 574 | 1 | 467 | my $self = shift; | ||
681 | 574 | 1280 | Parse::BBCode::Tag->new(@_) | ||||
682 | } | ||||||
683 | |||||||
684 | sub _add_error { | ||||||
685 | 27 | 27 | 30 | my ($self, $error, $tag) = @_; | |||
686 | 27 | 100 | 49 | my $errors = $self->get_error || {}; | |||
687 | 27 | 123 | push @{ $errors->{$error} }, $tag; | ||||
27 | 61 | ||||||
688 | 27 | 48 | $self->set_error($errors); | ||||
689 | } | ||||||
690 | |||||||
691 | sub error { | ||||||
692 | 11 | 11 | 1 | 3959 | my ($self, $type) = @_; | ||
693 | 11 | 100 | 47 | my $errors = $self->get_error || {}; | |||
694 | 11 | 100 | 33 | 84 | if ($type and $errors->{$type}) { | ||
100 | |||||||
695 | 3 | 5 | return $errors->{$type}; | ||||
696 | } | ||||||
697 | elsif (keys %$errors) { | ||||||
698 | 6 | 9 | return $errors; | ||||
699 | } | ||||||
700 | 2 | 5 | return 0; | ||||
701 | } | ||||||
702 | |||||||
703 | sub render { | ||||||
704 | 199 | 199 | 1 | 70035 | my ($self, $text, $params) = @_; | ||
705 | 199 | 100 | 412 | if (@_ < 2) { | |||
706 | 1 | 196 | croak ("Missing input - Usage: \$parser->render(\$text)"); | ||||
707 | } | ||||||
708 | #warn __PACKAGE__.':'.__LINE__.": @_\n"; | ||||||
709 | #sleep 2; | ||||||
710 | 198 | 325 | my $tree = $self->parse($text, $params); | ||||
711 | 198 | 308 | my $out = $self->render_tree($tree, $params); | ||||
712 | 198 | 100 | 320 | if ($self->get_error) { | |||
713 | 20 | 98 | $self->set_tree($tree); | ||||
714 | } | ||||||
715 | 198 | 1538 | return $out; | ||||
716 | } | ||||||
717 | |||||||
718 | sub render_tree { | ||||||
719 | 198 | 198 | 1 | 164 | my ($self, $tree, $params) = @_; | ||
720 | 198 | 100 | 534 | $params ||= {}; | |||
721 | 198 | 325 | $self->set_params($params); | ||||
722 | 198 | 725 | my $rendered = $self->_render_tree($tree); | ||||
723 | 198 | 340 | $self->set_params(undef); | ||||
724 | 198 | 755 | return $rendered; | ||||
725 | } | ||||||
726 | |||||||
727 | sub _render_tree { | ||||||
728 | 1102 | 1102 | 1064 | my ($self, $tree, $outer, $info) = @_; | |||
729 | 1102 | 769 | my $out = ''; | ||||
730 | 1102 | 100 | 1892 | $info ||= { | |||
731 | stack => [], | ||||||
732 | tags => {}, | ||||||
733 | classes => {}, | ||||||
734 | }; | ||||||
735 | 1102 | 1535 | my $defs = $self->get_tags; | ||||
736 | 1102 | 100 | 2847 | if (ref $tree) { | |||
737 | 540 | 717 | my $name = $tree->get_name; | ||||
738 | 540 | 1194 | my %tags = %{ $info->{tags} }; | ||||
540 | 1041 | ||||||
739 | 540 | 598 | $tags{$name}++; | ||||
740 | 540 | 330 | my @stack = @{ $info->{stack} }; | ||||
540 | 709 | ||||||
741 | 540 | 510 | push @stack, $name; | ||||
742 | 540 | 330 | my %classes = %{ $info->{classes} }; | ||||
540 | 705 | ||||||
743 | 540 | 50 | 772 | $classes{ $tree->get_class || '' }++; | |||
744 | 540 | 2496 | my %info = ( | ||||
745 | tags => \%tags, | ||||||
746 | stack => [@stack], | ||||||
747 | classes => \%classes, | ||||||
748 | ); | ||||||
749 | 540 | 597 | my $code = $defs->{$name}->{code}; | ||||
750 | 540 | 414 | my $parse = $defs->{$name}->{parse}; | ||||
751 | 540 | 50 | 772 | my $attr = $tree->get_attr || []; | |||
752 | 540 | 1652 | $attr = $attr->[0]->[0]; | ||||
753 | 540 | 719 | my $content = $tree->get_content; | ||||
754 | 540 | 1068 | my $fallback; | ||||
755 | 540 | 373 | my $string = ''; | ||||
756 | 540 | 100 | 100 | 689 | if (($tree->get_type || 'classic') eq 'classic') { | ||
757 | 533 | 100 | 100 | 2647 | $fallback = (defined $attr and length $attr) ? $attr : $content; | ||
758 | } | ||||||
759 | else { | ||||||
760 | 7 | 22 | $fallback = $attr; | ||||
761 | 7 | 100 | 10 | $string = @$content ? '' : $attr; | |||
762 | } | ||||||
763 | 540 | 100 | 828 | if (ref $fallback) { | |||
764 | # we have recursive content, we don't want that in | ||||||
765 | # an attribute | ||||||
766 | $fallback = join '', grep { | ||||||
767 | 432 | 452 | not ref $_ | ||||
742 | 1186 | ||||||
768 | } @$fallback; | ||||||
769 | } | ||||||
770 | 540 | 100 | 50 | 806 | if ($self->get_strip_linebreaks and ($tree->get_class || '') eq 'block') { | ||
100 | |||||||
771 | 321 | 100 | 100 | 3182 | if (@$content == 1 and not ref $content->[0] and defined $content->[0]) { | ||
100 | 66 | ||||||
772 | 89 | 125 | $content->[0] =~ s/^\r?\n//; | ||||
773 | 89 | 103 | $content->[0] =~ s/\r?\n\z//; | ||||
774 | } | ||||||
775 | elsif (@$content > 1) { | ||||||
776 | 192 | 100 | 66 | 466 | if (not ref $content->[0] and defined $content->[0]) { | ||
777 | 60 | 92 | $content->[0] =~ s/^\r?\n//; | ||||
778 | } | ||||||
779 | 192 | 100 | 66 | 561 | if (not ref $content->[-1] and defined $content->[-1]) { | ||
780 | 166 | 210 | $content->[-1] =~ s/\r?\n\z//; | ||||
781 | } | ||||||
782 | } | ||||||
783 | } | ||||||
784 | 540 | 100 | 100 | 2624 | if (not exists $defs->{$name}->{parse} or $parse) { | ||
785 | 500 | 500 | for my $c (@$content) { | ||||
786 | 890 | 1315 | $string .= $self->_render_tree($c, $tree, \%info); | ||||
787 | } | ||||||
788 | } | ||||||
789 | else { | ||||||
790 | 40 | 57 | $string = join '', @$content; | ||||
791 | } | ||||||
792 | 540 | 100 | 609 | if ($code) { | |||
793 | 342 | 543 | my $o = $code->($self, $attr, \$string, $fallback, $tree, \%info); | ||||
794 | 342 | 1061 | $out .= $o; | ||||
795 | } | ||||||
796 | else { | ||||||
797 | 198 | 465 | $out .= $string; | ||||
798 | } | ||||||
799 | } | ||||||
800 | else { | ||||||
801 | #warn __PACKAGE__.':'.__LINE__.": ==== $tree\n"; | ||||||
802 | 562 | 705 | $out .= $self->_render_text($outer, $tree, $info); | ||||
803 | } | ||||||
804 | 1102 | 1865 | return $out; | ||||
805 | } | ||||||
806 | |||||||
807 | |||||||
808 | sub escape_html { | ||||||
809 | 534 | 534 | 1 | 656 | my ($str) = @_; | ||
810 | 534 | 100 | 704 | return '' unless defined $str; | |||
811 | 530 | 478 | $str =~ s/&/&/g; | ||||
812 | 530 | 355 | $str =~ s/"/"/g; | ||||
813 | 530 | 379 | $str =~ s/'/'/g; | ||||
814 | 530 | 378 | $str =~ s/>/>/g; | ||||
815 | 530 | 363 | $str =~ s/</g; | ||||
816 | 530 | 739 | return $str; | ||||
817 | } | ||||||
818 | |||||||
819 | sub parse_attributes { | ||||||
820 | 369 | 369 | 1 | 728 | my ($self, %args) = @_; | ||
821 | 369 | 327 | my $text = $args{text}; | ||||
822 | 369 | 263 | my $tagname = $args{tag}; | ||||
823 | 369 | 648 | my $attribute_quote = $self->get_attribute_quote; | ||||
824 | 369 | 987 | my $attr_string = ''; | ||||
825 | 369 | 358 | my $attributes = []; | ||||
826 | 369 | 100 | 100 | 540 | if ( | ||
100 | |||||||
827 | ($self->get_direct_attribute and $$text =~ s/^(=[^\]]*)?]//) | ||||||
828 | or | ||||||
829 | ($$text =~ s/^( [^\]]*)?\]//) | ||||||
830 | ) { | ||||||
831 | 365 | 3115 | my $attr = $1; | ||||
832 | 365 | 272 | my $end = ']'; | ||||
833 | 365 | 100 | 552 | $attr = '' unless defined $attr; | |||
834 | 365 | 280 | $attr_string = $attr; | ||||
835 | 365 | 100 | 463 | unless (length $attr) { | |||
836 | 260 | 981 | return (1, [], $attr_string, $end); | ||||
837 | } | ||||||
838 | 105 | 100 | 168 | if ($self->get_direct_attribute) { | |||
839 | 104 | 441 | $attr =~ s/^=//; | ||||
840 | } | ||||||
841 | 105 | 100 | 100 | 197 | if ($self->get_strict_attributes and not length $attr) { | ||
842 | 1 | 8 | return (0, [], $attr_string, $end); | ||||
843 | } | ||||||
844 | 104 | 503 | my @array; | ||||
845 | 104 | 100 | 137 | if (length($attribute_quote) == 1) { | |||
846 | 103 | 50 | 774 | if ($attr =~ s/^(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) { | |||
847 | 103 | 100 | 207 | my $val = defined $1 ? $1 : $2; | |||
848 | 103 | 157 | push @array, [$val]; | ||||
849 | } | ||||||
850 | 103 | 607 | while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) { | ||||
851 | 9 | 14 | my $name = $1; | ||||
852 | 9 | 100 | 20 | my $val = defined $2 ? $2 : $3; | |||
853 | 9 | 45 | push @array, [$name, $val]; | ||||
854 | } | ||||||
855 | } | ||||||
856 | else { | ||||||
857 | 1 | 50 | 6 | if ($attr =~ s/^(?:(["'])(.+?)\1|(.*?)(?:\s+|$))//) { | |||
858 | 1 | 50 | 4 | my $val = defined $2 ? $2 : $3; | |||
859 | 1 | 2 | push @array, [$val]; | ||||
860 | } | ||||||
861 | 1 | 5 | while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:(["'])(.+?)\2|(.*?)(?:\s+|$))//) { | ||||
862 | 1 | 2 | my $name = $1; | ||||
863 | 1 | 50 | 3 | my $val = defined $3 ? $3 : $4; | |||
864 | 1 | 4 | push @array, [$name, $val]; | ||||
865 | } | ||||||
866 | } | ||||||
867 | 104 | 100 | 100 | 184 | if ($self->get_strict_attributes and length $attr and $attr =~ tr/ //c) { | ||
66 | |||||||
868 | 1 | 12 | return (0, [], $attr_string, $end); | ||||
869 | } | ||||||
870 | 103 | 559 | $attributes = [@array]; | ||||
871 | 103 | 307 | return (1, $attributes, $attr_string, $end); | ||||
872 | } | ||||||
873 | 4 | 51 | return (0, $attributes, $attr_string, ''); | ||||
874 | } | ||||||
875 | |||||||
876 | # TODO add callbacks | ||||||
877 | sub _finish_tag { | ||||||
878 | 342 | 342 | 384 | my ($self, $tag, $end, $auto_closed) = @_; | |||
879 | #warn __PACKAGE__.':'.__LINE__.": _finish_tag(@_)\n"; | ||||||
880 | #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']); | ||||||
881 | 342 | 50 | 470 | unless ($tag->get_finished) { | |||
882 | 342 | 1164 | $tag->set_end($end); | ||||
883 | 342 | 1359 | $tag->set_finished(1); | ||||
884 | 342 | 100 | 1697 | $tag->set_auto_closed($auto_closed || 0); | |||
885 | } | ||||||
886 | 342 | 1037 | return 1; | ||||
887 | } | ||||||
888 | |||||||
889 | __END__ |