File Coverage

blib/lib/Text/Amuse/Element.pm
Criterion Covered Total %
statement 132 150 88.0
branch 56 68 82.3
condition 43 62 69.3
subroutine 35 40 87.5
pod 35 35 100.0
total 301 355 84.7


line stmt bran cond sub pod time code
1             package Text::Amuse::Element;
2 46     46   58568 use strict;
  46         78  
  46         1120  
3 46     46   217 use warnings;
  46         74  
  46         860  
4 46     46   11223 use utf8;
  46         309  
  46         247  
5              
6             =head1 NAME
7              
8             Text::Amuse::Element - Helper for Text::Amuse
9              
10             =head1 METHODS/ACCESSORS
11              
12             Everything here is pretty much internal only, underdocumented and
13             subject to change.
14              
15             =over 4
16              
17             =item new(%args)
18              
19             Constructor
20              
21             =cut
22              
23             sub new {
24 27580     27580 1 67029 my ($class, %args) = @_;
25 27580         203453 my $self = {
26             rawline => '',
27             raw_without_anchors => '',
28             block => '', # the block it says to belong
29             type => 'null', # the type
30             string => '', # the string
31             removed => '', # the portion of the string removed
32             attribute => '', # optional attribute for desclists
33             indentation => 0,
34             attribute_type => '',
35             style => 'X',
36             start_list_index => 0,
37             element_number => 0,
38             footnote_number => 0,
39             footnote_symbol => '',
40             footnote_index => '',
41             anchors => [],
42             language => '',
43             };
44 27580         37800 my %provided;
45 27580         117169 foreach my $accessor (keys %$self) {
46 468860 100 66     770313 if (exists $args{$accessor} and defined $args{$accessor}) {
47 110314         136412 $self->{$accessor} = $args{$accessor};
48 110314         152169 $provided{$accessor} = 1;
49             }
50             }
51 27580 100       56565 unless ($provided{indentation}) {
52 25890         40975 $self->{indentation} = length($self->{removed});
53             }
54              
55             die "anchors passed to the constructor but not a reference $self->{anchors}"
56 27580 50       52727 unless ref($self->{anchors}) eq 'ARRAY';
57              
58 27580 100 66     46238 if (exists $args{anchor} and length $args{anchor}) {
59 420         541 push @{$self->{anchors}}, $args{anchor};
  420         932  
60             }
61              
62 27580         83606 bless $self, $class;
63             }
64              
65             =item language
66              
67             Accessor to the language attribute
68              
69             =cut
70              
71             sub language {
72 4874     4874 1 12882 shift->{language};
73             }
74              
75             =item rawline
76              
77             Accessor to the raw input line
78              
79             =cut
80              
81             sub rawline {
82 9524     9524 1 22011 my $self = shift;
83 9524         20269 return $self->{rawline};
84             }
85              
86             =item raw_without_anchors
87              
88             Return the original string, but with anchors stripped out.
89              
90             =cut
91              
92             sub raw_without_anchors {
93 7171     7171 1 8085 my $self = shift;
94 7171         12583 return $self->{raw_without_anchors};
95             }
96              
97             sub _reset_rawline {
98 0     0   0 my ($self, $line) = @_;
99 0         0 $self->{rawline} = $line;
100             }
101              
102             =item will_not_merge
103              
104             Attribute to mark if an element cannot be further merged
105              
106             =cut
107              
108             sub will_not_merge {
109 23459     23459 1 29827 my ($self, $arg) = @_;
110 23459 50       34508 if (defined $arg) {
111 0         0 $self->{_will_not_merge} = $arg;
112             }
113 23459         41381 return $self->{_will_not_merge};
114             }
115              
116             =item anchors
117              
118             A list of anchors for this element.
119              
120             =item add_to_anchors(@list)
121              
122             Add the anchors passed to the constructor to this element.
123              
124             =item remove_anchors
125              
126             Empty the anchors array in the element
127              
128             =item move_anchors_to($element)
129              
130             Remove the anchors from this element and add them to the one passed as
131             argument.
132              
133             =cut
134              
135             sub anchors {
136 56228     56228 1 67950 my $self = shift;
137 56228         58198 return @{$self->{anchors}};
  56228         158388  
138             }
139              
140             sub add_to_anchors {
141 4897     4897 1 7511 my ($self, @anchors) = @_;
142 4897         5343 push @{$self->{anchors}}, @anchors;
  4897         11663  
143             }
144              
145             sub remove_anchors {
146 296     296 1 513 my ($self) = @_;
147 296         745 $self->{anchors} = [];
148             }
149              
150             sub move_anchors_to {
151 296     296 1 504 my ($self, $el) = @_;
152 296         507 $el->add_to_anchors($self->anchors);
153 296         636 $self->remove_anchors;
154             }
155              
156             =back
157              
158             =head2 ACCESSORS
159              
160             The following accessors set the value if an argument is provided.
161              
162             =over 4
163              
164             =item block
165              
166             The block the string belongs
167              
168             =cut
169              
170             sub block {
171 46248     46248 1 52029 my $self = shift;
172 46248 100       66713 if (@_) {
173 1818         2368 $self->{block} = shift;
174             }
175 46248   66     116174 return $self->{block} || $self->type;
176             }
177              
178             =item type
179              
180             The type
181              
182             =cut
183              
184             sub type {
185 560078     560078 1 642682 my $self = shift;
186 560078 100       774990 if (@_) {
187 1709         2467 $self->{type} = shift;
188             }
189 560078         1315229 return $self->{type};
190             }
191              
192             =item string
193              
194             The string (without the indentation or the leading markup)
195              
196             =cut
197              
198             sub string {
199 44205     44205 1 52261 my $self = shift;
200 44205 50       64772 if (@_) {
201 0         0 $self->{string} = shift;
202             }
203 44205         159176 return $self->{string};
204             }
205              
206             =item removed
207              
208             The portion of the string stripped out
209              
210             =cut
211              
212             sub removed {
213 62     62 1 98 my $self = shift;
214 62 50       135 if (@_) {
215 0         0 die "Read only attribute!";
216             }
217 62         257 return $self->{removed};
218             }
219              
220             =item style
221              
222             The block style. Default to C, read only. Used for aliases of tags,
223             when closing it requires a matching style.
224              
225             =cut
226              
227             sub style {
228 1018     1018 1 1416 my $self = shift;
229 1018 50       1703 die "Read only attribute!" if @_;
230 1018         2275 return $self->{style};
231             }
232              
233             =item indentation
234              
235             The indentation level, as a numerical value
236              
237             =cut
238              
239             sub indentation {
240 14427     14427 1 26528 return shift->{indentation};
241             }
242              
243             =item footnote_number
244              
245             The footnote number
246              
247             =cut
248              
249             sub footnote_number {
250 1266     1266 1 2843 return shift->{footnote_number};
251             }
252              
253             =item footnote_symbol
254              
255             The footnote symbol
256              
257             =cut
258              
259             sub footnote_symbol {
260 1872     1872 1 3946 return shift->{footnote_symbol};
261             }
262              
263             =item footnote_index
264              
265             The footnote index
266              
267             =cut
268              
269             sub footnote_index {
270 1316     1316 1 2961 return shift->{footnote_index};
271             }
272              
273              
274              
275              
276             =item attribute
277              
278             Accessor to attribute
279              
280             =cut
281              
282             sub attribute {
283 1544     1544 1 4345 return shift->{attribute};
284             }
285              
286             =item attribute_type
287              
288             Accessor to attribute_type
289              
290             =cut
291              
292             sub attribute_type {
293 384     384 1 964 return shift->{attribute_type};
294             }
295              
296              
297             =item start_list_index
298              
299             Accessor rw to start_list_index (defaults to 0)
300              
301             =cut
302              
303             sub start_list_index {
304 12957     12957 1 16103 my $self = shift;
305 12957 100       20148 if (@_) {
306 3328         3997 my $arg = shift;
307 3328 50       4953 if (defined $arg) {
308 3328         4364 $self->{start_list_index} = $arg;
309             }
310             }
311 12957         25765 return $self->{start_list_index};
312             }
313              
314             =back
315              
316             =head2 HELPERS
317              
318             =over 4
319              
320             =item is_start_block($blockname)
321              
322             Return true if the element is a "startblock" of the required block name
323              
324             =cut
325              
326             sub is_start_block {
327 51261     51261 1 62775 my $self = shift;
328 51261   50     73435 my $block = shift || "";
329 51261 100 100     64646 if ($self->type eq 'startblock' and $self->block eq $block) {
330 352         893 return 1;
331             } else {
332 50909         112347 return 0;
333             }
334             }
335              
336             =item is_stop_element($element)
337              
338             Return true if the element is a matching stopblock for the element
339             passed as argument.
340              
341             =cut
342              
343             sub is_stop_element {
344 2341     2341 1 3799 my ($self, $element) = @_;
345 2341 100 66     5063 if ($element and
      100        
      100        
346             $self->type eq 'stopblock' and
347             $self->block eq $element->type and
348             $self->style eq $element->style) {
349 318         863 return 1;
350             }
351             else {
352 2023         4714 return 0;
353             }
354             }
355              
356             =item is_regular_maybe
357              
358             Return true if the element is "regular", i.e., it just have trailing
359             white space
360              
361             =cut
362              
363             sub is_regular_maybe {
364 0     0 1 0 my $self = shift;
365 0 0 0     0 if ($self->type eq 'li' or
      0        
366             $self->type eq 'null' or
367             $self->type eq 'regular') {
368 0         0 return 1;
369             } else {
370 0         0 return 0;
371             }
372             }
373              
374             =item can_merge_next
375              
376             Return true if the element will merge the next one
377              
378             =cut
379              
380             sub can_merge_next {
381 15078     15078 1 17960 my $self = shift;
382 15078 50       21678 return 0 if $self->will_not_merge;
383 15078         57855 my %nomerge = (
384             bidimarker => 1,
385             stopblock => 1,
386             startblock => 1,
387             null => 1,
388             table => 1,
389             versep => 1,
390             newpage => 1,
391             inlinecomment => 1,
392             comment => 1,
393             );
394 15078 100       22922 if ($nomerge{$self->type}) {
395 6697         18742 return 0;
396             } else {
397 8381         27657 return 1;
398             }
399             }
400              
401             =item can_be_merged
402              
403             Return true if the element will merge the next one. Only regular strings.
404              
405             =cut
406              
407             sub can_be_merged {
408 8381     8381 1 11564 my $self = shift;
409 8381 50       11452 return 0 if $self->will_not_merge;
410 8381 100 66     12204 if ($self->type eq 'regular' or $self->type eq 'verse') {
411 2595         6593 return 1;
412             }
413             else {
414 5786         13587 return 0;
415             }
416             }
417              
418             =item can_be_in_list
419              
420             Return true if the element can be inside a list
421              
422             =cut
423              
424             sub can_be_in_list {
425 0     0 1 0 my $self = shift;
426 0 0 0     0 if ($self->type eq 'li' or
      0        
427             $self->type eq 'null', or
428             $self->type eq 'regular') {
429 0         0 return 1;
430             } else {
431 0         0 return 0;
432             }
433             }
434              
435             =item can_be_regular
436              
437             Return true if the element is quote, center, right
438              
439             =cut
440              
441             sub can_be_regular {
442 17234     17234 1 18419 my $self = shift;
443 17234 100       20842 return 0 unless $self->type eq 'regular';
444 4498 100 100     6972 if ($self->block eq 'quote' or
      100        
445             $self->block eq 'center' or
446             $self->block eq 'right') {
447 278         807 return 1;
448             }
449             else {
450 4220         8442 return 0;
451             }
452             }
453              
454              
455             =item should_close_blocks
456              
457             =cut
458              
459             sub should_close_blocks {
460 3133     3133 1 4059 my $self = shift;
461 3133 100       4081 return 0 if $self->type eq 'regular';
462 1249 100       2006 return 1 if $self->type =~ m/h[1-5]/;
463 1239 100       2046 return 1 if $self->block eq 'example';
464 1233 100       1943 return 1 if $self->block eq 'verse';
465 1227 100       1847 return 1 if $self->block eq 'table';
466 1221 100       1845 return 1 if $self->type eq 'newpage';
467 1218         2905 return 0;
468             }
469              
470              
471             =item add_to_string($string, $other_string, [...])
472              
473             Append (just concatenate) the given strings to the string attribute.
474              
475             =cut
476              
477             sub add_to_string {
478 0     0 1 0 my ($self, @args) = @_;
479 0         0 my $orig = $self->string;
480 0         0 $self->_reset_rawline(); # we modify the string, so throw away the rawline
481 0         0 $self->string(join("", $orig, @args));
482             }
483              
484             =item append($element)
485              
486             Append the element passed as argument to this one, setting the raw_line
487              
488             =cut
489              
490             sub append {
491 6343     6343 1 8755 my ($self, $element) = @_;
492 6343         10388 $self->{rawline} .= $element->rawline;
493 6343         10990 $self->{raw_without_anchors} .= $element->raw_without_anchors;
494 6343         9352 my $type = $self->type;
495             # greedy elements
496 6343 100 100     16631 if ($type eq 'example') {
    100          
497 1742         2741 $self->{string} .= $element->rawline;
498             # ignore the anchors, they can't be inside.
499 1742         2969 return;
500             }
501             elsif ($type eq 'verse' or $type eq 'footnote') {
502 476         932 $self->{string} .= $element->raw_without_anchors;
503             }
504             else {
505 4125         7675 $self->{string} .= $element->string;
506             }
507             # inherit the anchors
508 4601         8174 $self->add_to_anchors($element->anchors);
509             }
510              
511             =item can_append($element)
512              
513             =cut
514              
515             sub can_append {
516 15078     15078 1 23020 my ($self, $element) = @_;
517 15078 100 100     23430 if ($self->can_merge_next && $element->can_be_merged) {
518 2595         6853 return 1;
519             }
520 12483 100 100     19121 if ($self->type eq 'footnote' and
      100        
      66        
521             $element->type ne 'footnote' and
522             $element->type ne 'null' and
523             !$element->should_close_blocks) {
524 20         60 return 1;
525             }
526             # same type. Marked as can_merge_next => false
527 12463         18308 foreach my $type (qw/table versep null/) {
528 36441 100 100     46132 if ($self->type eq $type and $element->type eq $type) {
529 1518         4752 return 1;
530             }
531             }
532 10945         26950 return 0;
533             }
534              
535             =item become_regular
536              
537             Set block to empty string and type to regular
538              
539             =cut
540              
541             sub become_regular {
542 1601     1601 1 1879 my $self = shift;
543 1601         3002 $self->type('regular');
544 1601         2272 $self->block('');
545             }
546              
547             =item element_number
548              
549             Internal numbering of the element.
550              
551             =cut
552              
553             sub element_number {
554 0     0 1 0 return shift->{element_number};
555             }
556              
557             sub _set_element_number {
558 17649     17649   22084 my ($self, $num) = @_;
559 17649         29466 $self->{element_number} = $num;
560             }
561              
562             =item is_header
563              
564             Return 1 if the element type is h1/h6, 0 otherwise.
565              
566             =cut
567              
568             sub is_header {
569 2936     2936 1 3905 my $self = shift;
570 2936 100       4490 if ($self->type =~ m/h[1-6]/) {
571 1691         4689 return 1;
572             }
573             else {
574 1245         4110 return 0;
575             }
576             }
577              
578             =back
579              
580             =cut
581              
582             1;