File Coverage

blib/lib/Text/Amuse/Preprocessor/Typography.pm
Criterion Covered Total %
statement 113 113 100.0
branch 5 6 83.3
condition 4 6 66.6
subroutine 16 16 100.0
pod 4 4 100.0
total 142 145 97.9


line stmt bran cond sub pod time code
1             # -*- mode: cperl -*-
2             package Text::Amuse::Preprocessor::Typography;
3              
4 12     12   183965 use strict;
  12         46  
  12         312  
5 12     12   53 use warnings;
  12         19  
  12         261  
6 12     12   534 use utf8;
  12         34  
  12         70  
7              
8             require Exporter;
9              
10             our @ISA = qw(Exporter);
11              
12             our @EXPORT_OK = qw/typography_filter linkify_filter
13             get_typography_filter/;
14              
15             # frozen at 0.09
16             our $VERSION = '0.09';
17              
18 12     12   5859 use Text::Amuse::Preprocessor::TypographyFilters;
  12         35  
  12         21645  
19              
20              
21             sub linkify_filter {
22 10     10 1 32 return Text::Amuse::Preprocessor::TypographyFilters::linkify(shift);
23             }
24              
25             sub _typography_filter_common {
26 98     98   157 my $l = shift;
27 98         232 $l =~ s/fi/fi/g ;
28 98         168 $l =~ s/fl/fl/g ;
29 98         154 $l =~ s/ffi/ffi/g ;
30 98         157 $l =~ s/ffl/ffl/g ;
31 98         158 $l =~ s/ff/ff/g ;
32              
33 98         191 return $l;
34             }
35              
36              
37             sub _typography_filter_en {
38 24     24   38 my $l = shift;
39             # then the quotes
40             # ascii style
41 24         45 $l =~ s/``/“/g ;
42 24         94 $l =~ s/(''|")\b/“/g ;
43 24         111 $l =~ s/(?<=\s)(''|")/“/gs;
44 24         44 $l =~ s/^(''|")/“/gm;
45 24         62 $l =~ s/(''|")/”/g ;
46              
47             # single
48 24         48 $l =~ s/'(?=[0-9])/’/g;
49 24         34 $l =~ s/`/‘/g;
50 24         52 $l =~ s/\b'/’/g;
51 24         39 $l =~ s/'\b/‘/g;
52 24         34 $l =~ s/^'/‘/gm;
53 24         38 $l =~ s/'/’/g;
54              
55             # the dashes
56             # this is the en-dash –
57 24         59 $l =~ s/(?
58              
59             # em-dash —
60 24         58 $l =~ s/(?<=\S) +-{1,3} +(?=\S)/ — /gs;
61              
62             # and the common case ^th
63 24         135 $l =~ s!\b(\d+)(th|rd|st|nd)\b!$1$2!g;
64 24         81 $l =~ s/(\. ){2,3}\./.../g;
65 24         50 return $l;
66             }
67              
68             sub _typography_filter_es {
69 13     13   25 my $l = shift;
70              
71             # em-dash —
72             # look behind and check it's not a \n
73             # not a spece, space, one-three hyphens, space, not a space => space — space
74 13         42 $l =~ s/(?<=\S) +-{1,3} +(?=\S)/ — /gs;
75             # - at beginning of the line (with no space), it's a dialog (em dash)
76 13         27 $l =~ s/^- */— /gm;
77              
78              
79             # I believe the following rules are dangerous. What if someone says:
80             # "the bit- and byte-wise" => "the bit — and byte-wise" !!!!
81             # I believe they should be removed.
82              
83             # # fix "example- "
84             # $l =~ s/ +-(?=\S)/ — /;
85             # # and " -example"
86             # $l =~ s/(?<=\S)- +/ — /;
87              
88             # better idea: check for matching on the same line
89 13         33 $l =~ s/ +-(\w.+?\w)- +/ — $1 — /gm;
90              
91             # if it touches a word on the right, and on the left there is not a
92             # word, it's an opening quote
93 13         55 $l =~ s/(?<=\W)"(?=\w)/«/gs;
94 13         41 $l =~ s/(?<=\W)'(?=\w)/‘/g;
95              
96             # if there is a space at the left, it's opening
97 13         31 $l =~ s/(?<=\s)"/«/gs;
98 13         24 $l =~ s/(?<=\s)'/‘/gs;
99              
100             # beginning of line, opening
101 13         19 $l =~ s/^"/«/gm;
102 13         21 $l =~ s/^'/‘/gm;
103              
104             # word at the left, closing
105 13         46 $l =~ s/(?<=\w)'/’/g;
106 13         53 $l =~ s/(?<=\w)"/»/g;
107              
108             # the others are right quotes, hopefully
109 13         34 $l =~ s/"/»/gs;
110 13         22 $l =~ s/'/’/g;
111              
112             # now the dots at the end of the quotations, but look behind not to
113             # have another dot
114             # $l =~ s/(?
115            
116 13         25 return $l;
117             }
118              
119              
120             sub _typography_filter_fi {
121 4     4   6 my $l = shift;
122 4         12 $l =~ s/"/\x{201d}/g;
123 4         11 $l =~ s/'/\x{2019}/g;
124 4         59 $l =~ s/(?<=\S) +--? +(?=\S)/ \x{2013} /gs;
125 4         11 return $l;
126             }
127              
128             sub _typography_filter_sr {
129 5     5   9 my $l = shift;
130 5         22 $l =~ s/(''|")\b/\x{201e}/g ;
131 5         23 $l =~ s/(?<=\s)(''|")/\x{201e}/gs;
132 5         15 $l =~ s/(''|")/\x{201c}/g ;
133 5         21 $l =~ s/(?<=\W)'(.*?)'(?=\W)/\x{201a}$1\x{2018}/gs;
134 5         11 $l =~ s/'/\x{2019}/g; # remaining apostrophes
135 5         18 $l =~ s/(?<=\S) +--? +(?=\S)/ \x{2013} /gs;
136 5         10 return $l;
137             }
138              
139             sub _typography_filter_hr {
140 5     5   8 my $l = shift;
141 5         21 $l =~ s/(''|")\b/\x{201e}/g ;
142 5         25 $l =~ s/(?<=\s)(''|")/\x{201e}/gs;
143 5         13 $l =~ s/(''|")/\x{201d}/g ; # ”
144 5         22 $l =~ s/(?<=\W)'(.*?)'(?=\W)/\x{201a}$1\x{2019}/gs; # ‚ ’
145 5         13 $l =~ s/'/\x{2019}/g; # remaining apostrophes
146 5         16 $l =~ s/(?<=\S) +--? +(?=\S)/ \x{2014} /gs; # —
147 5         12 return $l;
148             }
149              
150              
151             sub _typography_filter_ru {
152 44     44   61 my $l = shift;
153 44         340 $l =~ s/(?<=\s)(''|")/«/gs;
154 44         90 $l =~ s/^(''|")/«/gm;
155 44         129 $l =~ s/(''|")\b/«/gs;
156 44         106 $l =~ s/(''|")/»/g ;
157 44         88 $l =~ s/'(?=[0-9])/’/g;
158 44         77 $l =~ s/`/‘/g;
159 44         83 $l =~ s/\b'/’/g;
160 44         74 $l =~ s/'\b/‘/g;
161 44         69 $l =~ s/'/’/g;
162             # em-dash —
163 44         81 $l =~ s/(?<=\S) +-{1,3} +(?=\S)/ — /gs;
164 44         79 $l =~ s/(\. ){2,3}\./.../g;
165              
166              
167             # NON-BREAKING SPACE INSERTIONS
168              
169             # before em dash (—) and en dash (−)
170 44         180 $l =~ s/ (\x{2013}|\x{2014}|\x{2212})/\x{a0}$1/g;
171              
172             # space before, but only if there is a number, otherwise doesn't
173             # make sense.
174              
175 44         261 $l =~ s/(?<=\d)
176             [ ]+ # white space
177             (
178             # months
179             января | февраля | марта | апреля | мая | июня |
180             июля | августа | сентября | октября | ноября | декабря |
181              
182             # units
183             г|кг|мм|дм|см|м|км|л|В|А|ВТ|W|°C
184             )
185             \b # word boundary
186             /\x{a0}$1/gsx;
187            
188             # space after:
189 44         788 $l =~ s/\b # start with a word boundary
190             (
191             # prepositions
192             в|к|о|с|у|
193             В|К|О|С|У|
194             на|от|об|из|за|по|до|во|та|ту|то|те|ко|со|
195             На|От|Об|Из|За|По|До|Во|Со|Ко|Та|Ту|То|Те|
196              
197             # conjunctions
198             А |А,|
199             а |а,|
200             И |И,|
201             и |и,|
202             но|но,|
203             Но|Но,|
204              
205             # obuiquitous "da"
206             да|да,|Да|Да,|
207              
208             # particles with space after
209             не|ни|
210             Не|Ни|
211              
212             # interjections, space after
213             ну|ну,|
214             Ну|Ну,|
215              
216             # abbreviations
217             с\.|ч\.|
218             см\.|См\.|
219             им\.|Им\.|
220             т\.|п\.
221             )
222             [ ]+ # white space
223             (?=\S) # and look ahead for something that is not a white
224             # space or end of line
225             /$1\x{a0}/gsx;
226              
227              
228             # and a space before
229 44         271 $l =~ s/(?<=\S) # look behind for something that is not \n
230             [ ]+ # one or more space
231             (
232             # particles
233             б|ж|ли|же|ль|бы|бы,|же,
234             )
235             (?=[\W]) # white space follows or something that is not a word
236             /\x{a0}$1/gsx;
237              
238              
239 44         105 return $l;
240             }
241              
242              
243             sub filters {
244             return {
245 94     94 1 473 en => \&_typography_filter_en,
246             fi => \&_typography_filter_fi,
247             hr => \&_typography_filter_hr,
248             sr => \&_typography_filter_sr,
249             ru => \&_typography_filter_ru,
250             es => \&_typography_filter_es,
251             };
252             }
253              
254             sub typography_filter {
255 92     92 1 18141 my $lang = $_[0];
256 92         207 my $text = " " . $_[1] . " ";
257 92         188 $text = _typography_filter_common($text);
258              
259 92         191 my $lang_filters = filters();
260 92 100 66     364 if ($lang and exists $lang_filters->{$lang}) {
261 91         210 $text = $lang_filters->{$lang}->($text);
262             }
263 92         194 my $llength = length($text) - 2;
264 92         489 return substr($text, 1, $llength);
265             }
266              
267             sub get_typography_filter {
268 2     2 1 11306 my ($lang, $links) = @_;
269 2         6 my @routines = (\&_typography_filter_common);
270 2         7 my $lang_filters = filters();
271 2 100 66     13 if ($lang && exists $lang_filters->{$lang}) {
272 1         3 push @routines, $lang_filters->{$lang};
273             }
274 2 50       5 if ($links) {
275 2         4 push @routines, \&linkify_filter;
276             }
277             return sub {
278 6     6   3325 my $text = shift;
279 6         15 $text = ' ' . $text . ' ';
280 6         23 foreach my $sub (@routines) {
281 16         32 $text = $sub->($text);
282             }
283 6         12 my $llength = length($text) - 2;
284 6         21 return substr($text, 1, $llength);
285 2         15 };
286             }
287              
288             1;
289              
290             __END__