File Coverage

lib/File/Gettext.pm
Criterion Covered Total %
statement 51 51 100.0
branch 5 10 50.0
condition n/a
subroutine 16 16 100.0
pod 2 2 100.0
total 74 79 93.6


line stmt bran cond sub pod time code
1             package File::Gettext;
2              
3 2     2   2199 use 5.010001;
  2         8  
4 2     2   14 use namespace::autoclean;
  2         5  
  2         22  
5 2     2   198 use version; our $VERSION = qv( sprintf '0.32.%d', q$Rev: 1 $ =~ /\d+/gmx );
  2         4  
  2         16  
6              
7 2     2   317 use English qw( -no_match_vars );
  2         6  
  2         20  
8 2     2   951 use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE NUL SPC TRUE );
  2         3  
  2         202  
9 2     2   13 use File::DataClass::Functions qw( is_hashref merge_attributes throw );
  2         3  
  2         155  
10 2     2   12 use File::DataClass::IO qw( io );
  2         4  
  2         20  
11 2     2   1930 use File::DataClass::Types qw( ArrayRef Directory HashRef Str Undef );
  2         86551  
  2         33  
12 2     2   3960 use File::Gettext::Constants qw( LOCALE_DIRS );
  2         5  
  2         175  
13 2     2   16 use File::Spec::Functions qw( tmpdir );
  2         3  
  2         131  
14 2     2   25 use Type::Utils qw( as coerce declare from enum via );
  2         5  
  2         19  
15 2     2   1770 use Unexpected::Functions qw( Unspecified );
  2         4  
  2         27  
16 2     2   1000 use Moo;
  2         6  
  2         24  
17              
18             extends q(File::DataClass::Schema);
19              
20             # Private functions
21             my $_build_localedir = sub {
22             my $dir = shift; $dir and $dir = io( $dir ) and $dir->is_dir and return $dir;
23              
24             for $dir (map { io $_ } @{ LOCALE_DIRS() }) {
25             $dir->exists and $dir->is_dir and return $dir;
26             }
27              
28             return io tmpdir();
29             };
30              
31             my $LocaleDir = declare as Directory;
32              
33             coerce $LocaleDir,
34             from ArrayRef, via { $_build_localedir->( $_ ) },
35             from Str, via { $_build_localedir->( $_ ) },
36             from Undef, via { $_build_localedir->( $_ ) };
37              
38             my $SourceType = enum 'SourceType' => [ 'mo', 'po' ];
39              
40             # Public attributes
41             has 'charset' => is => 'ro', isa => Str, default => 'iso-8859-1';
42              
43             has 'default_po_header' => is => 'ro', isa => HashRef,
44             default => sub { {
45             appname => 'Your_Application',
46             company => 'ExampleCom',
47             email => '',
48             lang => 'en',
49             team => 'Translators',
50             translator => 'Athena', } };
51              
52             has 'gettext_catagory' => is => 'ro', isa => Str, default => 'LC_MESSAGES';
53              
54             has 'header_key_table' => is => 'ro', isa => HashRef,
55             default => sub { {
56             project_id_version => [ 0, 'Project-Id-Version' ],
57             report_msgid_bugs_to => [ 1, 'Report-Msgid-Bugs-To' ],
58             pot_creation_date => [ 2, 'POT-Creation-Date' ],
59             po_revision_date => [ 3, 'PO-Revision-Date' ],
60             last_translator => [ 4, 'Last-Translator' ],
61             language_team => [ 5, 'Language-Team' ],
62             language => [ 6, 'Language' ],
63             mime_version => [ 7, 'MIME-Version' ],
64             content_type => [ 8, 'Content-Type' ],
65             content_transfer_encoding => [ 9, 'Content-Transfer-Encoding' ],
66             plural_forms => [ 10, 'Plural-Forms' ], } };
67              
68             has 'localedir' => is => 'ro', isa => $LocaleDir, coerce => TRUE,
69             default => NUL;
70              
71             has '+result_source_attributes' =>
72             default => sub { {
73             mo => {
74             attributes => [ qw( msgid_plural msgstr ) ],
75             defaults => { msgstr => [], }, },
76             po => {
77             attributes =>
78             [ qw( translator_comment extracted_comment reference flags
79             previous msgctxt msgid msgid_plural msgstr ) ],
80             defaults => { 'flags' => [], 'msgstr' => [], },
81             label_attr => 'labels',
82             }, } };
83              
84             has '+storage_class' => default => '+File::Gettext::Storage::PO';
85              
86             has 'source_name' => is => 'ro', isa => $SourceType,
87             default => 'po', trigger => TRUE;
88              
89             # Private methods
90             my $_is_file_or_log_debug = sub {
91             my ($self, $path) = @_;
92              
93             $path->exists or ($self->log->debug( 'Path '.$path->pathname.' not found' )
94             and return FALSE);
95             $path->is_file or ($self->log->debug( 'Path '.$path->pathname.' not a file' )
96             and return FALSE);
97              
98             return TRUE;
99             };
100              
101             # Construction
102             around 'BUILDARGS' => sub {
103             my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args );
104              
105             my $builder = $attr->{builder} or return $attr;
106             my $config = $builder->can( 'config' ) ? $builder->config : {};
107             my $keys = [ 'gettext_catagory', 'localedir' ];
108              
109             merge_attributes $attr, $builder, $keys;
110             merge_attributes $attr, $config, $keys;
111              
112             return $attr;
113             };
114              
115             around 'source' => sub {
116             my ($orig, $self) = @_; return $orig->( $self, $self->source_name );
117             };
118              
119             around 'resultset' => sub {
120             my ($orig, $self) = @_; return $orig->( $self, $self->source_name );
121             };
122              
123             around 'load' => sub {
124             my ($orig, $self, $lang, @files) = @_;
125              
126             my @paths = grep { $self->$_is_file_or_log_debug( $_ ) }
127             map { $self->object_file( $lang, $_ ) } @files;
128              
129             not $paths[ 0 ] and not $self->path and return {};
130              
131             my $data = $orig->( $self, @paths );
132             my $po_header = exists $data->{po_header}
133             ? $data->{po_header}->{msgstr} // {} : {};
134             my $plural_func;
135              
136             # This is here because of the code ref. Cannot serialize (cache) a code ref
137             # Determine plural rules. The leading and trailing space is necessary
138             # to be able to match against word boundaries.
139             if (exists $po_header->{plural_forms}) {
140             my $code = SPC.$po_header->{plural_forms}.SPC;
141              
142             $code =~ s{ ([^_a-zA-Z0-9] | \A) ([_a-z][_A-Za-z0-9]*)
143             ([^_a-zA-Z0-9]) }{$1\$$2$3}gmsx;
144             $code = "sub { my \$n = shift; my (\$plural, \$nplurals);
145             $code;
146             return (\$nplurals, \$plural ? \$plural : 0); }";
147              
148             # Now try to evaluate the code. There is no need to run the code in
149             # a Safe compartment. The above substitutions should have destroyed
150             # all evil code. Corrections are welcome!
151             $plural_func = eval $code; ## no critic
152             $EVAL_ERROR and $plural_func = undef;
153             }
154              
155             # Default is Germanic plural (which is incorrect for French).
156             $data->{plural_func} = $plural_func // sub { (2, shift > 1) };
157              
158             return $data;
159             };
160              
161             sub _trigger_source_name {
162 1     1   139 my ($self, $source) = @_;
163              
164 1 50       61 $source eq 'mo' and $self->storage_class( '+File::Gettext::Storage::MO' );
165 1 50       87 $source eq 'po' and $self->storage_class( '+File::Gettext::Storage::PO' );
166              
167 1         36 return;
168             }
169              
170             # Public methods
171             sub object_file {
172 16     16 1 421 my ($self, $lang, $file) = @_;
173              
174 16 50       61 $lang or throw Unspecified, [ 'language' ];
175 16 50       42 $file or throw Unspecified, [ 'language file name' ];
176              
177 16         71 my $dir = $self->localedir; my $extn = $self->storage->extn;
  16         396  
178              
179 16 50       4536 length $self->gettext_catagory or return $dir->catfile( $lang, $file.$extn );
180              
181 16         101 return $dir->catfile( $lang, $self->gettext_catagory, $file.$extn );
182             }
183              
184             sub set_path {
185 10     10 1 2549 my $self = shift; return $self->path( $self->object_file( @_ ) );
  10         60  
186             }
187              
188             1;
189              
190             __END__