line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Copyright 2014-2016 - Giovanni Simoni |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# This file is part of PFT. |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# PFT is free software: you can redistribute it and/or modify it under the |
6
|
|
|
|
|
|
|
# terms of the GNU General Public License as published by the Free |
7
|
|
|
|
|
|
|
# Software Foundation, either version 3 of the License, or (at your |
8
|
|
|
|
|
|
|
# option) any later version. |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# PFT is distributed in the hope that it will be useful, but WITHOUT ANY |
11
|
|
|
|
|
|
|
# WARRANTY; without even the implied warranty of MERCHANTABILITY or |
12
|
|
|
|
|
|
|
# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
13
|
|
|
|
|
|
|
# for more details. |
14
|
|
|
|
|
|
|
# |
15
|
|
|
|
|
|
|
# You should have received a copy of the GNU General Public License along |
16
|
|
|
|
|
|
|
# with PFT. If not, see . |
17
|
|
|
|
|
|
|
# |
18
|
|
|
|
|
|
|
package PFT::Conf v1.3.0; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=encoding utf8 |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 NAME |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
PFT::Conf - Configuration parser for PFT |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 SYNOPSIS |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
PFT::Conf->new_default() # Using default |
29
|
|
|
|
|
|
|
PFT::Conf->new_load($root) # Load from conf file in directory |
30
|
|
|
|
|
|
|
PFT::Conf->new_load_locate() # Load from conf file, find directory |
31
|
|
|
|
|
|
|
PFT::Conf->new_load_locate($cwd) |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
PFT::Conf::locate() # Locate root |
34
|
|
|
|
|
|
|
PFT::Conf::locate($cwd) |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
PFT::Conf::isroot($path) # Check if location exists under path. |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
use Getopt::Long; |
39
|
|
|
|
|
|
|
Getopt::Long::Configure 'bundling'; |
40
|
|
|
|
|
|
|
GetOptions( |
41
|
|
|
|
|
|
|
PFT::Conf::wire_getopt(\my %opts), |
42
|
|
|
|
|
|
|
'more-opt' => \$more, |
43
|
|
|
|
|
|
|
); |
44
|
|
|
|
|
|
|
PFT::Conf->new_getopt(\%opts); # Create with command line options |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=head1 DESCRIPTION |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
Automatic loader and handler for the configuration file of a I site. |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
The configuration is a simple I file with a conventional name. Some |
51
|
|
|
|
|
|
|
keys are mandatory, while other are optional. This module allows a |
52
|
|
|
|
|
|
|
headache free check for mandatory ones. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
=head2 |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
Many constructors are available, here described: |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=over |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=item new_default |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
Creates a new configuration based on environment variables and common |
63
|
|
|
|
|
|
|
sense. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
The configuration can later be stored on a file with the C |
66
|
|
|
|
|
|
|
method. |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
=item new_load |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
Loads a configuration file which must already exist. Accepts as optional |
71
|
|
|
|
|
|
|
argument the name of a directory (not encoded), which defaults on |
72
|
|
|
|
|
|
|
the current directory. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
This constructor fails with C if the directory does not contain a |
75
|
|
|
|
|
|
|
configuration file. |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=item new_load_locate |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
Works as C, but before failing makes an attempt to locate the |
80
|
|
|
|
|
|
|
configuration file in the parent directories up to the root level. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
This is handy for launching commands from the command line without |
83
|
|
|
|
|
|
|
worrying on the current directory: it works as long as your I is |
84
|
|
|
|
|
|
|
below a I root directory. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=item wire_getopt and new_getopt |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
This is a two-steps constructor meant for command line initializers. |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
An example of usage can be found in the B section. In short, the |
91
|
|
|
|
|
|
|
auxiliary function C provides a list of |
92
|
|
|
|
|
|
|
ready-to-use options for the C Perl module. It expects a |
93
|
|
|
|
|
|
|
hash reference as argument, which will be used as storage for selected |
94
|
|
|
|
|
|
|
options. The C constructor expects as argument the same hash |
95
|
|
|
|
|
|
|
reference. |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=back |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
=cut |
100
|
|
|
|
|
|
|
|
101
|
3
|
|
|
3
|
|
74328
|
use utf8; |
|
3
|
|
|
|
|
16
|
|
|
3
|
|
|
|
|
18
|
|
102
|
3
|
|
|
3
|
|
108
|
use v5.16; |
|
3
|
|
|
|
|
10
|
|
103
|
3
|
|
|
3
|
|
18
|
use strict; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
82
|
|
104
|
3
|
|
|
3
|
|
16
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
89
|
|
105
|
|
|
|
|
|
|
|
106
|
3
|
|
|
3
|
|
13
|
use Carp; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
179
|
|
107
|
3
|
|
|
3
|
|
17
|
use Cwd; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
165
|
|
108
|
3
|
|
|
3
|
|
518
|
use Encode::Locale; |
|
3
|
|
|
|
|
15946
|
|
|
3
|
|
|
|
|
140
|
|
109
|
3
|
|
|
3
|
|
21
|
use Encode; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
283
|
|
110
|
3
|
|
|
3
|
|
21
|
use File::Basename qw/dirname/; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
237
|
|
111
|
3
|
|
|
3
|
|
20
|
use File::Path qw/make_path/; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
162
|
|
112
|
3
|
|
|
3
|
|
1493
|
use File::Spec::Functions qw/updir catfile catdir rootdir/; |
|
3
|
|
|
|
|
2628
|
|
|
3
|
|
|
|
|
219
|
|
113
|
3
|
|
|
3
|
|
668
|
use YAML::Tiny; |
|
3
|
|
|
|
|
6129
|
|
|
3
|
|
|
|
|
182
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
=head2 Shared variables |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
C<$PFT::Conf::CONF_NAME> is a string. Defines the name of the |
118
|
|
|
|
|
|
|
configuration file. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=cut |
121
|
|
|
|
|
|
|
|
122
|
3
|
|
|
3
|
|
23
|
use Exporter 'import'; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
5786
|
|
123
|
|
|
|
|
|
|
our @EXPORT_OK = qw( |
124
|
|
|
|
|
|
|
pod_autogen |
125
|
|
|
|
|
|
|
bash_completion_autogen |
126
|
|
|
|
|
|
|
); |
127
|
|
|
|
|
|
|
our $CONF_NAME = 'pft.yaml'; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# %CONF_RECIPE maps configuration names to an array. |
130
|
|
|
|
|
|
|
# |
131
|
|
|
|
|
|
|
# Keys of this map correspond to keys in the configuratoin file. They use dashes |
132
|
|
|
|
|
|
|
# to identify the hierarchy, so that, for instance, site-author corresponds to |
133
|
|
|
|
|
|
|
# the key 'author' in the section 'site' of the configuration file. |
134
|
|
|
|
|
|
|
# |
135
|
|
|
|
|
|
|
# Keys are also used for generating automatically the POD user guide and the |
136
|
|
|
|
|
|
|
# command line options of the `pft init` command. |
137
|
|
|
|
|
|
|
# |
138
|
|
|
|
|
|
|
# The semantics of each array item is defined by the following $IDX_* variables: |
139
|
|
|
|
|
|
|
my( |
140
|
|
|
|
|
|
|
$IDX_MANDATORY, # true if the configuration is mandatory |
141
|
|
|
|
|
|
|
$IDX_GETOPT_SUFFIX, # the corresponding suffix in getopt (see Getopt::Long) |
142
|
|
|
|
|
|
|
$IDX_DEFAULT, # The default value when generating a configuration |
143
|
|
|
|
|
|
|
$IDX_HELP # A human readable text descrbing the option |
144
|
|
|
|
|
|
|
) = 0 .. 3; |
145
|
|
|
|
|
|
|
my %CONF_RECIPE = do { |
146
|
|
|
|
|
|
|
my $user = $ENV{USER} || 'anon'; |
147
|
|
|
|
|
|
|
my $editor = $ENV{EDITOR} || 'vim'; |
148
|
|
|
|
|
|
|
my $browser = $ENV{BROWSER} || 'firefox'; |
149
|
|
|
|
|
|
|
( |
150
|
|
|
|
|
|
|
'site-author' => [1, '=s', $user || 'Anonymous', |
151
|
|
|
|
|
|
|
'Default author of entries' |
152
|
|
|
|
|
|
|
], |
153
|
|
|
|
|
|
|
'site-template' => [1, '=s', 'default.html', |
154
|
|
|
|
|
|
|
'Default template for compilation, can be overriden by single '. |
155
|
|
|
|
|
|
|
'entries' |
156
|
|
|
|
|
|
|
], |
157
|
|
|
|
|
|
|
'site-theme' => [0, '=s', 'light', |
158
|
|
|
|
|
|
|
'Global theme (e.g. "light" or "dark") optionally honored by '. |
159
|
|
|
|
|
|
|
'templates. Specific accepted values depend on the template '. |
160
|
|
|
|
|
|
|
'implementation' |
161
|
|
|
|
|
|
|
], |
162
|
|
|
|
|
|
|
'site-title' => [1, '=s', 'My PFT website', |
163
|
|
|
|
|
|
|
'Title of the website', |
164
|
|
|
|
|
|
|
], |
165
|
|
|
|
|
|
|
'site-url' => [0, '=s', 'http://example.org', |
166
|
|
|
|
|
|
|
'Base url for the website', |
167
|
|
|
|
|
|
|
], |
168
|
|
|
|
|
|
|
'site-home' => [1, '=s', 'Welcome', |
169
|
|
|
|
|
|
|
'First page, where index.html redirects the browsers', |
170
|
|
|
|
|
|
|
], |
171
|
|
|
|
|
|
|
'site-encoding' => [1, '=s', $Encode::Locale::ENCODING_LOCALE, |
172
|
|
|
|
|
|
|
'Charset of the generated web pages' |
173
|
|
|
|
|
|
|
], |
174
|
|
|
|
|
|
|
'site-feedfile' => [0, '=s', 'feed.rss', |
175
|
|
|
|
|
|
|
'File name of the RSS XML to be published by "pft gen-rss"', |
176
|
|
|
|
|
|
|
], |
177
|
|
|
|
|
|
|
'publish-method' => [1, '=s', 'rsync+ssh', |
178
|
|
|
|
|
|
|
'Method used for publishing' |
179
|
|
|
|
|
|
|
], |
180
|
|
|
|
|
|
|
'publish-host' => [0, '=s', 'example.org', |
181
|
|
|
|
|
|
|
'Remote host where to publish' |
182
|
|
|
|
|
|
|
], |
183
|
|
|
|
|
|
|
'publish-user' => [0, '=s', $user, |
184
|
|
|
|
|
|
|
'User login on publishing host' |
185
|
|
|
|
|
|
|
], |
186
|
|
|
|
|
|
|
'publish-port' => [0, '=i', 22, |
187
|
|
|
|
|
|
|
'Port for connection on publishing host' |
188
|
|
|
|
|
|
|
], |
189
|
|
|
|
|
|
|
'publish-path' => [0, '=s', "/home/$user/public_html", |
190
|
|
|
|
|
|
|
'Directory on publishing host' |
191
|
|
|
|
|
|
|
], |
192
|
|
|
|
|
|
|
'system-editor' => [0, '=s', "$editor %s", |
193
|
|
|
|
|
|
|
'Editor to be invoked by C. You may specify an '. |
194
|
|
|
|
|
|
|
'executable, or a shell command where "%s" gets replaced '. |
195
|
|
|
|
|
|
|
'with the file name' |
196
|
|
|
|
|
|
|
], |
197
|
|
|
|
|
|
|
'system-browser' => [0, '=s', "$browser %s", |
198
|
|
|
|
|
|
|
'Browser to be invoked by C. You may specify an '. |
199
|
|
|
|
|
|
|
'executable, or a shell command where "%s" gets replaced '. |
200
|
|
|
|
|
|
|
'with the file name' |
201
|
|
|
|
|
|
|
], |
202
|
|
|
|
|
|
|
) |
203
|
|
|
|
|
|
|
}; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# Transforms a flat mapping as $CONF_RECIPE into 'deep' hash table. Items in the |
206
|
|
|
|
|
|
|
# form 'foo-bar-baz' will be accessible as _hashify()->{foo}{bar}{baz}. |
207
|
|
|
|
|
|
|
sub _hashify { |
208
|
7
|
|
|
7
|
|
125
|
my %out; |
209
|
|
|
|
|
|
|
|
210
|
7
|
50
|
|
|
|
42
|
@_ % 2 and die "Odd number of args"; |
211
|
7
|
|
|
|
|
29
|
for (my $i = 0; $i < @_; $i += 2) { |
212
|
67
|
50
|
|
|
|
140
|
defined(my $val = $_[$i + 1]) or next; |
213
|
67
|
|
|
|
|
139
|
my @keys = split /-/, $_[$i]; |
214
|
|
|
|
|
|
|
|
215
|
67
|
50
|
|
|
|
114
|
die "Key is empty? \"$_[$i]\"" unless @keys; |
216
|
67
|
|
|
|
|
96
|
my $dst = \%out; |
217
|
67
|
|
|
|
|
113
|
while (@keys > 1) { |
218
|
69
|
|
|
|
|
98
|
my $k = shift @keys; |
219
|
|
|
|
|
|
|
$dst = exists $dst->{$k} |
220
|
|
|
|
|
|
|
? $dst->{$k} |
221
|
69
|
100
|
|
|
|
131
|
: do { $dst->{$k} = {} }; |
|
17
|
|
|
|
|
55
|
|
222
|
69
|
100
|
|
|
|
411
|
ref $dst ne 'HASH' and croak "Not pointing to hash: $_[$i]"; |
223
|
|
|
|
|
|
|
} |
224
|
66
|
|
|
|
|
100
|
my $k = shift @keys; |
225
|
66
|
100
|
66
|
|
|
238
|
exists $dst->{$k} && ref $dst->{$k} eq 'HASH' |
226
|
|
|
|
|
|
|
and croak "Overwriting $_[$i]"; |
227
|
65
|
|
|
|
|
181
|
$dst->{$k} = $val; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
5
|
|
|
|
|
20
|
\%out; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# Read the %CONF_RECIPE map and return a mapping between each key and the |
234
|
|
|
|
|
|
|
# associated field. The first parameter is the index to select. The second |
235
|
|
|
|
|
|
|
# parameter is optional: if true retrieves only the configuration which evaluate |
236
|
|
|
|
|
|
|
# as true. |
237
|
|
|
|
|
|
|
sub _read_recipe { |
238
|
7
|
|
|
7
|
|
19
|
my $select = shift; |
239
|
7
|
|
|
|
|
14
|
my @out; |
240
|
7
|
100
|
|
|
|
26
|
if (my $filter = shift) { |
241
|
3
|
|
|
|
|
19
|
while (my($k, $vs) = each %CONF_RECIPE) { |
242
|
45
|
100
|
|
|
|
116
|
my $v = $vs->[$select] or next; |
243
|
18
|
|
|
|
|
54
|
push @out, $k => $vs->[$select]; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
} else { |
246
|
4
|
|
|
|
|
33
|
while (my($k, $vs) = each %CONF_RECIPE) { |
247
|
60
|
|
|
|
|
194
|
push @out, $k => $vs->[$select]; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
7
|
|
|
|
|
46
|
@out; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub pod_autogen { |
254
|
0
|
|
|
0
|
0
|
0
|
my @out = ('=over', ''); |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
0
|
for my $key (sort keys %CONF_RECIPE) { |
257
|
0
|
|
|
|
|
0
|
my $info = $CONF_RECIPE{$key}; |
258
|
0
|
|
|
|
|
0
|
push @out, |
259
|
|
|
|
|
|
|
"=item --$key", '', |
260
|
|
|
|
|
|
|
$info->[$IDX_HELP], '', |
261
|
|
|
|
|
|
|
"Defaults to C<$info->[$IDX_DEFAULT]>", '' |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
0
|
|
|
|
|
0
|
join "\n", @out, '=back';# '', '=cut'; |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
sub bash_completion_autogen { |
268
|
0
|
|
|
0
|
0
|
0
|
'--' . join "\n--", keys %CONF_RECIPE; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub new_default { |
272
|
4
|
|
|
4
|
1
|
26
|
my $self = _hashify(_read_recipe($IDX_DEFAULT)); |
273
|
4
|
|
|
|
|
15
|
$self->{_root} = undef; |
274
|
4
|
|
|
|
|
16
|
bless $self, shift; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub _check_assign { |
278
|
3
|
|
|
3
|
|
56
|
my $self = shift; |
279
|
3
|
|
|
|
|
9
|
local $" = '-'; |
280
|
3
|
|
|
|
|
8
|
my $i; |
281
|
|
|
|
|
|
|
|
282
|
3
|
|
|
|
|
12
|
for my $mandk (grep { ++$i % 2 } _read_recipe($IDX_MANDATORY, 1)) { |
|
36
|
|
|
|
|
56
|
|
283
|
18
|
|
|
|
|
44
|
my @keys = split /-/, $mandk; |
284
|
18
|
|
|
|
|
23
|
my @path; |
285
|
|
|
|
|
|
|
|
286
|
18
|
|
|
|
|
24
|
my $c = $self; |
287
|
18
|
|
|
|
|
32
|
while (@keys > 1) { |
288
|
18
|
|
|
|
|
35
|
push @path, (my $k = shift @keys); |
289
|
18
|
50
|
|
|
|
40
|
confess "Missing section \"@path\"" unless $c->{$k}; |
290
|
18
|
|
|
|
|
26
|
$c = $c->{$k}; |
291
|
18
|
50
|
|
|
|
65
|
confess "Seeking \"@keys\" in \"@path\"" |
292
|
|
|
|
|
|
|
unless ref $c eq 'HASH'; |
293
|
|
|
|
|
|
|
} |
294
|
18
|
|
|
|
|
28
|
push @path, shift @keys; |
295
|
18
|
100
|
|
|
|
231
|
confess "Missing @path" unless exists $c->{$path[-1]}; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
sub new_load { |
300
|
2
|
|
|
2
|
1
|
9
|
my($cls, $root) = @_; |
301
|
|
|
|
|
|
|
|
302
|
2
|
|
|
|
|
4
|
my $self = do { |
303
|
2
|
50
|
|
|
|
6
|
my $enc_fname = isroot($root) |
304
|
|
|
|
|
|
|
or croak "$root is not a PFT site: $CONF_NAME is missing"; |
305
|
2
|
50
|
|
|
|
120
|
open(my $f, '<:encoding(locale)', $enc_fname) |
306
|
|
|
|
|
|
|
or croak "Cannot open $CONF_NAME in $root $!"; |
307
|
2
|
|
|
|
|
133
|
local $/ = undef; |
308
|
2
|
|
|
|
|
117
|
my $yaml = <$f>; |
309
|
2
|
|
|
|
|
56
|
close $f; |
310
|
|
|
|
|
|
|
|
311
|
2
|
|
|
|
|
14
|
YAML::Tiny::Load($yaml); |
312
|
|
|
|
|
|
|
}; |
313
|
2
|
|
|
|
|
2387
|
_check_assign($self); |
314
|
|
|
|
|
|
|
|
315
|
2
|
|
|
|
|
6
|
$self->{_root} = $root; |
316
|
2
|
|
|
|
|
23
|
bless $self, $cls; |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
sub new_load_locate { |
320
|
1
|
|
|
1
|
1
|
5
|
my $cls = shift; |
321
|
1
|
|
|
|
|
5
|
my $root = locate(my $start = shift); |
322
|
1
|
50
|
|
|
|
6
|
croak "Not a PFT site (or any parent up to $start)" |
323
|
|
|
|
|
|
|
unless defined $root; |
324
|
|
|
|
|
|
|
|
325
|
1
|
|
|
|
|
5
|
$cls->new_load($root); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub new_getopt { |
329
|
0
|
|
|
0
|
1
|
0
|
my($cls, $wired_hash) = @_; |
330
|
|
|
|
|
|
|
|
331
|
0
|
|
|
|
|
0
|
my $self = _hashify( |
332
|
|
|
|
|
|
|
_read_recipe($IDX_DEFAULT), # defaults |
333
|
|
|
|
|
|
|
%$wired_hash, # override via wire_getopt |
334
|
|
|
|
|
|
|
); |
335
|
0
|
|
|
|
|
0
|
$self->{_root} = undef; |
336
|
0
|
|
|
|
|
0
|
bless $self, $cls; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
=head2 Utility functions |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
=over |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=item isroot |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
The C function searches for the configuration file in |
346
|
|
|
|
|
|
|
the given directory path (not encoded). |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
Returns C if the file was not found, and the encoded file name |
349
|
|
|
|
|
|
|
(according to locale) if it was found. |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
=cut |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
sub isroot { |
354
|
24
|
|
|
24
|
1
|
156
|
my $f = encode(locale_fs => catfile(shift, $CONF_NAME)); |
355
|
24
|
100
|
|
|
|
1532
|
-e $f ? $f : undef |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=item locate |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
The C function locates a I configuration file. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
It accepts as optional parameter a directory path (not encoded), |
363
|
|
|
|
|
|
|
defaulting on the current working directory. |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
Possible return values: |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
=over |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=item The input directory itself if the configuration file was |
370
|
|
|
|
|
|
|
found in it; |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=item The first encountered parent directory containing the configuration |
373
|
|
|
|
|
|
|
file; |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
=item C if no configuration file was found, up to the root of all |
376
|
|
|
|
|
|
|
directories. |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
=back |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=back |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
=cut |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub locate { |
385
|
9
|
|
66
|
9
|
1
|
8441
|
my $cur = shift || Cwd::getcwd; |
386
|
9
|
|
|
|
|
29
|
my $root; |
387
|
|
|
|
|
|
|
|
388
|
9
|
50
|
|
|
|
45
|
croak "Not a directory: $cur" unless -d encode(locale_fs => $cur); |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# No single root directory on Windows. File::Spec->rootdir does not |
391
|
|
|
|
|
|
|
# work as intended. Workaround: $prev is like $cur on the previous |
392
|
|
|
|
|
|
|
# step: we stay on the same directory even going up, we reached the |
393
|
|
|
|
|
|
|
# root. Thanks to Alexandr Ciornii for checking this. |
394
|
9
|
|
|
|
|
1016
|
my $prev = ''; |
395
|
9
|
|
100
|
|
|
91
|
until ($cur eq rootdir or $cur eq $prev or defined($root)) { |
|
|
|
66
|
|
|
|
|
396
|
20
|
|
|
|
|
103
|
$prev = $cur; |
397
|
20
|
100
|
|
|
|
54
|
if (isroot($cur)) { |
398
|
4
|
|
|
|
|
26
|
$root = $cur |
399
|
|
|
|
|
|
|
} else { |
400
|
16
|
|
|
|
|
425
|
$cur = Cwd::abs_path catdir($cur, updir) |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
} |
403
|
9
|
|
|
|
|
45
|
$root; |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
sub wire_getopt { |
407
|
0
|
|
|
0
|
1
|
0
|
my $hash = shift; |
408
|
0
|
0
|
|
|
|
0
|
confess 'Needs hash' unless ref $hash eq 'HASH'; |
409
|
|
|
|
|
|
|
|
410
|
0
|
|
|
|
|
0
|
my @out; |
411
|
0
|
|
|
|
|
0
|
my @recipe = _read_recipe($IDX_GETOPT_SUFFIX); |
412
|
0
|
|
|
|
|
0
|
for (my $i = 0; $i < @recipe; $i += 2) { |
413
|
0
|
|
|
|
|
0
|
push @out, $recipe[$i] . $recipe[$i + 1] => \$hash->{$recipe[$i]} |
414
|
|
|
|
|
|
|
} |
415
|
0
|
|
|
|
|
0
|
@out; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=head2 Methods |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
=over 1 |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
=item save_to |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
Save the configuration to a file. This will also update the inner root |
425
|
|
|
|
|
|
|
reference, so the intsance will point to the saved file. |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
=cut |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub save_to { |
430
|
3
|
|
|
3
|
1
|
37
|
my($self, $root) = @_; |
431
|
|
|
|
|
|
|
|
432
|
3
|
|
|
|
|
65
|
my $orig_root = delete $self->{_root}; |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# YAML::Tiny does not like blessed items. I could unbless with |
435
|
|
|
|
|
|
|
# Data::Structure::Util, or easily do a shallow copy |
436
|
3
|
|
|
|
|
25
|
my $yaml = YAML::Tiny::Dump {%$self}; |
437
|
|
|
|
|
|
|
|
438
|
3
|
|
|
|
|
2963
|
eval { |
439
|
3
|
|
|
|
|
26
|
my $enc_root = encode(locale_fs => $root); |
440
|
3
|
50
|
33
|
|
|
244
|
-e $enc_root or make_path $enc_root |
441
|
|
|
|
|
|
|
or die "Cannot mkdir $root: $!"; |
442
|
3
|
50
|
|
3
|
|
303
|
open(my $out, |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
21
|
|
|
3
|
|
|
|
|
44
|
|
443
|
|
|
|
|
|
|
'>:encoding(locale)', |
444
|
|
|
|
|
|
|
encode(locale_fs => catfile($root, $CONF_NAME)), |
445
|
|
|
|
|
|
|
) or die "Cannot open $CONF_NAME in $root: $!"; |
446
|
3
|
|
|
|
|
3485
|
print $out $yaml; |
447
|
3
|
|
|
|
|
191
|
close $out; |
448
|
|
|
|
|
|
|
|
449
|
3
|
|
|
|
|
118
|
$self->{_root} = $root; |
450
|
|
|
|
|
|
|
}; |
451
|
3
|
50
|
|
|
|
21
|
$@ and do { |
452
|
0
|
|
|
|
|
|
$self->{_root} = $orig_root; |
453
|
0
|
|
|
|
|
|
croak $@ =~ s/ at.*$//sr; |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
=back |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=cut |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
use overload |
462
|
4
|
|
50
|
4
|
|
498
|
'""' => sub { 'PFT::Conf[ ' . (shift->{_root} || '?') . ' ]' }, |
463
|
3
|
|
|
3
|
|
1471
|
; |
|
3
|
|
|
|
|
1194
|
|
|
3
|
|
|
|
|
56
|
|
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
1; |