File Coverage

blib/lib/Text/Autoformat/Hang.pm
Criterion Covered Total %
statement 53 116 45.6
branch 14 64 21.8
condition 15 53 28.3
subroutine 12 23 52.1
pod 0 12 0.0
total 94 268 35.0


line stmt bran cond sub pod time code
1             package Text::Autoformat::Hang;
2             $Text::Autoformat::Hang::VERSION = '1.73';
3 4     4   93 use 5.006;
  4         12  
4 4     4   22 use strict;
  4         8  
  4         94  
5 4     4   21 use warnings;
  4         9  
  4         3361  
6              
7             # ROMAN NUMERALS
8              
9 16     16 0 30 sub inv($@) { my ($k, %inv)=shift; for(0..$#_) {$inv{$_[$_]}=$_*$k} %inv }
  16         46  
  136         327  
  16         134  
10             my @unit= ( "" , qw ( I II III IV V VI VII VIII IX ));
11             my @ten = ( "" , qw ( X XX XXX XL L LX LXX LXXX XC ));
12             my @hund= ( "" , qw ( C CC CCC CD D DC DCC DCCC CM ));
13             my @thou= ( "" , qw ( M MM MMM ));
14             my %rval= (inv(1,@unit),inv(10,@ten),inv(100,@hund),inv(1000,@thou));
15             my $rbpat= join ")(",join("|",reverse @thou), join("|",reverse @hund), join("|",reverse @ten), join("|",reverse @unit);
16             my $rpat= join ")(?:",join("|",reverse @thou), join("|",reverse @hund), join("|",reverse @ten), join("|",reverse @unit);
17             my $rom = qq/(?:(?=[MDCLXVI])(?:$rpat))/;
18              
19             my $abbrev = join '|', qw{ etc[.] pp[.] ph[.]?d[.] },
20             "(?!$rom)(?:[A-Z][A-Za-z]+[.])+",
21             '(?:[A-Z][.])(?:[A-Z][.])+';
22              
23             sub fromRoman($)
24             {
25 3 50   3 0 105 return 0 unless $_[0] =~ /^.*?($rbpat).*$/i;
26 3         32 return $rval{uc $1} + $rval{uc $2} + $rval{uc $3} + $rval{uc $4};
27             }
28              
29             sub toRoman($$)
30             {
31 0     0 0 0 my ($num,$example) = @_;
32 0 0       0 return '' unless $num =~ /^([0-3]??)(\d??)(\d??)(\d)$/;
33 0   0     0 my $roman = $thou[$1||0] . $hund[$2||0] . $ten[$3||0] . $unit[$4||0];
      0        
      0        
      0        
34 0 0       0 return $example=~/[A-Z]/ ? uc $roman : lc $roman;
35             }
36              
37             # BITS OF A NUMERIC VALUE
38              
39             my $num = q/(?:[0-9]{1,3}\b(?!:[0-9][0-9]\b))/; # Ignore 8:20 etc.
40             my $let = q/[A-Za-z]/;
41             my $pbr = q/[[(<]/;
42             my $sbr = q/])>/;
43             my $ows = q/[ \t]*/;
44             my %close = ( '[' => ']', '(' => ')', '<' => '>', "" => '' );
45              
46             my $hangPS = qq{(?i:ps:|(?:p\\.?)+s\\b\\.?(?:[ \\t]*:)?)};
47             my $hangNB = qq{(?i:n\\.?b\\.?(?:[ \\t]*:)?)};
48             my $hangword = qq{(?:(?:Note)[ \\t]*:)};
49             my $hangbullet = qq{[*.+-]};
50             my $hang = qq{(?:(?i)(?:$hangNB|$hangword|$hangbullet)(?=[ \t]))};
51              
52             # IMPLEMENTATION
53              
54             sub new {
55 26     26 0 83 my ($class, $orig, $lists_mode) = @_;
56 26 50       56 return Text::Autoformat::NullHang->new() if !$lists_mode;
57              
58 26         35 my $origlen = length $orig;
59 26         33 my @vals;
60 26 50 66     384 if ($_[1] =~ s#\A($hangPS)##) {
    50          
    50          
61 0         0 @vals = { type => 'ps', val => $1 }
62             }
63             elsif ($lists_mode =~ /1|bullet/i && $_[1] =~ s#\A($hang)##) {
64 0         0 @vals = { type => 'bul', val => $1 }
65             }
66             elsif ($_[1] =~ m#\A\([^\s)]+\s#) {
67 0         0 @vals = ();
68             }
69             else {
70 4     4   24 no warnings "all";
  4         8  
  4         2658  
71 26         7703 my $cut;
72 26         98 while (length $_[1]) {
73 22 0 0     326 last if $_[1] =~ m#\A($ows)($abbrev)#
      33        
74             && (length $1 || !@vals); # ws-separated or first
75              
76 22 50       144 last if $_[1] =~ m{\A $ows $pbr [^$sbr \t]* \s}xms;
77              
78 22         41 $cut = $origlen - length $_[1];
79 22 50       115 my $pre = $_[1] =~ s#\A($ows$pbr$ows)## ? $1 : "";
80 22 50 33     688 my $val
    100 100        
    50 66        
81             = ($lists_mode =~ /1|number/i && $_[1] =~ s#\A($num)##)
82             ? { type=>'num', val=>$1 }
83             : ($lists_mode =~ /1|roman/i && $_[1] =~ s#\A($rom)\b##i)
84             ? { type=>'rom', val=>$1, nval=>fromRoman($1) }
85             : ($lists_mode =~ /1|alpha/i && $_[1] =~ s#\A($let(?!$let))##i)
86             ? { type=>'let', val=>$1 }
87             : { val => "", type => "" };
88 22 100 50     148 $_[1] = $pre.$_[1] and last unless $val->{val};
89 1   50     38 $val->{post} = $pre && $_[1] =~ s#\A($ows()[.:/]?[$close{$pre}][.:/]?)## && $1
90             || $_[1] =~ s#\A($ows()[$sbr.:/])## && $1
91             || "";
92 1         3 $val->{pre} = $pre;
93 1         3 $val->{cut} = $cut;
94 1         4 push @vals, $val;
95             }
96 26   66     89 while (@vals && !$vals[-1]{post}) {
97 1         7 $_[1] = substr($orig,pop(@vals)->{cut});
98             }
99             }
100              
101             # check for orphaned years or unlikely Roman numerals...
102 26 0 33     73 if (@vals==1 && defined $vals[0]->{post} && $vals[0]->{post} =~ /[\.>)]/) {
      33        
103 0         0 my $v = $vals[0];
104 0 0 0     0 if ($v->{type} eq 'num' && $v->{val} >= 1000) {
105 0         0 $_[1] = substr($orig,pop(@vals)->{cut});
106             }
107             }
108              
109 26 50       123 return Text::Autoformat::NullHang->new if !@vals;
110 0           bless \@vals, $class;
111             }
112              
113             sub incr {
114 4     4   25 no warnings "all";
  4         7  
  4         1916  
115 0     0 0   my ($self, $prev, $prevsig) = @_;
116 0           my $level;
117             # check compatibility
118              
119 0 0 0       return unless $prev && !$prev->empty;
120              
121 0 0         for $level (0..(@$self<@$prev ? $#$self : $#$prev)) {
122 0 0         if ($self->[$level]{type} ne $prev->[$level]{type}) {
123 0 0         return if @$self<=@$prev; # no incr if going up
124 0           $prev = $prevsig;
125 0           last;
126             }
127             }
128 0 0 0       return unless $prev && !$prev->empty;
129 0 0         if ($self->[0]{type} eq 'ps') {
    0          
    0          
130 0           my $count = 1 + $prev->[0]{val} =~ s/(p[.]?)/$1/gi;
131 0           $prev->[0]{val} =~ /^(p[.]?).*(s[.]?[:]?)/;
132 0           $self->[0]{val} = $1 x $count . $2;
133             }
134             elsif ($self->[0]{type} eq 'bul') {
135             # do nothing
136             }
137             elsif (@$self>@$prev) { # going down level(s)
138 0           for $level (0..$#$prev) {
139 0           @{$self->[$level]}{'val','nval'} = @{$prev->[$level]}{'val','nval'};
  0            
  0            
140             }
141 0           for $level (@$prev..$#$self) {
142 0           _reset($self->[$level]);
143             }
144             }
145             else # same level or going up
146             {
147 0           for $level (0..$#$self) {
148 0           @{$self->[$level]}{'val','nval'} = @{$prev->[$level]}{'val','nval'};
  0            
  0            
149             }
150 0           _incr($self->[-1])
151             }
152             }
153              
154             sub _incr {
155 4     4   23 no warnings "all";
  4         8  
  4         596  
156 0 0   0     if ($_[0]{type} eq 'rom') {
157 0           $_[0]{val} = toRoman(++$_[0]{nval},$_[0]{val});
158             }
159             else {
160 0 0 0       $_[0]{val}++ unless $_[0]{type} eq 'let' && $_[0]{val}=~/Z/i;
161             }
162             }
163              
164             sub _reset {
165 4     4   28 no warnings "all";
  4         7  
  4         771  
166 0 0   0     if ($_[0]{type} eq 'rom') {
    0          
167 0           $_[0]{val} = toRoman($_[0]{nval}=1,$_[0]{val});
168             }
169             elsif ($_[0]{type} eq 'let') {
170 0 0         $_[0]{val} = $_[0]{val} =~ /[A-Z]/ ? 'A' : 'a';
171             }
172             else {
173 0           $_[0]{val} = 1;
174             }
175             }
176              
177             sub stringify {
178 0     0 0   my ($self) = @_;
179 0           my ($str, $level) = ("");
180 0           for $level (@$self) {
181 4     4   21 no warnings "all";
  4         7  
  4         894  
182 0           $str .= join "", @{$level}{'pre','val','post'};
  0            
183             }
184 0           return $str;
185             }
186              
187             sub val {
188 0     0 0   my ($self, $i) = @_;
189 0           return $self->[$i]{val};
190             }
191              
192 0     0 0   sub fields { return scalar @{$_[0]} }
  0            
193              
194             sub field {
195 0     0 0   my ($self, $i, $newval) = @_;
196 0 0         $self->[$i]{type} = $newval if @_>2;
197 0           return $self->[$i]{type};
198             }
199              
200             sub signature {
201 4     4   32 no warnings "all";
  4         7  
  4         938  
202 0     0 0   my ($self) = @_;
203 0           my ($str, $level) = ("");
204 0           for $level (@$self) {
205 0   0       $level->{type} ||= "";
206             $str .= join "", $level->{pre},
207             ($level->{type} =~ /rom|let/ ? "romlet" : $level->{type}),
208 0 0         $level->{post};
209             }
210 0           return $str;
211             }
212              
213             sub length {
214 0     0 0   length $_[0]->stringify
215             }
216              
217 0     0 0   sub empty { 0 }
218              
219             1;
220