File Coverage

blib/lib/Dancer2/Core/Role/ConfigReader.pm
Criterion Covered Total %
statement 93 105 88.5
branch 18 26 69.2
condition 2 3 66.6
subroutine 22 24 91.6
pod 4 4 100.0
total 139 162 85.8


line stmt bran cond sub pod time code
1             # ABSTRACT: Config role for Dancer2 core objects
2             package Dancer2::Core::Role::ConfigReader;
3             $Dancer2::Core::Role::ConfigReader::VERSION = '1.0.0';
4 145     145   93471 use Moo::Role;
  145         458  
  145         1064  
5              
6 145     145   65671 use File::Spec;
  145         459  
  145         3857  
7 145     145   74904 use Config::Any;
  145         1363271  
  145         5351  
8 145     145   68566 use Hash::Merge::Simple;
  145         74498  
  145         7439  
9 145     145   1237 use Carp 'croak';
  145         425  
  145         6809  
10 145     145   1113 use Module::Runtime 'require_module';
  145         540  
  145         962  
11              
12 145     145   6686 use Dancer2::Core::Factory;
  145         456  
  145         3300  
13 145     145   854 use Dancer2::Core;
  145         554  
  145         3074  
14 145     145   874 use Dancer2::Core::Types;
  145         397  
  145         1275  
15 145     145   1941572 use Dancer2::FileUtils 'path';
  145         485  
  145         249994  
16              
17             with 'Dancer2::Core::Role::HasLocation';
18              
19             has default_config => (
20             is => 'ro',
21             isa => HashRef,
22             lazy => 1,
23             builder => '_build_default_config',
24             );
25              
26             has config_location => (
27             is => 'ro',
28             isa => ReadableFilePath,
29             lazy => 1,
30             default => sub { $ENV{DANCER_CONFDIR} || $_[0]->location },
31             );
32              
33             # The type for this attribute is Str because we don't require
34             # an existing directory with configuration files for the
35             # environments. An application without environments is still
36             # valid and works.
37             has environments_location => (
38             is => 'ro',
39             isa => Str,
40             lazy => 1,
41             default => sub {
42             $ENV{DANCER_ENVDIR}
43             || File::Spec->catdir( $_[0]->config_location, 'environments' )
44             || File::Spec->catdir( $_[0]->location, 'environments' );
45             },
46             );
47              
48             has config => (
49             is => 'ro',
50             isa => HashRef,
51             lazy => 1,
52             builder => '_build_config',
53             );
54              
55             has environment => (
56             is => 'ro',
57             isa => Str,
58             lazy => 1,
59             builder => '_build_environment',
60             );
61              
62             has config_files => (
63             is => 'ro',
64             lazy => 1,
65             isa => ArrayRef,
66             builder => '_build_config_files',
67             );
68              
69             has local_triggers => (
70             is => 'ro',
71             isa => HashRef,
72             default => sub { +{} },
73             );
74              
75             has global_triggers => (
76             is => 'ro',
77             isa => HashRef,
78             default => sub {
79             my $triggers = {
80             traces => sub {
81             my ( $self, $traces ) = @_;
82             # Carp is already a dependency
83             $Carp::Verbose = $traces ? 1 : 0;
84             },
85             };
86              
87             my $runner_config = defined $Dancer2::runner
88             ? Dancer2->runner->config
89             : {};
90              
91             for my $global ( keys %$runner_config ) {
92             next if exists $triggers->{$global};
93             $triggers->{$global} = sub {
94             my ($self, $value) = @_;
95             Dancer2->runner->config->{$global} = $value;
96             }
97             }
98              
99             return $triggers;
100             },
101             );
102              
103 0     0   0 sub _build_default_config { +{} }
104              
105 36     36   911 sub _build_environment { 'development' }
106              
107             sub _build_config_files {
108 243     243   5557 my ($self) = @_;
109              
110 243         4048 my $location = $self->config_location;
111             # an undef location means no config files for the caller
112 243 50       3188 return [] unless defined $location;
113              
114 243         4071 my $running_env = $self->environment;
115 243         4772 my @available_exts = Config::Any->extensions;
116 243         1958082 my @files;
117              
118 243         974 my @exts = @available_exts;
119 243 50       1387 if (my $ext = $ENV{DANCER_CONFIG_EXT}) {
120 0 0       0 if (grep { $ext eq $_ } @available_exts) {
  0         0  
121 0         0 @exts = $ext;
122             warn "Only looking for configs ending in '$ext'\n"
123 0 0       0 if $ENV{DANCER_CONFIG_VERBOSE};
124             } else {
125 0         0 warn "DANCER_CONFIG_EXT environment variable set to '$ext' which\n" .
126             "is not recognized by Config::Any. Looking for config file\n" .
127             "using default list of extensions:\n" .
128             "\t@available_exts\n";
129             }
130             }
131              
132 243         7244 foreach my $file ( [ $location, "config" ],
133             [ $self->environments_location, $running_env ] )
134             {
135 486         17451 foreach my $ext (@exts) {
136 4860         21869 my $path = path( $file->[0], $file->[1] . ".$ext" );
137 4860 100       63841 next if !-r $path;
138              
139             # Look for *_local.ext files
140 141         1322 my $local = path( $file->[0], $file->[1] . "_local.$ext" );
141 141 100       2789 push @files, $path, ( -r $local ? $local : () );
142             }
143             }
144              
145 243         7162 return \@files;
146             }
147              
148             sub _build_config {
149 241     241   2217 my ($self) = @_;
150              
151 241         4327 my $location = $self->config_location;
152 241         21603 my $default = $self->default_config;
153              
154             my $config = Hash::Merge::Simple->merge(
155             $default,
156             map {
157 140 50       5069 warn "Merging config file $_\n" if $ENV{DANCER_CONFIG_VERBOSE};
158 140         766 $self->load_config_file($_)
159 241         16125 } @{ $self->config_files }
  241         4691  
160             );
161              
162 240         13517 $config = $self->_normalize_config($config);
163 240         1196 return $config;
164             }
165              
166             sub _set_config_entries {
167 146     146   540 my ( $self, @args ) = @_;
168 146         361 my $no = scalar @args;
169 146         555 while (@args) {
170 151         706 $self->_set_config_entry( shift(@args), shift(@args) );
171             }
172 146         230198 return $no;
173             }
174              
175             sub _set_config_entry {
176 151     151   496 my ( $self, $name, $value ) = @_;
177              
178 151         608 $value = $self->_normalize_config_entry( $name, $value );
179 151         3666 $value = $self->_compile_config_entry( $name, $value, $self->config );
180 151         5580 $self->config->{$name} = $value;
181             }
182              
183             sub _normalize_config {
184 241     241   1669 my ( $self, $config ) = @_;
185              
186 241         571 foreach my $key ( keys %{$config} ) {
  241         1213  
187 2362         3927 my $value = $config->{$key};
188 2362         4477 $config->{$key} = $self->_normalize_config_entry( $key, $value );
189             }
190 240         1063 return $config;
191             }
192              
193             sub _compile_config {
194 0     0   0 my ( $self, $config ) = @_;
195              
196 0         0 foreach my $key ( keys %{$config} ) {
  0         0  
197 0         0 my $value = $config->{$key};
198 0         0 $config->{$key} =
199             $self->_compile_config_entry( $key, $value, $config );
200             }
201 0         0 return $config;
202             }
203              
204 2     2 1 50 sub settings { shift->config }
205              
206             sub setting {
207 499     499 1 4294 my $self = shift;
208 499         1559 my @args = @_;
209              
210             return ( scalar @args == 1 )
211 499 100       3004 ? $self->settings->{ $args[0] }
212             : $self->_set_config_entries(@args);
213             }
214              
215             sub has_setting {
216 2     2 1 2546 my ( $self, $name ) = @_;
217 2         48 return exists $self->config->{$name};
218             }
219              
220             sub load_config_file {
221 140     140 1 533 my ( $self, $file ) = @_;
222 140         306 my $config;
223              
224 140         313 eval {
225 140         393 my @files = ($file);
226 140         1382 my $tmpconfig =
227             Config::Any->load_files( { files => \@files, use_ext => 1 } )->[0];
228 139 50       950321 ( $file, $config ) = %{$tmpconfig} if defined $tmpconfig;
  139         822  
229             };
230 140 100 66     6086 if ( my $err = $@ || ( !$config ) ) {
231 1         94 croak "Unable to parse the configuration file: $file: $@";
232             }
233              
234             # TODO handle mergeable entries
235 139         1843 return $config;
236             }
237              
238             # private
239              
240             my $_normalizers = {
241             charset => sub {
242             my ($charset) = @_;
243             return $charset if !length( $charset || '' );
244              
245             require_module('Encode');
246             my $encoding = Encode::find_encoding($charset);
247             croak
248             "Charset defined in configuration is wrong : couldn't identify '$charset'"
249             unless defined $encoding;
250             my $name = $encoding->name;
251              
252             # Perl makes a distinction between the usual perl utf8, and the strict
253             # utf8 charset. But we don't want to make this distinction
254             $name = 'utf-8' if $name eq 'utf-8-strict';
255             return $name;
256             },
257             };
258              
259             sub _normalize_config_entry {
260 2513     2513   4669 my ( $self, $name, $value ) = @_;
261             $value = $_normalizers->{$name}->($value)
262 2513 100       6510 if exists $_normalizers->{$name};
263 2512         5737 return $value;
264             }
265              
266             sub _compile_config_entry {
267 151     151   2661 my ( $self, $name, $value, $config ) = @_;
268              
269             my $trigger = exists $self->local_triggers->{$name} ?
270             $self->local_triggers->{$name} :
271 151 100       1462 $self->global_triggers->{$name};
272              
273 151 100       631 defined $trigger or return $value;
274              
275 93         536 return $trigger->( $self, $value, $config );
276             }
277              
278             1;
279              
280             __END__
281              
282             =pod
283              
284             =encoding UTF-8
285              
286             =head1 NAME
287              
288             Dancer2::Core::Role::ConfigReader - Config role for Dancer2 core objects
289              
290             =head1 VERSION
291              
292             version 1.0.0
293              
294             =head1 DESCRIPTION
295              
296             Provides a C<config> attribute that feeds itself by finding and parsing
297             configuration files.
298              
299             Also provides a C<setting()> method which is supposed to be used by externals to
300             read/write config entries.
301              
302             =head1 ATTRIBUTES
303              
304             =head2 location
305              
306             Absolute path to the directory where the server started.
307              
308             =head2 config_location
309              
310             Gets the location from the configuration. Same as C<< $object->location >>.
311              
312             =head2 environments_location
313              
314             Gets the directory were the environment files are stored.
315              
316             =head2 config
317              
318             Returns the whole configuration.
319              
320             =head2 environments
321              
322             Returns the name of the environment.
323              
324             =head2 config_files
325              
326             List of all the configuration files.
327              
328             =head1 METHODS
329              
330             =head2 settings
331              
332             Alias for config. Equivalent to <<$object->config>>.
333              
334             =head2 setting
335              
336             Get or set an element from the configuration.
337              
338             =head2 has_setting
339              
340             Verifies that a key exists in the configuration.
341              
342             =head2 load_config_file
343              
344             Load the configuration files.
345              
346             =head1 AUTHOR
347              
348             Dancer Core Developers
349              
350             =head1 COPYRIGHT AND LICENSE
351              
352             This software is copyright (c) 2023 by Alexis Sukrieh.
353              
354             This is free software; you can redistribute it and/or modify it under
355             the same terms as the Perl 5 programming language system itself.
356              
357             =cut