File Coverage

blib/lib/Locale/Maketext/Utils/Phrase.pm
Criterion Covered Total %
statement 81 83 97.5
branch 46 52 88.4
condition 56 71 78.8
subroutine 16 16 100.0
pod 9 9 100.0
total 208 231 90.0


line stmt bran cond sub pod time code
1             package Locale::Maketext::Utils::Phrase;
2              
3 7     7   43054 use strict;
  7         9  
  7         153  
4 7     7   22 use warnings;
  7         7  
  7         115  
5 7     7   20 use Carp ();
  7         6  
  7         78  
6              
7 7     7   1123 use Module::Want ();
  7         2294  
  7         8661  
8              
9             $Locale::Maketext::Utils::Phrase::VERSION = '0.1';
10              
11             my $closing_bn = qr/(?
12             my $opening_bn = qr/(?
13             my $bn_delimit = qr/(?
14             my $bn_var_arg = qr/(?
15              
16             sub get_bn_var_regexp {
17 188     188 1 1867 return qr/(?
18             }
19              
20             sub get_non_translatable_type_regexp {
21 1     1 1 7 return qr/(?:var|meth|basic_var)/;
22             }
23              
24             sub string_has_opening_or_closing_bracket {
25 5   100 5 1 5953 return $_[0] =~ m/$opening_bn/ || $_[0] =~ m/$closing_bn/;
26             }
27              
28             sub phrase2struct {
29 120     120 1 9665 my ($phrase) = @_;
30              
31             # Makes parsing (via code or mentally) unnecessarily difficult.
32             # ? TODO ? s/~~/_TILDES_/g (yes w/ an S so _TILDE_ still works) then restore them inside the while loop and don’t croak() here (maybe carp()) ?
33 120 50       236 Carp::croak("Consecutive tildes are ambiguous (use the special placeholder _TILDE_ instead): “$phrase”") if $phrase =~ m/~~/;
34              
35 120 100       805 return [$phrase] unless $phrase =~ m/(?:$opening_bn|$closing_bn)/;
36              
37 100         84 my @struct;
38 100         834 while (
39             $phrase =~ m{
40             ( # Capture chunk of …
41             # bracket notation …
42             (?:
43             $opening_bn
44             ( # Capture bracket pair contents
45             (?:
46             \~\]
47             |
48             [^\]]
49             )*
50             )
51             $closing_bn
52             )
53             |
54             # … or non-bracket notation
55             (?:
56             \~[\[\]]
57             |
58             [^\[\]]
59             )+
60             ) # /Capture chunk of …
61             }gx
62             ) {
63 407         633 my ( $match, $bn_inside ) = ( $1, $2 );
64              
65 407 100       443 if ( defined $bn_inside ) {
66 172 100       743 if ( $bn_inside =~ m/(?:$closing_bn|$opening_bn)/ ) {
67 6         486 Carp::croak("Unbalanced bracket: “[$bn_inside]”");
68             }
69              
70 166         219 my $list = [ _split_bn_cont($bn_inside) ];
71 166         239 my $type = _get_bn_type_from_list($list);
72              
73 166         1260 push @struct,
74             {
75             'orig' => $match,
76             'cont' => $bn_inside,
77             'list' => $list,
78             'type' => $type,
79             };
80             }
81             else {
82              
83             # probably won't trip but for good measure
84 235 50       871 if ( $match =~ m/(?:$opening_bn|$closing_bn)/ ) {
85 0         0 Carp::croak("Unbalanced bracket: “$match”");
86             }
87              
88 235         1366 push @struct, $match;
89             }
90             }
91              
92 94 50       170 return if !@struct;
93              
94             # if the structure rebuilds differently it means unbalanced [ or ] existed in $phrase that were masked out in @struct
95 94 100       139 if ( struct2phrase( \@struct ) ne $phrase ) {
96 10         682 Carp::croak("Unbalanced bracket: “$phrase”");
97             }
98              
99 84         245 return \@struct;
100             }
101              
102             sub struct2phrase {
103 98     98 1 738 my ($struct) = @_;
104              
105             return join(
106             '',
107 98 100       83 map { ref($_) ? $_->{'orig'} : $_ } @{$struct}
  399         825  
  98         119  
108             );
109             }
110              
111             sub phrase_has_bracket_notation {
112 8 100   8 1 2373 return 1 if $_[0] =~ m/$opening_bn/;
113 2         11 return;
114             }
115              
116             sub struct_has_bracket_notation {
117 4     4 1 3 my $len = @{ $_[0] };
  4         8  
118 4 100 100     37 return 1 if ( $len == 1 && ref( $_[0]->[0] ) ) || $len > 1;
      100        
119 1         6 return;
120             }
121              
122             sub phrase_is_entirely_bracket_notation {
123 8 100   8 1 867 return 1 if $_[0] =~ m{\A$opening_bn(?:\~[\[\]]|[^\[\]])+$closing_bn\z}x;
124 6         20 return;
125             }
126              
127             sub struct_is_entirely_bracket_notation {
128 102 100 100 102 1 61 return 1 if @{ $_[0] } == 1 && ref( $_[0]->[0] );
  102         283  
129 93         204 return;
130             }
131              
132             sub _split_bn_cont {
133 388     388   79743 my ( $cont, $limit ) = @_;
134 388   100     1269 $limit = abs( int( $limit || 0 ) );
135 388 100       2795 return $limit ? split( $bn_delimit, $cont, $limit ) : split( $bn_delimit, $cont );
136             }
137              
138             my %meth = (
139             'numf' => 'Should be passing in an unformatted number.',
140             '#' => 'Should be passing in an unformatted number (numf alias).',
141             'format_bytes' => 'Should be passing in the unformatted number of bytes.',
142             'output' => sub {
143             return 'Should be passing in character identifier.' if $_[0]->[1] eq 'chr';
144             return 'Displayed without modification.' if $_[0]->[1] eq 'asis' || $_[0]->[1] eq 'asis_for_tests';
145             return 'No args, character.' if $_[0]->[1] =~ m/^(?:nbsp|amp|quot|apos|shy|lt|gt)/;
146             return 'Domain should be passed in. Hardcoded domain that needs translated should just be a string.' if $_[0]->[1] eq 'encode_puny' || $_[0]->[1] eq 'decode_puny';
147             return;
148             },
149             'datetime' => sub {
150             return 'format has no translatable components' if !$_[0]->[2] # there is no format (FWIW, 0 is not a valid format)
151             || $_[0]->[2] =~ m/\A(?:date|time|datetime)_format_(:full|long|medium|short|default)\z/ # it is a format method name
152             || $_[0]->[2] =~ m/\A[GgyYQqMmwWdDEeaAhHKkSszZvVuLFcj]+(?:{[0-9],?([0-9])?})?\z/; # is only CLDR Pattern codes …
153              
154             # … i.e. which includes values for format_for() AKA $loc->available_formats(),
155             # http://search.cpan.org/perldoc?DateTime#CLDR_Patterns says:
156             # If you want to include any lower or upper case ASCII characters as-is, you can surround them with single quotes (').
157             # If you want to include a single quote, you must escape it as two single quotes ('').
158             # Spaces and any non-letter text will always be passed through as-is.
159              
160             return;
161             },
162             'current_year' => 'Takes no args.',
163             'asis' => 'Displayed without modification.',
164             'comment' => 'Not displayed.',
165             'join' => 'Arbitrary args.',
166             'sprintf' => 'Arbitrary args.',
167             'convert' => 'Converts arbitrary units and identifiers.', # ? technically USD -> GBP, not critical ATM ?
168             'list_and' => 'Arbitrary args.',
169             'list_or' => 'Arbitrary args.',
170             'list_and_quoted' => 'Arbitrary args.',
171             'list_or_quoted' => 'Arbitrary args.',
172             'list' => 'Deprecated. Arbitrary args.',
173             );
174              
175             my %basic = (
176             'output' => 'has possible translatable parts',
177             'datetime' => 'has possible translatable components in format',
178             );
179              
180             my %complex = (
181             'boolean' => 'should have translatable parts',
182             'is_defined' => 'should have translatable parts',
183             'is_future' => 'should have translatable parts',
184             'quant' => 'should have translatable parts',
185             '*' => 'should have translatable parts (quant alias)',
186             'numerate' => 'should have translatable parts',
187             );
188              
189             my $ns_regexp = Module::Want::get_ns_regexp();
190              
191             sub _get_attr_hash_from_list {
192 179     179   202 my ( $list, $start_idx ) = @_;
193              
194 179         130 my $last_list_idx = @{$list} - 1;
  179         222  
195              
196 179         171 my %attr;
197 179         127 my $skip_to = 0;
198 179         347 for my $i ( $start_idx .. $last_list_idx ) {
199 373 100       612 next if $i < $skip_to;
200 193 100       571 next if $list->[$i] =~ m/\A$bn_var_arg\z/;
201              
202 180         395 $attr{ $list->[$i] } = $list->[ $i + 1 ];
203 180         200 $skip_to = $i + 2;
204             }
205              
206 179         631 return %attr;
207             }
208              
209             sub _get_bn_type_from_list {
210 381     381   98280 my ($list) = @_;
211 381         285 my $len = @{$list};
  381         417  
212              
213 381 100 100     1468 return 'var' if $len == 1 && $list->[0] =~ m/\A$bn_var_arg\z/;
214              
215             # recommend to carp/croak
216 274 100 66     2278 return '_invalid' if !defined $list->[0] || $list->[0] !~ m/\A(?:$ns_regexp|\*|\#)\z/;
217 260 100 66     1821 return '_invalid' if $list->[0] eq 'output' && ( !defined $list->[1] || $list->[1] !~ m/\A$ns_regexp\z/ );
      100        
218              
219             # should not be anything translatable
220 259 100 100     1151 return 'meth' if exists $meth{ $list->[0] } && ( ref( $meth{ $list->[0] } ) ne 'CODE' || $meth{ $list->[0] }->($list) );
      66        
221              
222 212 50 33     676 if ( exists $basic{ $list->[0] } && ( ref( $basic{ $list->[0] } ) ne 'CODE' || $basic{ $list->[0] }->($list) ) ) {
      66        
223              
224             # check for 'basic_var' (might be basic except there are not any translatable parts)
225              
226 206 50       288 if ( $list->[0] eq 'output' ) {
227 206 100       462 if ( $list->[1] =~ m/\A(?:underline|strong|em|class|attr|inline|block|sup|sub)\z/ ) {
228 131         187 my %attr = _get_attr_hash_from_list( $list, 3 );
229              
230 131 100 100     888 if ( $list->[2] =~ m/\A$bn_var_arg\z/
      66        
      100        
      66        
231             && ( !exists $attr{'title'} || $attr{'title'} =~ m/\A$bn_var_arg\z/ )
232             && ( !exists $attr{'alt'} || $attr{'alt'} =~ m/\A$bn_var_arg\z/ ) ) {
233 36         197 return 'basic_var';
234             }
235             }
236              
237             # TODO: do url && factor in html/plain attr && add to t/13.phrase_object_precursor_functions.t
238 170 100       345 if ( $list->[1] =~ m/\A(?:img|abbr|acronym)\z/ ) {
239 42         47 my %attr = _get_attr_hash_from_list( $list, 4 );
240              
241             # if any of these are true (except maybe $list->[2]) w/ these functions
242             # then the caller is probably doing something wrong, the class/methods
243             # will help find those sort of things better.
244 42 100 66     379 if ( $list->[2] =~ m/\A$bn_var_arg\z/
      100        
      66        
      100        
      66        
245             && $list->[3] =~ m/\A$bn_var_arg\z/
246             && ( !exists $attr{'title'} || $attr{'title'} =~ m/\A$bn_var_arg\z/ )
247             && ( !exists $attr{'alt'} || $attr{'alt'} =~ m/\A$bn_var_arg\z/ ) ) {
248 12         61 return 'basic_var';
249             }
250             }
251             }
252              
253 158         652 return 'basic';
254             }
255              
256 6 50 33     49 return 'complex' if exists $complex{ $list->[0] } && ( ref( $complex{ $list->[0] } ) ne 'CODE' || $complex{ $list->[0] }->($list) );
      33        
257 0           return '_unknown'; # recommend to treat like 'basic' unless its one you know about that your class defines or if it's a show stopper
258             }
259              
260             1;
261              
262             __END__