File Coverage

lib/File/Gettext/Storage.pm
Criterion Covered Total %
statement 81 81 100.0
branch 11 20 55.0
condition 2 6 33.3
subroutine 17 17 100.0
pod 6 6 100.0
total 117 130 90.0


line stmt bran cond sub pod time code
1             package File::Gettext::Storage;
2              
3 1     1   4 use namespace::autoclean;
  1         1  
  1         6  
4              
5 1     1   64 use File::Basename qw( basename );
  1         1  
  1         67  
6 1     1   4 use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE NUL TRUE );
  1         2  
  1         90  
7 1     1   7 use File::DataClass::Functions qw( is_stale merge_file_data throw );
  1         7  
  1         63  
8 1     1   5 use File::DataClass::Types qw( Object );
  1         2  
  1         6  
9 1     1   580 use File::Gettext;
  1         2  
  1         17  
10 1     1   4 use Try::Tiny;
  1         1  
  1         61  
11 1     1   4 use Unexpected::Functions qw( NothingUpdated Unspecified );
  1         1  
  1         10  
12 1     1   350 use Moo;
  1         2  
  1         5  
13              
14             has 'gettext' => is => 'lazy', isa => Object,
15 1     1   573 builder => sub { File::Gettext->new( builder => $_[ 0 ]->schema ) };
16              
17             has 'schema' => is => 'ro', isa => Object, required => TRUE,
18             handles => [ qw( cache language ) ], weak_ref => TRUE;
19              
20             has 'storage' => is => 'ro', isa => Object, required => TRUE,
21             handles => [ qw( extn meta_pack meta_unpack
22             read_file txn_do validate_params ) ];
23              
24             # Private functions
25             my $_get_attributes = sub {
26             my ($condition, $source) = @_;
27              
28             return grep { not m{ \A _ }msx
29             and $_ ne 'id' and $_ ne 'name'
30             and $condition->( $_ ) } @{ $source->attributes || [] };
31             };
32              
33             # Private methods
34             my $_extn = sub {
35             my ($self, $path) = @_; $path //= NUL;
36              
37             my $extn = (split m{ \. }mx, ("${path}" // NUL))[ -1 ];
38              
39             return $extn ? ".${extn}" : $self->extn;
40             };
41              
42             my $_gettext = sub {
43             my ($self, $path) = @_; $path or throw Unspecified, [ 'path name' ];
44              
45             my $gettext = $self->gettext; my $extn = $self->$_extn( $path );
46              
47             $gettext->set_path( $self->language, basename( "${path}", $extn ) );
48              
49             return $gettext;
50             };
51              
52             my $_create_or_update = sub {
53             my ($self, $path, $result, $updating) = @_;
54              
55             my $source = $result->can( 'result_source' )
56             ? $result->result_source : $result->_resultset->source;
57             my $condition = sub { not $source->language_dependent->{ $_[ 0 ] } };
58             my $updated = $self->storage->create_or_update
59             ( $path, $result, $updating, $condition );
60             my $rs = $self->$_gettext( $path )->resultset;
61             my $element = $source->name;
62              
63             $condition = sub { $source->language_dependent->{ $_[ 0 ] } };
64              
65             for my $attr_name ($_get_attributes->( $condition, $source )) {
66             my $msgstr = $result->$attr_name() or next;
67             my $attrs = { msgctxt => "${element}.${attr_name}",
68             msgid => $result->name,
69             msgstr => [ $msgstr ], };
70              
71             $attrs->{name} = $rs->storage->make_key( $attrs ); my $name;
72              
73             try {
74             $name = $updating ? $rs->create_or_update( $attrs )
75             : $rs->create( $attrs );
76             }
77             catch { $_->class ne NothingUpdated and throw $_ };
78              
79             $updated ||= $name ? TRUE : FALSE;
80             }
81              
82             $updating and not $updated and throw NothingUpdated, level => 4;
83             $updated and $path->touch;
84             return $updated;
85             };
86              
87             my $_get_key_and_newest = sub {
88             my ($self, $paths) = @_;
89              
90             my $gettext = $self->gettext; my $key; my $newest = 0; my $valid = TRUE;
91              
92             for my $path (grep { length } map { "${_}" } @{ $paths }) {
93             $key .= $key ? "~${path}" : $path;
94              
95             my $mtime = $self->cache->get_mtime( $path );
96              
97             if ($mtime) { $mtime > $newest and $newest = $mtime }
98             else { $valid = FALSE }
99              
100             my $file = basename( "${path}", $self->$_extn( $path ) );
101             my $lang_file = $gettext->object_file( $self->language, $file );
102              
103             if (defined ($mtime = $self->cache->get_mtime( "${lang_file}" ))) {
104             if ($mtime) {
105             $key .= $key ? "~${lang_file}" : "${lang_file}";
106             $mtime > $newest and $newest = $mtime;
107             }
108             }
109             else {
110             if ($lang_file->exists and $lang_file->is_file) {
111             $key .= $key ? "~${lang_file}" : "${lang_file}"; $valid = FALSE;
112             }
113             else { $self->cache->set_mtime( "${lang_file}", 0 ) }
114             }
115             }
116              
117             return ($key, $valid ? $newest : undef);
118             };
119              
120             my $_load_gettext = sub {
121             my ($self, $data, $path) = @_;
122              
123             my $gettext = $self->$_gettext( $path ); $gettext->path->is_file or return;
124              
125             my $gettext_data = $gettext->load->{ $gettext->source_name };
126              
127             for my $key (keys %{ $gettext_data }) {
128             my ($msgctxt, $msgid) = $gettext->storage->decompose_key( $key );
129             my ($element, $attr_name) = split m{ [\.] }msx, $msgctxt, 2;
130              
131             ($element and $attr_name and $msgid) or next;
132              
133             $data->{ $element }->{ $msgid }->{ $attr_name }
134             = $gettext_data->{ $key }->{msgstr}->[ 0 ];
135             }
136              
137             return $gettext->path->stat->{mtime};
138             };
139              
140             # Public methods
141             sub delete {
142 2     2 1 1325 my ($self, $path, $result) = @_;
143              
144 2 50       24 my $source = $result->can( 'result_source' )
145             ? $result->result_source : $result->_resultset->source;
146 2     4   14 my $condition = sub { $source->language_dependent->{ $_[ 0 ] } };
  4         34  
147 2         25 my $deleted = $self->storage->delete( $path, $result );
148 2         8815 my $rs = $self->$_gettext( $path )->resultset;
149 2         457 my $element = $source->name;
150              
151 2         9 for my $attr_name ($_get_attributes->( $condition, $source )) {
152 2         22 my $attrs = { msgctxt => "${element}.${attr_name}",
153             msgid => $result->name, };
154 2         133 my $name = $rs->storage->make_key( $attrs );
155              
156 2         24 $name = $rs->delete( { name => $name, optional => TRUE } );
157 2 0 33     3615 $deleted ||= $name ? TRUE : FALSE;
158             }
159              
160 2         22 return $deleted;
161             }
162              
163             sub dump {
164 1     1 1 611 my ($self, $path, $data) = @_; $self->validate_params( $path, TRUE );
  1         18  
165              
166 1         82 my $gettext = $self->$_gettext( $path );
167 1 50       130 my $gettext_data = $gettext->path->exists ? $gettext->load : {};
168              
169 1         74 for my $source (values %{ $self->schema->source_registrations }) {
  1         40  
170 1         14 my $element = $source->name; my $element_ref = $data->{ $element };
  1         3  
171              
172 1         2 for my $msgid (keys %{ $element_ref }) {
  1         4  
173 8 50       7 for my $attr_name (keys %{ $source->language_dependent || {} }) {
  8         23  
174 8 100       18 my $msgstr = delete $element_ref->{ $msgid }->{ $attr_name }
175             or next;
176 1         7 my $attrs = { msgctxt => "${element}.${attr_name}",
177             msgid => $msgid,
178             msgstr => [ $msgstr ] };
179 1         20 my $key = $gettext->storage->make_key( $attrs );
180              
181 1         8 $gettext_data->{ $gettext->source_name }->{ $key } = $attrs;
182             }
183             }
184             }
185              
186 1         11 $gettext->dump( { data => $gettext_data } );
187              
188 1         1660 return $self->storage->dump( $path, $data );
189             }
190              
191             sub insert {
192 3     3 1 37085 return $_[ 0 ]->$_create_or_update( $_[ 1 ], $_[ 2 ], FALSE );
193             }
194              
195             sub load {
196 6 50   6 1 1497 my ($self, @paths) = @_; $paths[ 0 ] or return {};
  6         34  
197              
198 6         394 my ($key, $newest) = $self->$_get_key_and_newest( \@paths );
199 6         170 my ($data, $meta) = $self->cache->get( $key );
200 6         1514 my $cache_mtime = $self->meta_unpack( $meta );
201              
202 6 100       646 not is_stale $data, $cache_mtime, $newest and return $data;
203              
204 4         87 $data = {}; $newest = 0;
  4         27  
205              
206 4         17 for my $path (@paths) {
207 4         71 my ($red, $path_mtime) = $self->read_file( $path, FALSE );
208              
209 4         17604 merge_file_data $data, $red;
210 4 50       78 $path_mtime > $newest and $newest = $path_mtime;
211 4         15 $path_mtime = $self->$_load_gettext( $data, $path );
212 4 50 33     1217 $path_mtime and $path_mtime > $newest and $newest = $path_mtime;
213             }
214              
215 4         143 $self->cache->set( $key, $data, $self->meta_pack( $newest ) );
216              
217 4         2850 return $data;
218             }
219              
220             sub select {
221 5     5 1 35030 my ($self, $path, $element) = @_; $self->validate_params( $path, $element );
  5         118  
222              
223 5         880 my $data = $self->load( $path );
224              
225 5 50       167 return exists $data->{ $element } ? $data->{ $element } : {};
226             }
227              
228             sub update {
229 1     1 1 1217 return $_[ 0 ]->$_create_or_update( $_[ 1 ], $_[ 2 ], TRUE );
230             }
231              
232             1;
233              
234             __END__