File Coverage

blib/lib/Net/DRI/Data/LanguageTag.pm
Criterion Covered Total %
statement 29 126 23.0
branch 4 50 10.0
condition 0 9 0.0
subroutine 7 25 28.0
pod 0 12 0.0
total 40 222 18.4


line stmt bran cond sub pod time code
1             ## Domain Registry Interface, Language Tag parsing (RFC5646)
2             ##
3             ## Copyright (c) 2015,2016 Patrick Mevzek . All rights reserved.
4             ##
5             ## This file is part of Net::DRI
6             ##
7             ## Net::DRI is free software; you can redistribute it and/or modify
8             ## it under the terms of the GNU General Public License as published by
9             ## the Free Software Foundation; either version 2 of the License, or
10             ## (at your option) any later version.
11             ##
12             ## See the LICENSE file that comes with this distribution for more details.
13             ####################################################################################################
14              
15             package Net::DRI::Data::LanguageTag;
16              
17 70     70   2162 use strict;
  70         93  
  70         1802  
18 70     70   221 use warnings;
  70         85  
  70         1536  
19 70     70   236 use feature 'state';
  70         82  
  70         5214  
20              
21 70     70   669 use Sub::Name;
  70         696  
  70         12480  
22              
23 6     0   13 use overload '""' => sub { my ($self, @rest) = @_; return $self->as_string(); },
  6         10  
24 1     0   3 '@{}' => sub { my ($self, @rest) = @_; return [ $self->subtags() ]; },
  1         3  
25 3 100   0   346 '.' => sub { my ($self, $toadd, $swap) = @_; mydie('Left adding subtags is not implemented') if $swap; return $self->add_subtag($toadd); },
  3         121  
  2         5  
26 4 100   0   81 'cmp' => sub { my ($self, $other, $swap) = @_; my $r = "${self}" cmp "${other}"; return $swap ? -$r : $r; }, ## should we compare subtags one by one?
  4         7  
  4         25  
27 70     70   293 'fallback' => undef;
  70         89  
  70         1024  
28              
29             my $digit=qr/[0-9]/;
30             my $alpha=qr/[A-Za-z]/;
31             my $alphanum=qr/${digit}|${alpha}/;
32              
33             my $irregular=qr/en-GB-oed|i-ami|i-bnn|i-default|i-enochian|i-hak|i-klingon|i-lux|i-mingo|i-navajo|i-pwn|i-tao|i-tay|i-tsu|sgn-BE-FR|sgn-BE-NL|sgn-CH-DE/i;
34             my $regular=qr/art-lojban|cel-gaulish|no-bok|no-nyn|zh-guoyu|zh-hakka|zh-min|zh-min-nan|zh-xiang/i;
35             my $grandfathered=qr/${irregular}|${regular}/;
36              
37             my $privateuse=qr/x(?:-${alphanum}{1,8})+/i; ## TODO check if lower bound is indeed 1 ! is this like an extension, and hence need to be checked
38              
39             my $extlang=qr/${alpha}{3}(?:-${alpha}{3}){0,2}/;
40             my $language=qr/(?:${alpha}{2,3}(-${extlang})?)|${alpha}{4}|${alpha}{5,8}/;
41              
42             my $script=qr/${alpha}{4}/;
43             my $region=qr/${alpha}{2}|${digit}{3}/;
44             my $variant=qr/${alphanum}{5,8}|${digit}${alphanum}{3}/;
45              
46             my $singleton=qr/${digit}|[A-W]|[Y-Z]|[a-w]|[y-z]/;
47             my $extension=qr/${singleton}(?:-${alphanum}{2,8})+/;
48              
49             my $langtag=qr/(?${language})(?