File Coverage

blib/lib/XML/Grammar/FictionBase/FromProto/Parser/XmlIterator.pm
Criterion Covered Total %
statement 70 323 21.6
branch 5 80 6.2
condition 0 9 0.0
subroutine 20 78 25.6
pod 1 1 100.0
total 96 491 19.5


line stmt bran cond sub pod time code
1             package XML::Grammar::FictionBase::FromProto::Parser::XmlIterator;
2              
3 2     2   776 use strict;
  2         4  
  2         58  
4 2     2   10 use warnings;
  2         3  
  2         39  
5              
6 2     2   17 use Carp ();
  2         3  
  2         30  
7              
8 2     2   8 use MooX 'late';
  2         10  
  2         8  
9              
10 2     2   2214 use XML::Grammar::Fiction::Err;
  2         4  
  2         41  
11 2     2   11 use XML::Grammar::Fiction::Struct::Tag;
  2         4  
  2         31  
12 2     2   8 use XML::Grammar::FictionBase::Event;
  2         4  
  2         37  
13              
14 2     2   554 use XML::Grammar::Fiction::FromProto::Node::WithContent;
  2         5  
  2         70  
15 2     2   510 use XML::Grammar::Fiction::FromProto::Node::Element;
  2         6  
  2         57  
16 2     2   516 use XML::Grammar::Fiction::FromProto::Node::List;
  2         5  
  2         50  
17 2     2   528 use XML::Grammar::Fiction::FromProto::Node::Text;
  2         5  
  2         47  
18 2     2   485 use XML::Grammar::Fiction::FromProto::Node::Saying;
  2         5  
  2         51  
19 2     2   545 use XML::Grammar::Fiction::FromProto::Node::Description;
  2         6  
  2         47  
20 2     2   490 use XML::Grammar::Fiction::FromProto::Node::Paragraph;
  2         19  
  2         56  
21 2     2   508 use XML::Grammar::Fiction::FromProto::Node::InnerDesc;
  2         5  
  2         48  
22 2     2   491 use XML::Grammar::Fiction::FromProto::Node::Comment;
  2         5  
  2         5033  
23              
24             extends("XML::Grammar::FictionBase::FromProto::Parser::LineIterator");
25              
26             has "_tags_stack" =>
27             (
28             isa => "ArrayRef",
29             is => "rw",
30             default => sub { [] },
31             );
32              
33              
34             sub _get_tag
35             {
36 0     0   0 my ($self, $idx) = @_;
37              
38 0         0 return $self->_tags_stack->[$idx];
39             }
40              
41             sub _tags_stack_is_empty
42             {
43 0     0   0 my $self = shift;
44              
45 0         0 return (! @{$self->_tags_stack});
  0         0  
46             }
47              
48             sub _grep_tags_stack
49             {
50 0     0   0 my $self = shift;
51 0         0 my $cb = shift;
52              
53 0         0 return grep { $cb->($_) } @{$self->_tags_stack};
  0         0  
  0         0  
54             }
55              
56             sub _push_tag
57             {
58 0     0   0 my $self = shift;
59              
60 0         0 push( @{$self->_tags_stack}, @_);
  0         0  
61              
62 0         0 return;
63             }
64              
65             sub _pop_tag
66             {
67 0     0   0 my $self = shift;
68              
69 0         0 return pop(@{$self->_tags_stack});
  0         0  
70             }
71              
72             has "_events_queue" =>
73             (
74             isa => "ArrayRef",
75             # isa => "ArrayRef",
76             is => "rw",
77             default => sub { []; },
78             );
79              
80              
81             sub _clear_events
82             {
83 0     0   0 my $self = shift;
84              
85 0         0 $self->_events_queue([]);
86              
87 0         0 return;
88             }
89              
90             sub _no_events
91             {
92 0     0   0 my $self = shift;
93              
94 0         0 return (! @{$self->_events_queue});
  0         0  
95             }
96              
97             sub _enqueue_event
98             {
99 0     0   0 my $self = shift;
100 0         0 my $event = shift;
101              
102 0 0       0 if (@_) {
103 0         0 Carp::confess("More than one argument.");
104             }
105              
106 0         0 push( @{$self->_events_queue}, $event);
  0         0  
107              
108 0         0 return;
109             }
110              
111             sub _extract_event
112             {
113 0     0   0 my $self = shift;
114              
115 0         0 return shift(@{$self->_events_queue});
  0         0  
116             }
117              
118             has '_ret_tag' =>
119             (
120             is => "rw",
121             # TODO : add isa.
122             predicate => "_has_ret_tag",
123             clearer => "_clear_ret_tag",
124             );
125              
126             # Whether we are inside a paragraph or not.
127             has "_in_para" => (isa => "Bool", is => "rw", default => 0,);
128              
129             has '_tag_names_to_be_handled' =>
130             (
131             is => 'ro',
132             isa => 'HashRef[Bool]',
133             lazy => 1,
134             builder => '_build_tag_names_to_be_handled',
135             );
136              
137             sub _build_tag_names_to_be_handled
138             {
139 0     0   0 my $self = shift;
140              
141 0         0 return { map { $_ => 1 } @{$self->_list_valid_tag_events} };
  0         0  
  0         0  
142             }
143              
144             sub _get_id_regex
145             {
146 4     4   12 return qr{[a-zA-Z_\-]+};
147             }
148              
149             sub _top_tag
150             {
151 0     0   0 my $self = shift;
152 0         0 return $self->_get_tag(-1);
153             }
154              
155             sub _add_to_top_tag
156             {
157 0     0   0 my ($self, $child) = @_;
158              
159 0         0 $self->_top_tag->append_child($child);
160              
161 0         0 return;
162             }
163              
164             # TODO : Maybe move to a different sub-class or role.
165             sub _new_empty_list
166             {
167 0     0   0 my $self = shift;
168 0         0 return $self->_new_list([]);
169             }
170              
171             sub _new_node
172             {
173 0     0   0 my $self = shift;
174 0         0 my $args = shift;
175              
176             # t == type
177             my $class =
178             "XML::Grammar::Fiction::FromProto::Node::"
179 0         0 . delete($args->{'t'})
180             ;
181              
182 0         0 return $class->new(%$args);
183             }
184              
185              
186             sub _create_elem
187             {
188 0     0   0 my $self = shift;
189 0         0 my $open = shift;
190              
191 0 0       0 my $children = @_ ? shift(@_) : $self->_new_empty_list();
192              
193             return
194 0 0       0 $self->_new_node(
    0          
195             {
196             t => (
197             $open->name() eq "desc" ? "Description"
198             : $open->name() eq "innerdesc" ? "InnerDesc"
199             : "Element"
200             ),
201             name => $open->name(),
202             children => $children,
203             attrs => $open->attrs(),
204             open_line => $open->line(),
205             }
206             );
207             }
208              
209             sub _new_list
210             {
211 0     0   0 my $self = shift;
212 0         0 my $contents = shift;
213              
214 0         0 return $self->_new_node(
215             {
216             t => "List",
217             contents => $contents,
218             }
219             );
220             }
221              
222             sub _generic_para_contents_assert
223             {
224 0     0   0 my ($self, $predicate, $message, $contents) = @_;
225              
226 0 0   0   0 if (List::MoreUtils::any { $predicate->($_) } @{$contents || []})
  0 0       0  
  0         0  
227             {
228 0         0 Carp::confess ($message);
229             }
230              
231 0         0 return;
232             }
233              
234             sub _assert_not_contains_saying
235             {
236 0     0   0 my ($self, $contents) = @_;
237              
238             return $self->_generic_para_contents_assert(
239 0 0   0   0 sub { ref($_) ne "" && $_->isa("XML::Grammar::Fiction::FromProto::Node::Saying") },
240 0         0 qq{Para contains a saying.},
241             $contents
242             );
243             }
244              
245             sub _assert_not_contains_undef
246             {
247 0     0   0 my ($self, $contents) = @_;
248              
249             return $self->_generic_para_contents_assert(
250 0     0   0 sub { !defined($_) },
251 0         0 qq{Para contains an undef member.},
252             $contents
253             );
254             }
255              
256             sub _new_para
257             {
258 0     0   0 my ($self, $contents) = @_;
259              
260 0         0 $self->_assert_not_contains_saying($contents);
261 0         0 $self->_assert_not_contains_undef($contents);
262              
263 0         0 return $self->_new_node(
264             {
265             t => "Paragraph",
266             children => $self->_new_list($contents),
267             }
268             );
269             }
270              
271             sub _new_text
272             {
273 0     0   0 my $self = shift;
274 0         0 my $contents = shift;
275              
276 0         0 return $self->_new_node(
277             {
278             t => "Text",
279             children => $self->_new_list($contents),
280             }
281             );
282             }
283              
284             sub _new_comment
285             {
286 0     0   0 my $self = shift;
287 0         0 my $text = shift;
288              
289 0         0 return $self->_new_node(
290             {
291             t => "Comment",
292             text => $text,
293             }
294             );
295             }
296              
297             sub _parse_opening_tag_attrs
298             {
299 2     2   5 my $self = shift;
300              
301 2         6 my $l = $self->curr_line_ref();
302              
303 2         38 my @attrs;
304              
305 2         6 my $id_regex = $self->_get_id_regex();
306              
307 2         54 while ($$l =~ m{\G\s*($id_regex)="([^"]+)"\s*}cg)
308             {
309 2         17 push @attrs, { 'key' => $1, 'value' => $2, };
310             }
311              
312 2         6 return \@attrs;
313             }
314              
315             sub _opening_tag_asserts
316             {
317 2     2   4 my $self = shift;
318              
319 2 50       8 if ($self->eof)
320             {
321 0         0 Carp::confess (qq{Reached EOF in _parse_opening_tag.});
322             }
323              
324 2 50       46 if (!defined($self->curr_pos()))
325             {
326 0         0 Carp::confess (qq{curr_pos is not defined in _parse_opening_tag.});
327             }
328              
329 2         41 return;
330             }
331              
332             sub _parse_opening_tag
333             {
334 2     2   29 my $self = shift;
335              
336 2         11 $self->_opening_tag_asserts;
337              
338 2         6 my $l = $self->curr_line_ref();
339              
340 2         43 my $id_regex = $self->_get_id_regex();
341              
342 2 50       44 if ($$l !~ m{\G<($id_regex)}cg)
343             {
344 0         0 $self->throw_text_error(
345             'XML::Grammar::Fiction::Err::Parse::CannotMatchOpeningTag',
346             "Cannot match opening tag.",
347             );
348             }
349              
350 2         6 my $id = $1;
351              
352 2         10 my $attrs = $self->_parse_opening_tag_attrs();
353              
354 2         5 my $is_standalone = 0;
355 2 50       21 if ($$l =~ m{\G\s*/\s*>}cg)
    50          
356             {
357 0         0 $is_standalone = 1;
358             }
359             elsif ($$l !~ m{\G>}g)
360             {
361 0         0 $self->throw_text_error(
362             'XML::Grammar::Fiction::Err::Parse::NoRightAngleBracket',
363             "Cannot match the \">\" of the opening tag",
364             );
365             }
366              
367 2         14 return XML::Grammar::Fiction::Struct::Tag->new(
368             name => $id,
369             is_standalone => $is_standalone,
370             line => $self->line_num(),
371             attrs => $attrs,
372             );
373             }
374              
375             sub _parse_closing_tag
376             {
377 0     0     my $self = shift;
378              
379 0           my $l = $self->curr_line_ref();
380              
381 0           my $id_regex = $self->_get_id_regex();
382              
383 0 0         if ($$l !~ m{\G}g)
384             {
385 0           $self->throw_text_error(
386             'XML::Grammar::Fiction::Err::Parse::WrongClosingTagSyntax',
387             "Cannot match closing tag",
388             );
389             }
390              
391 0           return XML::Grammar::Fiction::Struct::Tag->new(
392             name => $1,
393             line => $self->line_num(),
394             );
395             }
396              
397             sub _check_for_open_tag
398             {
399 0     0     my $self = shift;
400              
401 0 0         if ($self->_tags_stack_is_empty())
402             {
403 0           $self->throw_text_error(
404             'XML::Grammar::Fiction::Err::Parse::CannotMatchOpeningTag',
405             "Cannot match opening tag.",
406             );
407             }
408              
409 0           return;
410             }
411              
412             sub _is_event_a_saying
413             {
414 0     0     my ($self, $event) = @_;
415              
416 0           return $event->is_tag_of_name("saying");
417             }
418              
419             sub _is_event_a_para
420             {
421 0     0     my ($self, $event) = @_;
422              
423 0           return $event->is_tag_of_name("para");
424             }
425              
426             sub _is_event_elem
427             {
428 0     0     my ($self, $event) = @_;
429              
430 0           return $event->type() eq "elem";
431             }
432              
433             sub _handle_event
434             {
435 0     0     my ($self, $event) = @_;
436              
437 0 0 0       if ((! $self->_check_and_handle_tag_event($event))
438             && $self->_is_event_elem($event)
439             )
440             {
441 0           $self->_handle_elem_event($event);
442             }
443              
444 0           return;
445             }
446              
447             sub _handle_specific_tag_event
448             {
449 0     0     my ($self, $event) = @_;
450              
451 0           my $tag_name = $event->tag();
452 0 0         my $type = $event->is_open() ? "open" : "close";
453              
454 0           my $method = "_handle_${type}_${tag_name}";
455              
456 0           $self->$method($event);
457              
458 0           return 1;
459             }
460              
461             sub _check_and_handle_tag_event
462             {
463 0     0     my ($self, $event) = @_;
464              
465 0 0 0       if ($event->tag && exists($self->_tag_names_to_be_handled->{$event->tag}))
466             {
467 0           return $self->_handle_specific_tag_event($event);
468             }
469             else
470             {
471 0           return;
472             }
473             }
474              
475             sub _handle_para_event
476             {
477 0     0     my ($self, $event) = @_;
478              
479             return
480 0 0         $event->is_open()
481             ? $self->_handle_open_para($event)
482             : $self->_handle_close_para($event)
483             ;
484             }
485              
486             sub _handle_elem_event
487             {
488 0     0     my ($self, $event) = @_;
489              
490 0           $self->_add_to_top_tag( $event->elem());
491              
492 0           return;
493             }
494              
495             sub _handle_non_tag_text
496             {
497 0     0     my $self = shift;
498              
499 0           $self->_check_for_open_tag();
500              
501 0           my $contents = $self->_parse_text();
502              
503 0           foreach my $event (@$contents)
504             {
505 0           $self->_handle_event($event);
506             }
507              
508 0           return;
509             }
510              
511              
512             sub _look_for_and_handle_tag
513             {
514 0     0     my $self = shift;
515              
516 0           my ($is_tag_cond, $is_close) = $self->_look_ahead_for_tag();
517              
518             # Check if it's a closing tag.
519 0 0         if ($is_close)
    0          
520             {
521 0           return $self->_handle_close_tag();
522             }
523             elsif ($is_tag_cond)
524             {
525 0           $self->_handle_open_tag();
526             }
527             else
528             {
529 0           $self->_handle_non_tag_text();
530             }
531 0           return;
532             }
533              
534             sub _merge_tag
535             {
536 0     0     my $self = shift;
537 0           my $open_tag = shift;
538              
539 0           my $new_elem =
540             $self->_create_elem(
541             $open_tag,
542             $self->_new_list($open_tag->detach_children()),
543             );
544              
545 0 0         if (! $self->_tags_stack_is_empty())
546             {
547 0           $self->_add_to_top_tag($new_elem);
548 0           return;
549             }
550             else
551             {
552 0           return $new_elem;
553             }
554             }
555              
556             sub _handle_close_tag
557             {
558 0     0     my $self = shift;
559              
560 0           my $close = $self->_parse_closing_tag();
561              
562 0           my $open = $self->_pop_tag();
563              
564 0 0         if ($open->name() ne $close->name())
565             {
566 0           XML::Grammar::Fiction::Err::Parse::TagsMismatch->throw(
567             error => "Tags do not match",
568             opening_tag => $open,
569             closing_tag => $close,
570             );
571             }
572              
573 0           return $self->_merge_tag($open);
574             }
575              
576             sub _look_ahead_for_comment
577             {
578 0     0     my $self = shift;
579              
580 0 0         if ($self->curr_line_continues_with(qr{});
583              
584 0           $self->_add_to_top_tag(
585             $self->_new_comment($text),
586             );
587              
588 0           return 1;
589             }
590             else
591             {
592 0           return;
593             }
594             }
595              
596             sub _decode_entities_in_text
597             {
598 0     0     my ($self, $orig_text) = @_;
599              
600 0           my $ret = '';
601              
602             # Incrementally parse $text for entities.
603 0           pos($orig_text) = 0;
604              
605 0           while ($orig_text =~ m{\G(.*?)(\&|\z)}msg)
606             {
607 0           my ($before, $indicator) = ($1, $2);
608              
609 0           $ret .= $before;
610              
611 0 0         if ($indicator eq '&')
612             {
613 0 0         if ($orig_text =~ m{\G(\#?\w+;)}cg)
614             {
615 0           $ret .= HTML::Entities::decode_entities("&$1");
616             }
617             else
618             {
619 0           Carp::confess(
620             sprintf(
621             "Cannot match entity '%s' at line %d",
622             substr($orig_text, pos($orig_text)-1, 10),
623             $self->line_num(),
624             )
625             );
626             }
627             }
628             }
629              
630 0           return $ret;
631             }
632              
633             sub _parse_non_tag_text_unit
634             {
635 0     0     my $self = shift;
636              
637 0           my $orig_text = $self->consume_up_to(
638             $self->_non_tag_text_unit_consume_regex
639             );
640              
641 0           my $text = $self->_decode_entities_in_text($orig_text);
642              
643 0           my $l = $self->curr_line_ref();
644              
645 0           my $ret_elem = $self->_new_text([$text]);
646 0           my $is_para_end = 0;
647              
648             # Demote the cursor to before the < of the tag.
649             #
650 0 0         if ($self->at_line_start)
651             {
652 0           $is_para_end = 1;
653             }
654             else
655             {
656 0           pos($$l)--;
657 0 0         if (substr($$l, pos($$l), 1) eq "\n")
658             {
659 0           $is_para_end = 1;
660             }
661             }
662              
663 0 0         if ($text !~ /\S/)
664             {
665 0           return;
666             }
667             else
668             {
669             return
670             {
671 0           elem => $ret_elem,
672             para_end => $is_para_end,
673             };
674             }
675             }
676              
677             sub _parse_text_unit
678             {
679 0     0     my $self = shift;
680              
681 0 0         if (defined(my $event = $self->_extract_event()))
682             {
683 0           return $event;
684             }
685             else
686             {
687 0           $self->_generate_text_unit_events();
688 0           return $self->_extract_event();
689             }
690             }
691              
692             sub _flush_events
693             {
694 0     0     my $self = shift;
695              
696 0           my @ret = @{$self->_events_queue()};
  0            
697              
698 0           $self->_clear_events;
699              
700 0           return \@ret;
701             }
702              
703             sub _parse_text
704             {
705 0     0     my $self = shift;
706              
707 0           my @ret;
708              
709 0           while (my $unit = $self->_parse_text_unit())
710             {
711 0           push @ret, $unit;
712              
713 0 0         if ($unit->is_open_or_close)
714             {
715 0           return [@ret, @{$self->_flush_events()}];
  0            
716             }
717             }
718              
719 0           return \@ret;
720             }
721              
722             sub _look_for_tag_opener
723             {
724 0     0     my $self = shift;
725              
726 0           my $l = $self->curr_line_ref();
727              
728 0 0         if ($$l =~ m{\G(<(?:/)?)}cg)
729             {
730 0           return $1;
731             }
732             else
733             {
734 0           return;
735             }
736             }
737              
738             sub _is_closing_tag {
739 0     0     my $self = shift;
740 0           my $tag_start = shift;
741              
742 0           return $tag_start =~ m{/};
743             }
744              
745             sub _generate_tag_event
746             {
747 0     0     my $self = shift;
748              
749 0           my $l = $self->curr_line_ref();
750 0           my $orig_pos = pos($$l);
751              
752 0 0         if (defined(my $tag_start = $self->_look_for_tag_opener()))
753             {
754             # If it's a tag.
755              
756             # TODO : implement the comment handling.
757             # We have a tag.
758              
759 0           pos($$l) = $orig_pos;
760              
761 0 0         $self->_enqueue_event(
762             XML::Grammar::FictionBase::Event->new(
763             {'type' => ($self->_is_closing_tag($tag_start) ? "close" : "open")}
764             ),
765             );
766              
767 0           return 1;
768             }
769             else
770             {
771 0           return;
772             }
773             }
774              
775             sub _handle_open_tag
776             {
777 0     0     my $self = shift;
778              
779 0           my $open = $self->_parse_opening_tag();
780              
781 0           $open->children([]);
782              
783             # TODO : add the check for is_standalone in XML-Grammar-Fiction
784             # too.
785 0 0         if ($open->is_standalone())
786             {
787 0 0         if (defined($self->_merge_tag($open)))
788             {
789 0           Carp::confess ("Top element/tag cannot be standalone.");
790             }
791             else
792             {
793 0           return;
794             }
795             }
796             else
797             {
798 0           $self->_push_tag($open);
799              
800 0           return;
801             }
802             }
803              
804             sub _generate_text_unit_events
805             {
806 0     0     my $self = shift;
807              
808             # $self->skip_multiline_space();
809              
810 0 0         if (! $self->_generate_tag_event())
811             {
812 0           $self->_generate_non_tag_text_event();
813             }
814              
815 0           return;
816             }
817              
818             sub _flush_ret_tag
819             {
820 0     0     my $self = shift;
821              
822 0           my $ret = $self->_ret_tag();
823              
824 0           $self->_clear_ret_tag();
825              
826 0           return $ret;
827             }
828              
829             sub _main_loop
830             {
831 0     0     my $self = shift;
832              
833 0           while (! defined($self->_ret_tag()))
834             {
835 0           $self->_main_loop_iter();
836             }
837              
838 0           return;
839             }
840              
841             sub _parse_all
842             {
843 0     0     my $self = shift;
844              
845 0           $self->_main_loop();
846              
847 0           return $self->_flush_ret_tag();
848             }
849              
850             sub _assert_not_eof
851             {
852 0     0     my $self = shift;
853              
854 0 0 0       if ($self->eof() && $self->_no_events())
855             {
856 0 0         if (! $self->_tags_stack_is_empty() )
857             {
858 0           XML::Grammar::Fiction::Err::Parse::TagNotClosedAtEOF->throw(
859             error => "Tag not closed at EOF.",
860             opening_tag => $self->_top_tag(),
861             );
862             }
863             else
864             {
865 0           Carp::confess (qq{Reached EOF.});
866             }
867             }
868              
869 0           return;
870             }
871              
872             sub _main_loop_iter
873             {
874 0     0     my $self = shift;
875              
876 0           $self->_assert_not_eof;
877              
878 0 0         if ($self->_look_ahead_for_comment)
879             {
880 0           return;
881             }
882             else
883             {
884 0           return $self->_main_loop_iter_body;
885             }
886             }
887              
888             sub _attempt_to_calc_new_ret_tag
889             {
890 0     0     my $self = shift;
891              
892 0           $self->_ret_tag(scalar($self->_look_for_and_handle_tag()));
893              
894 0           return;
895             }
896              
897             sub _main_loop_iter_body
898             {
899 0     0     my $self = shift;
900              
901 0 0         if ($self->_main_loop_iter_body_prelude())
902             {
903 0           $self->_attempt_to_calc_new_ret_tag();
904             }
905              
906 0           return;
907             }
908              
909              
910             our $VERSION = 'v0.14.12';
911              
912              
913             sub process_text
914             {
915 0     0 1   my ($self, $text) = @_;
916              
917 0           $self->setup_text($text);
918              
919 0           return $self->_parse_all();
920             }
921              
922              
923             1;
924              
925             __END__