1# ABSTRACT: Config role for Dancer2 core objects
2package Dancer2::Core::Role::ConfigReader;
3$Dancer2::Core::Role::ConfigReader::VERSION = '0.301004';
4use Moo::Role;
5
6use File::Spec;
7use Config::Any;
8use Hash::Merge::Simple;
9use Carp 'croak';
10use Module::Runtime 'require_module';
11
12use Dancer2::Core::Factory;
13use Dancer2::Core;
14use Dancer2::Core::Types;
15use Dancer2::FileUtils 'path';
16
17with 'Dancer2::Core::Role::HasLocation';
18
19has default_config => (
20    is      => 'ro',
21    isa     => HashRef,
22    lazy    => 1,
23    builder => '_build_default_config',
24);
25
26has 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.
37has 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
48has config => (
49    is      => 'ro',
50    isa     => HashRef,
51    lazy    => 1,
52    builder => '_build_config',
53);
54
55has environment => (
56    is      => 'ro',
57    isa     => Str,
58    lazy    => 1,
59    builder => '_build_environment',
60);
61
62has config_files => (
63    is      => 'ro',
64    lazy    => 1,
65    isa     => ArrayRef,
66    builder => '_build_config_files',
67);
68
69has local_triggers => (
70    is      => 'ro',
71    isa     => HashRef,
72    default => sub { +{} },
73);
74
75has 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
103sub _build_default_config { +{} }
104
105sub _build_environment { 'development' }
106
107sub _build_config_files {
108    my ($self) = @_;
109
110    my $location = $self->config_location;
111    # an undef location means no config files for the caller
112    return [] unless defined $location;
113
114    my $running_env = $self->environment;
115    my @available_exts = Config::Any->extensions;
116    my @files;
117
118    my @exts = @available_exts;
119    if (my $ext = $ENV{DANCER_CONFIG_EXT}) {
120        if (grep { $ext eq $_ } @available_exts) {
121            @exts = $ext;
122            warn "Only looking for configs ending in '$ext'\n"
123                if $ENV{DANCER_CONFIG_VERBOSE};
124        } else {
125            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    foreach my $file ( [ $location, "config" ],
133        [ $self->environments_location, $running_env ] )
134    {
135        foreach my $ext (@exts) {
136            my $path = path( $file->[0], $file->[1] . ".$ext" );
137            next if !-r $path;
138
139            # Look for *_local.ext files
140            my $local = path( $file->[0], $file->[1] . "_local.$ext" );
141            push @files, $path, ( -r $local ? $local : () );
142        }
143    }
144
145    return \@files;
146}
147
148sub _build_config {
149    my ($self) = @_;
150
151    my $location = $self->config_location;
152    my $default  = $self->default_config;
153
154    my $config = Hash::Merge::Simple->merge(
155        $default,
156        map {
157            warn "Merging config file $_\n" if $ENV{DANCER_CONFIG_VERBOSE};
158            $self->load_config_file($_)
159        } @{ $self->config_files }
160    );
161
162    $config = $self->_normalize_config($config);
163    return $config;
164}
165
166sub _set_config_entries {
167    my ( $self, @args ) = @_;
168    my $no = scalar @args;
169    while (@args) {
170        $self->_set_config_entry( shift(@args), shift(@args) );
171    }
172    return $no;
173}
174
175sub _set_config_entry {
176    my ( $self, $name, $value ) = @_;
177
178    $value = $self->_normalize_config_entry( $name, $value );
179    $value = $self->_compile_config_entry( $name, $value, $self->config );
180    $self->config->{$name} = $value;
181}
182
183sub _normalize_config {
184    my ( $self, $config ) = @_;
185
186    foreach my $key ( keys %{$config} ) {
187        my $value = $config->{$key};
188        $config->{$key} = $self->_normalize_config_entry( $key, $value );
189    }
190    return $config;
191}
192
193sub _compile_config {
194    my ( $self, $config ) = @_;
195
196    foreach my $key ( keys %{$config} ) {
197        my $value = $config->{$key};
198        $config->{$key} =
199          $self->_compile_config_entry( $key, $value, $config );
200    }
201    return $config;
202}
203
204sub settings { shift->config }
205
206sub setting {
207    my $self = shift;
208    my @args = @_;
209
210    return ( scalar @args == 1 )
211      ? $self->settings->{ $args[0] }
212      : $self->_set_config_entries(@args);
213}
214
215sub has_setting {
216    my ( $self, $name ) = @_;
217    return exists $self->config->{$name};
218}
219
220sub load_config_file {
221    my ( $self, $file ) = @_;
222    my $config;
223
224    eval {
225        my @files = ($file);
226        my $tmpconfig =
227          Config::Any->load_files( { files => \@files, use_ext => 1 } )->[0];
228        ( $file, $config ) = %{$tmpconfig} if defined $tmpconfig;
229    };
230    if ( my $err = $@ || ( !$config ) ) {
231        croak "Unable to parse the configuration file: $file: $@";
232    }
233
234    # TODO handle mergeable entries
235    return $config;
236}
237
238# private
239
240my $_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
259sub _normalize_config_entry {
260    my ( $self, $name, $value ) = @_;
261    $value = $_normalizers->{$name}->($value)
262      if exists $_normalizers->{$name};
263    return $value;
264}
265
266sub _compile_config_entry {
267    my ( $self, $name, $value, $config ) = @_;
268
269    my $trigger = exists $self->local_triggers->{$name} ?
270                         $self->local_triggers->{$name} :
271                         $self->global_triggers->{$name};
272
273    defined $trigger or return $value;
274
275    return $trigger->( $self, $value, $config );
276}
277
2781;
279
280__END__
281
282=pod
283
284=encoding UTF-8
285
286=head1 NAME
287
288Dancer2::Core::Role::ConfigReader - Config role for Dancer2 core objects
289
290=head1 VERSION
291
292version 0.301004
293
294=head1 DESCRIPTION
295
296Provides a C<config> attribute that feeds itself by finding and parsing
297configuration files.
298
299Also provides a C<setting()> method which is supposed to be used by externals to
300read/write config entries.
301
302=head1 ATTRIBUTES
303
304=head2 location
305
306Absolute path to the directory where the server started.
307
308=head2 config_location
309
310Gets the location from the configuration. Same as C<< $object->location >>.
311
312=head2 environments_location
313
314Gets the directory were the environment files are stored.
315
316=head2 config
317
318Returns the whole configuration.
319
320=head2 environments
321
322Returns the name of the environment.
323
324=head2 config_files
325
326List of all the configuration files.
327
328=head1 METHODS
329
330=head2 settings
331
332Alias for config. Equivalent to <<$object->config>>.
333
334=head2 setting
335
336Get or set an element from the configuration.
337
338=head2 has_setting
339
340Verifies that a key exists in the configuration.
341
342=head2 load_config_file
343
344Load the configuration files.
345
346=head1 AUTHOR
347
348Dancer Core Developers
349
350=head1 COPYRIGHT AND LICENSE
351
352This software is copyright (c) 2021 by Alexis Sukrieh.
353
354This is free software; you can redistribute it and/or modify it under
355the same terms as the Perl 5 programming language system itself.
356
357=cut
358