File Coverage

blib/lib/Text/Guess/Script.pm
Criterion Covered Total %
statement 50 66 75.7
branch 10 10 100.0
condition 2 3 100.0
subroutine 9 10 90.0
pod 2 3 66.6
total 73 92 80.4


line stmt bran cond sub pod time code
1             package Text::Guess::Script;
2              
3 4     4   2937 use strict;
  4         10  
  4         117  
4 4     4   19 use warnings;
  4         6  
  4         156  
5              
6             our $VERSION = '0.05';
7              
8 4     4   2387 use Unicode::Normalize;
  4         8499  
  4         319  
9 4     4   3944 use Unicode::UCD qw(charscript prop_value_aliases);
  4         200801  
  4         355  
10 4     4   33 use charnames ':full'; # ord($char)
  4         10  
  4         21  
11              
12             our @codes;
13              
14             sub new {
15 6     6 1 1049 my $class = shift;
16             # uncoverable condition false
17 6 100 66     46 bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class;
  2 100       13  
18             }
19              
20             sub guess {
21 4     4 1 1857 my ($self, $text) = @_;
22              
23 4         14 my $guesses = $self->guesses($text);
24              
25 4         59 return $guesses->[0]->[0];
26             }
27              
28             sub guesses {
29 4     4 0 11 my ($self, $text) = @_;
30              
31 4         1880 my $text_NFC = NFC($text);
32              
33 4         8030 my @tokens = $text_NFC =~ m/(.)/xmsg;
34              
35 4         79 my $chars = {};
36 4         13 for my $token (@tokens) {
37 18291         24981 $chars->{$token}++;
38             }
39              
40 4         14 my $guesses = {};
41 4         86 my @other_codes = @codes;
42 4         11 my @seen_codes;
43              
44 4         39 CHAR: for my $char (keys %$chars) {
45 131         216 for my $code (@seen_codes) {
46 159 100       1706 if ($char =~ m/\p{$code}/xms) {
47 123         5348 $guesses->{$code} += $chars->{$char};
48 123         273 next CHAR;
49             }
50             }
51 8         16 OTHER: for my $code (@other_codes) {
52 1109         81866 eval {local $SIG{'__DIE__'}; $char =~ m/\p{$code}/xms};
  1109         3058  
  1109         10596  
53 1109 100       173264 if ($@) { next OTHER }
  260         525  
54 849 100       8669 if ($char =~ m/\p{$code}/xms) {
55 8         779 $guesses->{$code} += $chars->{$char};
56 8         22 push @seen_codes,$code;
57 8         29 next CHAR;
58             }
59             }
60             }
61              
62             my $result = [
63 8         44 map { [ $_, $guesses->{$_}/scalar(@tokens) ] }
64 4         54 sort { $guesses->{$b} <=> $guesses->{$a} }
  4         30  
65             keys(%$guesses)
66             ];
67 4         1457 return $result;
68             }
69              
70             sub _guesses {
71 0     0     my ($self, $text) = @_;
72              
73 0           my $text_NFC = NFC($text);
74              
75 0           my @tokens = $text_NFC =~ m/(.)/xmsg;
76              
77 0           my $chars = {};
78 0           for my $token (@tokens) {
79 0           $chars->{$token}++;
80             }
81              
82 0           my $guesses = {};
83 0           my @other_codes = @codes;
84 0           my @seen_codes;
85              
86 0           for my $char (keys %$chars) {
87 0           my ($code, $name) = prop_value_aliases("Script",charscript(ord($char)));
88              
89 0           $guesses->{$code} += $chars->{$char};
90             }
91              
92             my $result = [
93 0           map { [ $_, $guesses->{$_}/scalar(@tokens) ] }
94 0           sort { $guesses->{$b} <=> $guesses->{$a} }
  0            
95             keys(%$guesses)
96             ];
97 0           return $result;
98             }
99              
100              
101             BEGIN {
102 4     4   5197 @codes = qw(
103             Adlm
104             Afak
105             Aghb
106             Ahom
107             Arab
108             Aran
109             Armi
110             Armn
111             Avst
112             Bali
113             Bamu
114             Bass
115             Batk
116             Beng
117             Bhks
118             Blis
119             Bopo
120             Brah
121             Brai
122             Bugi
123             Buhd
124             Cakm
125             Cans
126             Cari
127             Cham
128             Cher
129             Cirt
130             Copt
131             Cprt
132             Cyrl
133             Cyrs
134             Deva
135             Dsrt
136             Dupl
137             Egyd
138             Egyh
139             Egyp
140             Elba
141             Ethi
142             Geok
143             Geor
144             Glag
145             Goth
146             Gran
147             Grek
148             Gujr
149             Guru
150             Hanb
151             Hang
152             Hani
153             Hano
154             Hans
155             Hant
156             Hatr
157             Hebr
158             Hira
159             Hluw
160             Hmng
161             Hrkt
162             Hung
163             Inds
164             Ital
165             Jamo
166             Java
167             Jpan
168             Jurc
169             Kali
170             Kana
171             Khar
172             Khmr
173             Khoj
174             Kitl
175             Kits
176             Knda
177             Kore
178             Kpel
179             Kthi
180             Lana
181             Laoo
182             Latf
183             Latg
184             Latn
185             Leke
186             Lepc
187             Limb
188             Lina
189             Linb
190             Lisu
191             Loma
192             Lyci
193             Lydi
194             Mahj
195             Mand
196             Mani
197             Marc
198             Maya
199             Mend
200             Merc
201             Mero
202             Mlym
203             Modi
204             Mong
205             Moon
206             Mroo
207             Mtei
208             Mult
209             Mymr
210             Narb
211             Nbat
212             Newa
213             Nkgb
214             Nkoo
215             Nshu
216             Ogam
217             Olck
218             Orkh
219             Orya
220             Osge
221             Osma
222             Palm
223             Pauc
224             Perm
225             Phag
226             Phli
227             Phlp
228             Phlv
229             Phnx
230             Piqd
231             Plrd
232             Prti
233             Qaaa
234             Qabx
235             Rjng
236             Roro
237             Runr
238             Samr
239             Sara
240             Sarb
241             Saur
242             Sgnw
243             Shaw
244             Shrd
245             Sidd
246             Sind
247             Sinh
248             Sora
249             Sund
250             Sylo
251             Syrc
252             Syre
253             Syrj
254             Syrn
255             Tagb
256             Takr
257             Tale
258             Talu
259             Taml
260             Tang
261             Tavt
262             Telu
263             Teng
264             Tfng
265             Tglg
266             Thaa
267             Thai
268             Tibt
269             Tirh
270             Ugar
271             Vaii
272             Visp
273             Wara
274             Wole
275             Xpeo
276             Xsux
277             Yiii
278             Zinh
279             Zmth
280             Zsye
281             Zsym
282             Zxxx
283             Zyyy
284             Zzzz
285             );
286             }
287              
288             1;
289              
290             __END__