-
Notifications
You must be signed in to change notification settings - Fork 25
/
Config.pm
315 lines (244 loc) · 7.87 KB
/
Config.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
#!/usr/bin/perl
#
# mySociety/Config.pm:
# Very simple config parser. Our config files are sort of cod-PHP.
#
# Copyright (c) 2004 UK Citizens Online Democracy. All rights reserved.
# WWW: http://www.mysociety.org/
package mySociety::Config;
use strict;
use IO::Handle;
use IO::Pipe;
use Error qw(:try);
use Data::Dumper;
use POSIX ();
use YAML ();
=head1 NAME
mySociety::Config
=head1 SYNOPSIS
mySociety::Config::set_file('../conf/general');
my $opt = mySociety::Config::get('CONFIG_VARIABLE', DEFAULT_VALUE);
=head1 DESCRIPTION
Parse config files (written in a sort of cod-php, using
define(OPTION_VALUE_NAME, "value of option");
to define individual elements.
=head1 FUNCTIONS
=over 4
=cut
my $php_path;
# find_php
# Try to locate the PHP binary in various sensible places.
sub find_php () {
$ENV{PATH} ||= '/bin:/usr/bin';
foreach my $dir (split(/:/, $ENV{PATH}),
qw(/usr/local/bin /usr/bin /software/bin /opt/bin /opt/php/bin)) {
foreach my $name (qw(php php-cgi)) {
return "$dir/$name" if (-x "$dir/$name");
}
}
throw Error::Simple "unable to locate PHP binary, needed to read config file";
}
# read_config_from_yaml
# Read configuration data from the named YAML configuration file
sub read_config_from_yaml($) {
my ($f) = @_;
my $conf = YAML::LoadFile($f);
if (ref($conf) ne "HASH") {
throw Error::Simple "$f: The YAML file must represent an object (a.k.a. hash, dict, map)";
}
return $conf;
}
# read_config_from_php
# Read configuration data from the named PHP configuration file
sub read_config_from_php($) {
my ($f) = @_;
if (! -r $f) {
throw Error::Simple "$f: permission denied trying to read config file (maybe you're not running as the correct user?)";
}
my $old_SIGCHLD = $SIG{CHLD};
$SIG{CHLD} = sub { };
# We need to find the PHP binary.
$php_path ||= find_php();
# This is a bit miserable. We ought to use IPC::Open2 or similar, but
# can't because of a nasty interaction with the tied filehandles which
# FCGI.pm uses.
my ($inr, $inw, $outr, $outw);
$inr = new IO::Handle();
$inw = new IO::Handle();
$outr = new IO::Handle();
$outw = new IO::Handle();
my $p1 = new IO::Pipe($outr, $outw);
my $p2 = new IO::Pipe($inr, $inw);
my $pid = fork();
throw Error::Simple "fork: $!" unless (defined($pid));
if ($pid == 0) {
# Delete everything from the environment other than our special
# variable to give PHP the config file name. We don't want PHP to pick
# up other information from our environment and turn into an FCGI
# server or something.
%ENV = ( MYSOCIETY_CONFIG_FILE_PATH => $f );
$inw->close();
$outr->close();
POSIX::close(0);
POSIX::close(1);
POSIX::dup2($inr->fileno(), 0);
POSIX::dup2($outw->fileno(), 1);
$inr->close();
$outw->close();
exec($php_path) or throw Error::Simple "$php_path: exec: $!";
}
$inr->close();
$outw->close();
$inw->print(<<'EOF');
<?php
$b = get_defined_constants();
require(getenv("MYSOCIETY_CONFIG_FILE_PATH"));
$a = array_diff_assoc(get_defined_constants(), $b);
print "start_of_options\n";
foreach ($a as $k => $v) {
print preg_replace("/^OPTION_/", "", $k); /* strip off "OPTION_" if there */
print "\0";
print $v;
print "\0";
}
?>
EOF
$inw->close();
# skip any header material
my $line;
while (defined($line = $outr->getline())) {
last if ($line eq "start_of_options\n");
}
if (!defined($line)) {
if ($outr->error()) {
throw Error::Simple "$php_path: $f: $!";
} else {
throw Error::Simple "$php_path: $f: no option output from subprocess";
}
}
# read remainder
my $buf = join('', $outr->getlines());
$outr->close();
my @vals = split(/\0/, $buf, -1); # option values may be empty
pop(@vals); # The buffer ends "\0" so there's always a trailing empty value
# at the end of the buffer. I love perl! Perl is my friend!
throw Error::Simple "$php_path: $f: bad option output from subprocess" if (scalar(@vals) % 2);
waitpid($pid, 0);
if ($?) {
if ($? & 127) {
throw Error::Simple "$php_path: killed by signal " . ($? & 127);
} else {
throw Error::Simple "$php_path: exited with failure status " . ($? >> 8);
}
}
# Restore signal handler.
$old_SIGCHLD ||= 'DEFAULT';
$SIG{CHLD} = $old_SIGCHLD;
my %config = @vals;
return \%config;
}
=item read_config FILE [DEFAULTS]
Read configuration from FILE.
If the filename contains .yml, or FILE.yml exists, that file is parsed as
a YAML object which is returned. Otherwise FILE is parsed by PHP, and any defines
are extracted as config values.
For PHP configuration files only, "OPTION_" is removed from any names
beginning with that.
If specified, values from DEFAULTS are merged.
=cut
sub read_config ($;$) {
my ($f, $defaults) = @_;
my $config;
if ($f =~ /\.yml/) {
$config = read_config_from_yaml($f);
} elsif (-f "$f.yml") {
if (-e $f) {
throw Error::Simple "Configuration error: both $f and $f.yml exist (remove one)";
}
$config = read_config_from_yaml("$f.yml");
} else {
$config = read_config_from_php($f);
}
if ($defaults) {
$config->{$_} = $defaults->{$_} foreach (keys %$defaults);
}
$config->{"CONFIG_FILE_NAME"} = $f;
return $config;
}
=item set_file FILENAME
Sets the default configuration file, used by mySociety::Config::get.
=cut
my $main_config_filename;
sub set_file ($) {
($main_config_filename) = @_;
}
=item load_default
Loads and caches default config file, as set with set_file. This
function is implicitly called by get and get_all.
=cut
my %cached_configs;
sub load_default() {
my $filename = $main_config_filename;
throw Error::Simple "Please call mySociety::Config::set_file to specify config file" if (!defined($filename));
if (!defined($cached_configs{$filename})) {
$cached_configs{$filename} = read_config($filename);
}
return $cached_configs{$filename};
}
=item get KEY [DEFAULT]
Returns the constants set for KEY from the configuration file specified in
set_config_file. The file is automatically loaded and cached. An exception is
thrown if the value isn't present and no DEFAULT is specified.
=cut
sub get ($;$) {
my ($key, $default) = @_;
my $config = load_default();
if (exists($config->{$key})) {
return $config->{$key};
} elsif (@_ == 2) {
return $default;
} else {
throw Error::Simple "No value for '$key' in '" . $config->{'CONFIG_FILE_NAME'} . "', and no default specified";
}
}
sub get_list {
my (%searches) = @_;
# example of usage get_list('startswith' => 'SMS');
# returns a ref to a hash of config values
my $config = load_default();
my $regexp = '';
if ($searches{'startswith'}) {
$regexp = qr/^$searches{'startswith'}/;
}
if ($searches{'endswith'}) {
$regexp = qr/$searches{'endswith'}$/;
}
if ($regexp) {
my $conf_subset = {};
foreach my $key (keys %$config) {
if ($key =~ $regexp) {
$conf_subset->{$key} = $config->{$key};
}
}
return $conf_subset;
} else {
return $config;
}
return {};
}
=item test_run/set
set allows you to change config variables at runtime. As this shouldn't
normally be allowed, and is only for the test suites, you have to call a
special function test_run first, to confirm you want to do this. set
then works as you'd expect, but must come after at least one get.
=cut
my $test_run;
sub test_run() {
$test_run = 1;
}
sub set($$) {
return unless $test_run;
my ($key, $value) = @_;
$cached_configs{$main_config_filename}{$key} = $value;
}
1;