File Coverage

lib/CallBackery/Translate.pm
Criterion Covered Total %
statement 23 78 29.4
branch 0 16 0.0
condition 0 10 0.0
subroutine 7 12 58.3
pod 4 4 100.0
total 34 120 28.3


line stmt bran cond sub pod time code
1             # $Id: Translate.pm 542 2013-12-12 16:36:34Z oetiker $
2             package CallBackery::Translate;
3              
4 1     1   7 use Mojo::Base -base, -signatures;
  1         2  
  1         7  
5 1     1   230 use Encode;
  1         3  
  1         103  
6 1     1   7 use CallBackery::Exception qw(mkerror);
  1         3  
  1         56  
7              
8 1     1   8 use Exporter 'import';
  1         2  
  1         41  
9 1     1   6 use vars qw(@EXPORT_OK);
  1         2  
  1         908  
10             @EXPORT_OK = qw(trm);
11              
12              
13             =head1 NAME
14              
15             CallBackery::Translate - gettext po file translation functionality
16              
17             =head1 SYNOPSIS
18              
19             use CallBackery::Translate qw(mtr);
20             my $loc = CallBackery::Translate::new(localeRoot=>$dir);
21             $loc->setLocale('de');
22             $loc->tra("Hello %1","Tobi");
23              
24             trm("Mark but for translation but return original");
25              
26             =head1 DESCRIPTION
27              
28             Read translations from gettext po files and translate incoming data.
29              
30             =cut
31              
32             has 'localeRoot';
33              
34             =over
35              
36             =item C($locale);
37              
38             Load the translations strings for $locale. First try the full name and
39             then top-up with only the language part.
40              
41             =cut
42              
43             my %lx;
44              
45             sub setLocale {
46 0     0 1 0 my $self = shift;
47 0         0 my $locale = shift;
48 0 0       0 if ($lx{$locale}){
49 0         0 $self->{_lx} = $lx{$locale};
50 0         0 return;
51             }
52 0         0 my $lang = $locale;
53 0         0 $lang =~ s/_.+//;
54 0         0 for my $file ($lang,$locale){
55 0         0 my $mode = 'id';
56 0 0       0 if (open my $fh, '< :encoding(utf8)', $self->localeRoot.'/'.$file.'.po'){
57 0         0 my $key;
58             my %var;
59 0         0 while (<$fh>){
60 0         0 chomp;
61 0 0       0 /^msg(id|str)\s+"(.*)"/ && do {
62 0         0 $var{$1} = $2;
63 0         0 $key = $1;
64 0         0 next;
65             };
66 0 0       0 /^"(.*)"/ && do {
67 0         0 $var{$key} .= $1;
68 0         0 next;
69             };
70 0 0 0     0 /^\s*$/ && $var{id} && do {
71 0         0 $lx{$locale}{$var{id}} = $var{str};
72 0         0 next;
73             }
74             }
75 0 0 0     0 $lx{$locale}{$var{id}} = $var{str} if $var{id} and $var{str};
76             }
77             }
78 0         0 $self->{_lx} = $lx{$locale};
79             }
80              
81             =item C(str[,arg,arg,...])
82              
83             Translate string into the curent language.
84              
85             =cut
86              
87             sub tra {
88 0     0 1 0 my $self = shift;
89 0         0 my $str = shift;
90 0         0 my @args = @_;
91 0   0     0 my $lx = $self->{_lx} // {};
92 0 0       0 $str = $lx->{$str} if $lx->{$str};
93 0         0 my $id = 1;
94 0         0 for my $a (@args){
95 0         0 $str =~ s/%$id/$a/g;
96 0         0 $id++;
97             }
98 0         0 return $str;
99             }
100              
101             =item C(str[,arg,arg,...])
102              
103             mark for translation but return an array pointer so that the string
104             can be translated dynamically in the frontend. I
105             not yet fully implemented>.
106              
107             =cut
108              
109             # trm("Hello %1",$name);
110              
111             =head2 trm($str[,@args]);
112              
113             Make string and prepare for translation in the frontend.
114              
115             Note there is some major perl magic going on! by blessing the returned
116             array into the current package, we then get to use the overload code
117             on stringification AND Mojo::JSON gets to use the TO_JSON method when
118             converting this into something to be transported to the frontend.
119              
120             =cut
121              
122             use overload
123 0     0   0 '""' => sub ($self,@args) {
  0         0  
  0         0  
  0         0  
124 0         0 my $ret = $self->[0];
125 0   0     0 $ret =~ s{%(\d+)}{$self->[$1]//''}eg;
  0         0  
126 0         0 return $ret;
127             },
128 0     0   0 'eq' => sub ($self,$other,$swap) {
  0         0  
  0         0  
  0         0  
  0         0  
129 0         0 return "$self" eq "$other";
130 1     1   9 };
  1         2  
  1         10  
131              
132 9     9 1 29 sub trm ($str,@args) {
  9         17  
  9         12  
  9         12  
133             # make sure the arguments are stringified
134 9         82 return bless [$str,map { "$_" } @args];
  0            
135             }
136              
137             =head2 $str->TO_JSON
138              
139             Help L encode us into JSON.
140              
141             =cut
142              
143 0     0 1   sub TO_JSON ($self) {
  0            
  0            
144 0 0         my $ret = $#$self == 0 ? $self->[0] : [@$self];
145 0           return $ret;
146             }
147              
148             1;
149              
150              
151             __END__