1#!/usr/bin/perl
2#
3# $Id: Config.pm 877 2010-04-23 11:55:46Z calle $
4#
5# Copyright (c) 2007 .SE (The Internet Infrastructure Foundation).
6#                    All rights reserved.
7#
8# Redistribution and use in source and binary forms, with or without
9# modification, are permitted provided that the following conditions
10# are met:
11# 1. Redistributions of source code must retain the above copyright
12#    notice, this list of conditions and the following disclaimer.
13# 2. Redistributions in binary form must reproduce the above copyright
14#    notice, this list of conditions and the following disclaimer in the
15#    documentation and/or other materials provided with the distribution.
16#
17# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
18# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
21# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
22# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
23# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
24# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
25# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
27# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28#
29######################################################################
30package DNSCheck::Config;
31
32require 5.008;
33use strict;
34use warnings;
35
36our $SVN_VERSION = '$Revision: 877 $';
37
38use Config;
39use File::Spec::Functions;
40use Sys::Hostname;
41use YAML 'LoadFile';
42use Carp;
43use Cwd;
44use FindBin;
45use List::Util qw(first);
46use Storable qw(dclone);
47
48sub new {
49    my $proto = shift;
50    my $class = ref($proto) || $proto;
51    my $self  = {};
52    bless $self, $proto;
53
54    my %arg = @_;
55
56    $self->{configdir} = catfile($Config{'siteprefix'}, 'share/dnscheck');
57    $self->{configdir} = $arg{'configdir'} if defined($arg{'configdir'});
58
59    $self->{sitedir} = $self->{configdir};
60    $self->{sitedir} = $arg{'sitedir'} if defined($arg{'sitedir'});
61
62    my $configfile = _findfile('config.yaml', $self->{configdir});
63    $configfile = $arg{'configfile'} if defined($arg{'configfile'});
64
65    unless (-r $configfile) {
66        croak "Configuration file $configfile not readable.";
67    }
68
69    my $policyfile = _findfile('policy.yaml', $self->{configdir});
70    $policyfile = $arg{'policyfile'} if defined($arg{'policyfile'});
71
72    my $siteconfigfile = _findfile('site_config.yaml', $self->{sitedir});
73    $siteconfigfile = $arg{'siteconfigfile'} if defined($arg{'siteconfigfile'});
74
75    my $sitepolicyfile = _findfile('site_policy.yaml', $self->{sitedir});
76    $sitepolicyfile = $arg{'sitepolicyfile'} if defined($arg{'sitepolicyfile'});
77
78    my $localefile;
79    $localefile = $arg{'localefile'} if defined($arg{'localefile'});
80    if (defined($arg{'locale'}) && !defined($localefile)) {
81        $localefile = _findfile($arg{'locale'} . '.yaml',
82            catfile($self->{configdir}, 'locale'));
83    }
84
85    $self->{'configfile'}     = $configfile;
86    $self->{'policyfile'}     = $policyfile;
87    $self->{'siteconfigfile'} = $siteconfigfile;
88    $self->{'sitepolicyfile'} = $sitepolicyfile;
89    $self->{'localefile'}     = $localefile;
90
91    my $cfdata = LoadFile($configfile);
92    my $pfdata;
93    $pfdata = LoadFile($policyfile) if -r $policyfile;
94    my $scfdata;
95    $scfdata = LoadFile($siteconfigfile) if -r $siteconfigfile;
96    my $spfdata;
97    $spfdata = LoadFile($sitepolicyfile) if -r $sitepolicyfile;
98
99    my $lfdata;
100    $lfdata = LoadFile($localefile)
101      if (defined($localefile) and -r $localefile);
102
103    _hashrefcopy($self, $cfdata)  if defined($cfdata);
104    _hashrefcopy($self, $scfdata) if defined($scfdata);
105    _hashrefcopy($self, $pfdata)  if defined($pfdata);
106    _hashrefcopy($self, $spfdata) if defined($pfdata);
107
108    $self->{locale} = $lfdata;
109
110    _hashrefcopy($self, $arg{extras})
111      if (defined($arg{extras}) && (ref($arg{extras}) eq 'HASH'));
112
113    # Special cases
114    $self->{'hostname'} ||= hostname;
115    $self->{'logging'}{'interactive'} = 1 if $arg{'interactive'};
116
117    return $self;
118}
119
120sub get {
121    my $self = shift;
122    my ($key) = @_;
123
124    my $res = $self->{$key};
125    if (ref($res)) {
126        $res = dclone($res);
127    }
128
129    return $res;
130}
131
132sub put {
133    my $self = shift;
134
135    my ($key, $value) = @_;
136    $self->{$key} = $value;
137
138    return $value;
139}
140
141sub should_run {
142    my $self = shift;
143
144    my (undef, undef, undef, $subroutine) = caller(1);
145
146    if ($self->get("disable") and $subroutine =~ /^DNSCheck::Test::(.*)$/) {
147        my ($module, $test) = map { lc($_) } split('::', $1, 2);
148
149        return !$self->get("disable")->{$module}{$test};
150    } else {
151        return 1;
152    }
153}
154
155###
156### Non-public functions below here
157###
158
159sub _findfile {
160    my ($file, $prio) = @_;
161
162    my $path = first { -e $_ }
163    map { catfile($_, $file) } ($prio, getcwd(), $FindBin::Bin);
164
165    if (defined($path)) {
166        return $path;
167    } else {
168        return $file;
169    }
170
171}
172
173sub _hashrefcopy {
174    my ($target, $source) = @_;
175
176    foreach my $pkey (keys %{$source}) {
177        $target->{$pkey} = {} unless defined($target->{$pkey});
178
179        if (ref($source->{$pkey}) eq 'HASH') {
180
181    # Hash slice assignment to copy all keys under the $pkey top-level key.
182    # We don't just copy the entire hash since a site file may have changed only
183    # some of the keys in it.
184            @{ $target->{$pkey} }{ keys %{ $source->{$pkey} } } =
185              values %{ $source->{$pkey} };
186        } else {
187            $target->{$pkey} = $source->{$pkey};
188        }
189    }
190}
191
1921;
193
194=head1 NAME
195
196DNSCheck::Config - Read config files and make their contents available to
197other modules.
198
199=head1 DESCRIPTION
200
201Reads any config files, specified and/or default ones, stores their contents
202and provides methods that other modules can use to fetch them.
203
204There are two distinct classes of configuration information, that reside in
205separate files. There is I<configuration>, which modifies how things run. This
206is, for example, network timeouts, database connection information, file paths
207and such. In addition to this there is I<policy>, which specifies things about
208the tests that get run. Most importantly, the policy information specifies the
209reported severity level of various test failures.
210
211By default, C<DNSCheck::Config> will look for four different files:
212F<policy.yaml>, F<config.yaml>, F<site_policy.yaml> and F<site_config.yaml>.
213Only the first two exist by default. If the second two exist, they will
214override values in their respective non-site file. Local changes should go in
215the site files, since the default files will get overwritten when a new
216DNSCheck version is installed.
217
218These four files will be looked for in a number of places: a config directory,
219the current working directory (as determined by the Cwd module) and the
220directory where the running script file is stored (as determined by the
221FindBin module). By default, the config directory is F<share/dnscheck> under
222the root directory for the Perl installation. This can be changed via the
223C<configdir> (for F<config.yaml> and F<policy.yaml>) and C<sitedir> (for
224F<site_config.yalm> and F<site_policy.yaml>) parameters.
225
226The default lookup of a file is disregarded if the parameter giving the full
227path to that file is used.
228
229There is no protection against having the same keys in the configuration and
230policy files. The configuration/policy distinction is entirely for human use,
231and if they want to put everything in the same bucket they're perfectly
232welcome to do so.
233
234=head1 METHODS
235
236=over
237
238=item ->new(parameter => $value)
239
240The C<new> method creates a new C<DNSCheck::Config> object. It takes named
241parameters in the perl/Tk style (but without the initial dashes).
242
243The available parameters are these:
244
245=over
246
247=item configdir
248
249The path to the directory in which the module should look for configuration
250and policy files.
251
252=item sitedir
253
254The path to the directory where the site configuration files are. By default the same as F<configdir>.
255
256=item configfile
257
258The full path to the configuration file.
259
260=item siteconfigfile
261
262The full path to the site configuration file.
263
264=item policyfile
265
266The full path to the policy file.
267
268=item sitepolicyfile
269
270The full path to the site policy file.
271
272=item locale
273
274The locale to be used for messages. This is supposed to be only a string with
275the locale, for example "en" or "sv". The actual filename will be figured out
276from that.
277
278=item localefile
279
280The full path to the actual YAML file holding the locale information to be used.
281
282=item interactive
283
284If this key is a true value, the logger object will be set to print entries to
285stdout as they are added, rather than store them for future use.
286
287=item extras
288
289A hashref with random stuff that'll be copied to the Config object.
290
291=back
292
293=item ->get($key)
294
295Simply returns whatever got read from the configuration or policy files under
296the given key.
297
298=back
299
300=cut
301