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