File Coverage

blib/lib/XML/Filter/DetectWS.pm
Criterion Covered Total %
statement 9 193 4.6
branch 0 76 0.0
condition 0 12 0.0
subroutine 3 42 7.1
pod 3 37 8.1
total 15 360 4.1


line stmt bran cond sub pod time code
1             package XML::Filter::DetectWS;
2 1     1   12512 use strict;
  1         3  
  1         55  
3 1     1   1470 use XML::Filter::SAXT;
  1         2597  
  1         46  
4              
5 1     1   9 use vars qw($VERSION);
  1         10  
  1         4130  
6             $VERSION = '0.01';
7              
8             #----------------------------------------------------------------------
9             # CONSTANT DEFINITIONS
10             #----------------------------------------------------------------------
11              
12             # Locations of whitespace
13 0     0 1   sub WS_START (%) { 1 } # just after
14 0     0 1   sub WS_END (%) { 2 } # just before
15 0     0 0   sub WS_INTER (%) { 0 } # not at the start or end (i.e. intermediate)
16 0     0 0   sub WS_ONLY (%) { 3 } # both START and END, i.e. between and
17              
18             # The states of the WhiteSpace detection code
19             # for regular elements, i.e. elements that:
20             # 1) don't have xml:space="preserve"
21             # 2) have an ELEMENT model that allows text children (i.e. ANY or Mixed content)
22              
23 0     0 0   sub START (%) { 0 } # just saw
24 0     0 0   sub ONLY_WS (%) { 1 } # saw followed by whitespace (only)
25 0     0 0   sub ENDS_IN_WS (%) { 2 } # ends in whitespace (sofar)
26 0     0 0   sub ENDS_IN_NON_WS (%) { 3 } # ends in non-ws text or non-text node (sofar)
27              
28             # NO_TEXT States: when model does not allow text
29             # (we assume that all text children are whitespace)
30 0     0 0   sub NO_TEXT_START (%) { 4 } # just saw
31 0     0 0   sub NO_TEXT_ONLY_WS (%) { 5 } # saw followed by whitespace (only)
32 0     0 0   sub NO_TEXT_ENDS_IN_WS (%) { 6 } # ends in whitespace (sofar)
33 0     0 0   sub NO_TEXT_ENDS_IN_NON_WS (%) { 7 } # ends in non-text node (sofar)
34              
35             # State for elements with xml:space="preserve" (all text is non-WS)
36 0     0 0   sub PRESERVE_WS (%) { 8 }
37              
38             #----------------------------------------------------------------------
39             # METHOD DEFINITIONS
40             #----------------------------------------------------------------------
41              
42             # Constructor options:
43             #
44             # SkipIgnorableWS 1 means: don't forward ignorable_whitespace events
45             # Handler SAX Handler that will receive the resulting events
46             #
47              
48             sub new
49             {
50 0     0 0   my ($class, %options) = @_;
51              
52 0           my $self = bless \%options, $class;
53              
54 0           $self->init_handlers;
55              
56 0           $self;
57             }
58              
59             # Does nothing
60 0     0 0   sub noop {}
61              
62             sub init_handlers
63             {
64 0     0 0   my ($self) = @_;
65 0           my %handlers;
66            
67 0           my $handler = $self->{Handler};
68            
69 0           for my $cb (map { @{$_} } values %XML::Filter::SAXT::SAX_HANDLERS)
  0            
  0            
70             {
71 0 0         if (UNIVERSAL::can ($handler, $cb))
72             {
73 0           $handlers{$cb} = eval "sub { \$handler->$cb (\@_) }";
74             }
75             else
76             {
77 0           $handlers{$cb} = \&noop;
78             }
79             }
80              
81 0 0         if ($self->{SkipIgnorableWS})
    0          
82             {
83 0           delete $handlers{ignorable_whitespace}; # if it exists
84             }
85             elsif (UNIVERSAL::can ($handler, 'ignorable_whitespace'))
86             {
87             # Support ignorable_whitespace callback if it exists
88             # (if not, just use characters callback)
89             $handlers{ignorable_whitespace} =
90 0     0     sub { $handler->ignorable_whitespace (@_) };
  0            
91             }
92             else
93             {
94 0           $handlers{ignorable_whitespace} = $handlers{characters};
95             }
96              
97 0           $handlers{ws} = $handlers{characters};
98             #?? were should whitespace go?
99              
100             # NOTE: 'cdata' is not a valid PerlSAX callback
101 0 0 0       if (UNIVERSAL::can ($handler, 'start_cdata') &&
102             UNIVERSAL::can ($handler, 'end_cdata'))
103             {
104             $handlers{cdata} = sub {
105 0     0     $handler->start_cdata;
106 0           $handler->characters (@_);
107 0           $handler->end_cdata;
108             }
109 0           }
110             else # pass CDATA as regular characters
111             {
112 0           $handlers{cdata} = $handlers{characters};
113             }
114              
115 0           $self->{Callback} = \%handlers;
116             }
117              
118             sub start_cdata
119             {
120 0     0 0   my ($self, $event) = @_;
121              
122 0           $self->{InCDATA} = 1;
123             }
124              
125             sub end_cdata
126             {
127 0     0 0   my ($self, $event) = @_;
128              
129 0           $self->{InCDATA} = 0;
130             }
131              
132             sub entity_reference
133             {
134 0     0 0   my ($self, $event) = @_;
135            
136 0           $self->push_event ('entity_reference', $event);
137              
138 0           my $parent = $self->{ParentStack}->[-1];
139 0 0         $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;
140             }
141              
142             sub comment
143             {
144 0     0 1   my ($self, $event) = @_;
145            
146 0           $self->push_event ('comment', $event);
147              
148 0           my $parent = $self->{ParentStack}->[-1];
149 0 0         $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;
150             }
151              
152             sub processing_instruction
153             {
154 0     0 0   my ($self, $event) = @_;
155            
156 0           $self->push_event ('processing_instruction', $event);
157              
158 0           my $parent = $self->{ParentStack}->[-1];
159 0 0         $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;
160             }
161              
162             sub start_document
163             {
164 0     0 0   my ($self, $event) = @_;
165              
166             # Initialize initial state
167 0           $self->{ParentStack} = [];
168 0           $self->{EventQ} = [];
169 0           $self->{InCDATA} = 0;
170              
171 0           $self->init_handlers;
172              
173 0 0         $event = {} unless defined $event;
174             # Don't preserve WS by default (unless specified by the user)
175 0 0         $event->{PreserveWS} = defined ($self->{PreserveWS}) ?
176             $self->{PreserveWS} : 0;
177              
178             # We don't need whitespace detection at the document level
179 0           $event->{State} = PRESERVE_WS;
180              
181 0           $self->push_event ('start_document', $event);
182 0           push @{ $self->{ParentStack} }, $event;
  0            
183             }
184              
185             sub end_document
186             {
187 0     0 0   my ($self, $event) = @_;
188 0 0         $event = {} unless defined $event;
189              
190 0           $self->push_event ('end_document', $event);
191              
192 0           $self->flush;
193             }
194              
195             sub start_element
196             {
197 0     0 0   my ($self, $event) = @_;
198              
199 0           my $pres = $event->{Attributes}->{'xml:space'};
200 0 0         if (defined $pres)
201             {
202 0           $event->{PreserveWS} = $pres eq "preserve";
203             }
204             else
205             {
206 0           $event->{PreserveWS} = $self->{ParentStack}->[-1]->{PreserveWS};
207             }
208              
209 0 0         if ($self->{NoText}->{ $event->{Name} })
210             {
211 0           $event->{NoText} = 1;
212             }
213              
214 0           $event->{State} = $self->get_init_state ($event);
215              
216 0           $self->push_event ('start_element', $event);
217 0           push @{ $self->{ParentStack} }, $event;
  0            
218             }
219              
220             sub end_element
221             {
222 0     0 0   my ($self, $event) = @_;
223              
224             # Mark previous whitespace event as the last event (WS_END)
225             # (if it's there)
226 0           my $prev = $self->{EventQ}->[-1];
227 0 0         $prev->{Loc} |= WS_END if exists $prev->{Loc};
228              
229 0           $self->push_event ('end_element', $event);
230            
231 0           my $elem = pop @{ $self->{ParentStack} };
  0            
232 0           delete $elem->{State};
233             }
234              
235             sub characters
236             {
237 0     0 0   my ($self, $event) = @_;
238              
239 0 0         if ($self->{InCDATA})
240             {
241             # NOTE: 'cdata' is not a valid PerlSAX callback
242 0           $self->push_event ('cdata', $event);
243            
244 0           my $parent = $self->{ParentStack}->[-1];
245 0 0         $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;
246 0           return;
247             }
248              
249 0           my $text = $event->{Data};
250 0 0         return unless length ($text);
251              
252 0           my $state = $self->{ParentStack}->[-1]->{State};
253 0 0         if ($state == PRESERVE_WS)
    0          
    0          
    0          
    0          
    0          
    0          
254             {
255 0           $self->push_event ('characters', $event);
256             }
257             elsif ($state == NO_TEXT_START)
258             {
259             # ELEMENT model does not allow regular text.
260             # All characters are whitespace.
261 0           $self->push_event ('ignorable_whitespace', { Data => $text, Loc => WS_START });
262 0           $state = NO_TEXT_ONLY_WS;
263             }
264             elsif ($state == NO_TEXT_ONLY_WS)
265             {
266 0           $self->merge_text ($text, 'ignorable_whitespace', WS_START );
267             }
268             elsif ($state == NO_TEXT_ENDS_IN_NON_WS)
269             {
270 0           $self->push_event ('ignorable_whitespace', { Data => $text, Loc => WS_INTER });
271 0           $state = NO_TEXT_ENDS_IN_WS;
272             }
273             elsif ($state == NO_TEXT_ENDS_IN_WS)
274             {
275 0           $self->merge_text ($text, 'ignorable_whitespace', WS_INTER );
276             }
277             elsif ($state == START)
278             {
279             #?? add support for full Unicode
280 0           $text =~ /^(\s*)(\S(?:.*\S)?)?(\s*)$/;
281 0 0         if (length $1)
282             {
283 0           $self->push_event ('ws', { Data => $1, Loc => WS_START });
284 0           $state = ONLY_WS;
285             }
286 0 0         if (length $2)
287             {
288 0           $self->push_event ('characters', { Data => $2 });
289 0           $state = ENDS_IN_NON_WS;
290             }
291 0 0         if (length $3)
292             {
293 0           $self->push_event ('ws', { Data => $3, Loc => WS_INTER });
294 0           $state = ENDS_IN_WS;
295             }
296             }
297             elsif ($state == ONLY_WS)
298             {
299 0           $text =~ /^(\s*)(\S(?:.*\S)?)?(\s*)$/;
300 0 0         if (length $1)
301             {
302 0           $self->merge_text ($1, 'ws', WS_START);
303             }
304 0 0         if (length $2)
305             {
306 0           $self->push_event ('characters', { Data => $2 });
307 0           $state = ENDS_IN_NON_WS;
308             }
309 0 0         if (length $3)
310             {
311 0           $self->push_event ('ws', { Data => $3, Loc => WS_INTER });
312 0           $state = ENDS_IN_WS;
313             }
314             }
315             else # state == ENDS_IN_WS or ENDS_IN_NON_WS
316             {
317 0           $text =~ /^(.*\S)?(\s*)$/;
318 0 0         if (length $1)
319             {
320 0 0         if ($state == ENDS_IN_NON_WS)
321             {
322 0           $self->merge_text ($1, 'characters');
323             }
324             else
325             {
326 0           $self->push_event ('characters', { Data => $1 });
327 0           $state = ENDS_IN_NON_WS;
328             }
329             }
330 0 0         if (length $2)
331             {
332 0 0         if ($state == ENDS_IN_WS)
333             {
334 0           $self->merge_text ($2, 'ws', WS_INTER);
335             }
336             else
337             {
338 0           $self->push_event ('ws', { Data => $2, Loc => WS_INTER });
339 0           $state = ENDS_IN_WS;
340             }
341             }
342             }
343              
344 0           $self->{ParentStack}->[-1]->{State} = $state;
345             }
346              
347             sub element_decl
348             {
349 0     0 0   my ($self, $event) = @_;
350 0           my $tag = $event->{Name};
351 0           my $model = $event->{Model};
352              
353             # Check the model to see if the elements may contain regular text
354 0   0       $self->{NoText}->{$tag} = ($model eq 'EMPTY' || $model !~ /\#PCDATA/);
355              
356 0           $self->push_event ('element_decl', $event);
357             }
358              
359             sub attlist_decl
360             {
361 0     0 0   my ($self, $event) = @_;
362            
363 0           my $prev = $self->{EventQ}->[-1];
364 0 0 0       if ($prev->{EventType} eq 'attlist_decl' &&
365             $prev->{ElementName} eq $event->{ElementName})
366             {
367 0           $prev->{MoreFollow} = 1;
368 0           $event->{First} = 0;
369             }
370             else
371             {
372 0           $event->{First} = 1;
373             }
374              
375 0           $self->push_event ('attlist_decl', $event);
376             }
377              
378             sub notation_decl
379             {
380 0     0 0   my ($self, $event) = @_;
381 0           $self->push_event ('notation_decl', $event);
382             }
383              
384             sub unparsed_entity_decl
385             {
386 0     0 0   my ($self, $event) = @_;
387 0           $self->push_event ('unparsed_entity_decl', $event);
388             }
389              
390             sub entity_decl
391             {
392 0     0 0   my ($self, $event) = @_;
393 0           $self->push_event ('entity_decl', $event);
394             }
395              
396             sub doctype_decl
397             {
398 0     0 0   my ($self, $event) = @_;
399 0           $self->push_event ('doctype_decl', $event);
400             }
401              
402             sub xml_decl
403             {
404 0     0 0   my ($self, $event) = @_;
405 0           $self->push_event ('xml_decl', $event);
406             }
407              
408             #?? what about set_document_locator, resolve_entity
409              
410             #
411             # Determine the initial State for the current Element.
412             # By default, we look at the PreserveWS property (i.e. value of xml:space.)
413             # The user can override this to force xml:space="preserve" for a particular
414             # element with e.g.
415             #
416             # sub get_init_state
417             # {
418             # my ($self, $event) = @_;
419             # ($event->{Name} eq 'foo' || $event->{PreserveWS}) ? PRESERVE_WS : START;
420             # }
421             #
422             sub get_init_state
423             {
424 0     0 0   my ($self, $event) = @_;
425 0           my $tag = $event->{Name};
426              
427 0 0         if ($self->{NoText}->{$tag}) # ELEMENT model does not allow text
428             {
429 0           return NO_TEXT_START;
430             }
431 0 0         $event->{PreserveWS} ? PRESERVE_WS : START;
432             }
433              
434             sub push_event
435             {
436 0     0 0   my ($self, $type, $event) = @_;
437              
438 0           $event->{EventType} = $type;
439              
440 0           $self->flush;
441 0           push @{ $self->{EventQ} }, $event;
  0            
442             }
443              
444             # Merge text with previous event (if it has the same EventType)
445             # or push a new text event
446             sub merge_text
447             {
448 0     0 0   my ($self, $str, $eventType, $wsLocation) = @_;
449 0           my $q = $self->{EventQ};
450              
451 0           my $prev = $q->[-1];
452 0 0 0       if (defined $prev && $prev->{EventType} eq $eventType)
453             {
454 0           $prev->{Data} .= $str;
455             }
456             else
457             {
458 0           my $event = { Data => $str };
459 0 0         $event->{Loc} = $wsLocation if defined $wsLocation;
460 0           $self->push_event ($eventType, $event);
461             }
462             }
463              
464             # Forward all events on the EventQ
465             sub flush
466             {
467 0     0 0   my ($self) = @_;
468              
469 0           my $q = $self->{EventQ};
470 0           while (@$q)
471             {
472 0           my $event = shift @$q;
473 0           my $type = $event->{EventType};
474 0           delete $event->{EventType};
475              
476 0           $self->{Callback}->{$type}->($event);
477             }
478             }
479              
480             1; # package return code
481              
482             __END__