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.4.1; |
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
|
|
65997
|
use utf8; |
|
3
|
|
|
|
|
14
|
|
|
3
|
|
|
|
|
18
|
|
102
|
3
|
|
|
3
|
|
121
|
use v5.16; |
|
3
|
|
|
|
|
10
|
|
103
|
3
|
|
|
3
|
|
16
|
use strict; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
79
|
|
104
|
3
|
|
|
3
|
|
15
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
79
|
|
105
|
|
|
|
|
|
|
|
106
|
3
|
|
|
3
|
|
13
|
use Carp; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
172
|
|
107
|
3
|
|
|
3
|
|
19
|
use Cwd; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
178
|
|
108
|
3
|
|
|
3
|
|
477
|
use Encode::Locale; |
|
3
|
|
|
|
|
13882
|
|
|
3
|
|
|
|
|
123
|
|
109
|
3
|
|
|
3
|
|
19
|
use Encode; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
252
|
|
110
|
3
|
|
|
3
|
|
19
|
use File::Basename qw/dirname/; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
179
|
|
111
|
3
|
|
|
3
|
|
18
|
use File::Path qw/make_path/; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
157
|
|
112
|
3
|
|
|
3
|
|
1315
|
use File::Spec::Functions qw/updir catfile catdir rootdir/; |
|
3
|
|
|
|
|
2589
|
|
|
3
|
|
|
|
|
200
|
|
113
|
3
|
|
|
3
|
|
594
|
use YAML::Tiny; |
|
3
|
|
|
|
|
5711
|
|
|
3
|
|
|
|
|
149
|
|
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
|
|
18
|
use Exporter 'import'; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
6138
|
|
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, # 1 if the configuration is mandatory |
141
|
|
|
|
|
|
|
$IDX_GETOPT_SUFFIX, # 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
|
|
|
|
|
|
|
$IDX_HELP_OPTARG_NAME, # Option argument placeholder, undef if the |
145
|
|
|
|
|
|
|
# option doesn't take arguments. |
146
|
|
|
|
|
|
|
$IDX_HELP_DEFAULT, # Optional human readable text explaining |
147
|
|
|
|
|
|
|
# the default value. A representation of the |
148
|
|
|
|
|
|
|
# actual default is used if this is missing. |
149
|
|
|
|
|
|
|
) = 0 .. 5; |
150
|
|
|
|
|
|
|
my %CONF_RECIPE = do { |
151
|
|
|
|
|
|
|
my $user = $ENV{USER} || 'anon'; |
152
|
|
|
|
|
|
|
( |
153
|
|
|
|
|
|
|
'site-author' => [ |
154
|
|
|
|
|
|
|
1, |
155
|
|
|
|
|
|
|
'=s', |
156
|
|
|
|
|
|
|
$user, |
157
|
|
|
|
|
|
|
'Global Author, can be overriden by individual entries', |
158
|
|
|
|
|
|
|
'USER', |
159
|
|
|
|
|
|
|
'C<$USER> (environment variable)', |
160
|
|
|
|
|
|
|
], |
161
|
|
|
|
|
|
|
'site-template' => [ |
162
|
|
|
|
|
|
|
1, |
163
|
|
|
|
|
|
|
'=s', |
164
|
|
|
|
|
|
|
'default.html', |
165
|
|
|
|
|
|
|
'Global HTML template, can be overriden by individual entires', |
166
|
|
|
|
|
|
|
'TEMPLATE', |
167
|
|
|
|
|
|
|
undef, |
168
|
|
|
|
|
|
|
], |
169
|
|
|
|
|
|
|
'site-theme' => [ |
170
|
|
|
|
|
|
|
0, |
171
|
|
|
|
|
|
|
'=s', |
172
|
|
|
|
|
|
|
'light', |
173
|
|
|
|
|
|
|
'Global theme (e.g. C or C) optionally honored by'. |
174
|
|
|
|
|
|
|
' templates. Specific accepted values depend on the template'. |
175
|
|
|
|
|
|
|
' implementation', |
176
|
|
|
|
|
|
|
'THEME', |
177
|
|
|
|
|
|
|
undef, |
178
|
|
|
|
|
|
|
], |
179
|
|
|
|
|
|
|
'site-title' => [ |
180
|
|
|
|
|
|
|
1, |
181
|
|
|
|
|
|
|
'=s', |
182
|
|
|
|
|
|
|
'My PFT website', |
183
|
|
|
|
|
|
|
'Title of the website', |
184
|
|
|
|
|
|
|
'TITLE', |
185
|
|
|
|
|
|
|
undef, |
186
|
|
|
|
|
|
|
], |
187
|
|
|
|
|
|
|
'site-url' => [ |
188
|
|
|
|
|
|
|
0, |
189
|
|
|
|
|
|
|
'=s', |
190
|
|
|
|
|
|
|
'http://example.org', |
191
|
|
|
|
|
|
|
'Base url for the website', |
192
|
|
|
|
|
|
|
'URL', |
193
|
|
|
|
|
|
|
undef, |
194
|
|
|
|
|
|
|
], |
195
|
|
|
|
|
|
|
'site-home' => [ |
196
|
|
|
|
|
|
|
1, |
197
|
|
|
|
|
|
|
'=s', |
198
|
|
|
|
|
|
|
'Welcome', |
199
|
|
|
|
|
|
|
'First page, where C will redirect the browsers', |
200
|
|
|
|
|
|
|
'PAGE_NAME', |
201
|
|
|
|
|
|
|
undef, |
202
|
|
|
|
|
|
|
], |
203
|
|
|
|
|
|
|
'site-encoding' => [ |
204
|
|
|
|
|
|
|
1, |
205
|
|
|
|
|
|
|
'=s', |
206
|
|
|
|
|
|
|
$Encode::Locale::ENCODING_LOCALE, |
207
|
|
|
|
|
|
|
'Charset of the generated web pages', |
208
|
|
|
|
|
|
|
'ENC', |
209
|
|
|
|
|
|
|
'what is defined by L', |
210
|
|
|
|
|
|
|
], |
211
|
|
|
|
|
|
|
'site-feed-path' => [ |
212
|
|
|
|
|
|
|
0, |
213
|
|
|
|
|
|
|
'=s', |
214
|
|
|
|
|
|
|
'feed.rss', |
215
|
|
|
|
|
|
|
'File name of the RSS XML to be published by L', |
216
|
|
|
|
|
|
|
'PATH', |
217
|
|
|
|
|
|
|
undef, |
218
|
|
|
|
|
|
|
], |
219
|
|
|
|
|
|
|
'site-feed-length' => [ |
220
|
|
|
|
|
|
|
0, |
221
|
|
|
|
|
|
|
'=i', |
222
|
|
|
|
|
|
|
10, |
223
|
|
|
|
|
|
|
'Number of most recent blog entries to list in the RSS feed', |
224
|
|
|
|
|
|
|
'N', |
225
|
|
|
|
|
|
|
undef, |
226
|
|
|
|
|
|
|
], |
227
|
|
|
|
|
|
|
'site-feed-description' => [ |
228
|
|
|
|
|
|
|
0, |
229
|
|
|
|
|
|
|
'=s', |
230
|
|
|
|
|
|
|
'News from a PFT website', |
231
|
|
|
|
|
|
|
'Description of the channel (CdescriptionE> in the XML)', |
232
|
|
|
|
|
|
|
'DESC', |
233
|
|
|
|
|
|
|
undef, |
234
|
|
|
|
|
|
|
], |
235
|
|
|
|
|
|
|
'publish-method' => [ |
236
|
|
|
|
|
|
|
1, |
237
|
|
|
|
|
|
|
'=s', |
238
|
|
|
|
|
|
|
'rsync+ssh', |
239
|
|
|
|
|
|
|
'Method used for publishing (see L)', |
240
|
|
|
|
|
|
|
'NAME', |
241
|
|
|
|
|
|
|
undef, |
242
|
|
|
|
|
|
|
], |
243
|
|
|
|
|
|
|
'publish-host' => [ |
244
|
|
|
|
|
|
|
0, |
245
|
|
|
|
|
|
|
'=s', |
246
|
|
|
|
|
|
|
'example.org', |
247
|
|
|
|
|
|
|
'Remote host where to publish (see L)', |
248
|
|
|
|
|
|
|
'HOST', |
249
|
|
|
|
|
|
|
undef, |
250
|
|
|
|
|
|
|
], |
251
|
|
|
|
|
|
|
'publish-user' => [ |
252
|
|
|
|
|
|
|
0, |
253
|
|
|
|
|
|
|
'=s', |
254
|
|
|
|
|
|
|
$user, |
255
|
|
|
|
|
|
|
'User login on publishing host (see L)', |
256
|
|
|
|
|
|
|
'USER', |
257
|
|
|
|
|
|
|
'$USER (environment variable)', |
258
|
|
|
|
|
|
|
], |
259
|
|
|
|
|
|
|
'publish-port' => [ |
260
|
|
|
|
|
|
|
0, |
261
|
|
|
|
|
|
|
'=i', |
262
|
|
|
|
|
|
|
22, |
263
|
|
|
|
|
|
|
'Port for connection on publishing host (see L)', |
264
|
|
|
|
|
|
|
'PORT', |
265
|
|
|
|
|
|
|
undef, |
266
|
|
|
|
|
|
|
], |
267
|
|
|
|
|
|
|
'publish-path' => [ |
268
|
|
|
|
|
|
|
0, |
269
|
|
|
|
|
|
|
'=s', |
270
|
|
|
|
|
|
|
"/home/$user/public_html", |
271
|
|
|
|
|
|
|
'Remote path on publishing host (see L)', |
272
|
|
|
|
|
|
|
'PATH', |
273
|
|
|
|
|
|
|
'C, as by tradition', |
274
|
|
|
|
|
|
|
], |
275
|
|
|
|
|
|
|
'system-editor' => [ |
276
|
|
|
|
|
|
|
0, |
277
|
|
|
|
|
|
|
'=s', |
278
|
|
|
|
|
|
|
$ENV{EDITOR} || 'vi', |
279
|
|
|
|
|
|
|
'Editor to be invoked by L. You may specify an'. |
280
|
|
|
|
|
|
|
' executable, or a L command where "%s" gets replaced'. |
281
|
|
|
|
|
|
|
' with the file name (e.g.'. |
282
|
|
|
|
|
|
|
' "vim +\'set filetype=markdown spell\' %s")', |
283
|
|
|
|
|
|
|
'EDITOR', |
284
|
|
|
|
|
|
|
'C<$EDITOR> (environment variable), or C if not defined' |
285
|
|
|
|
|
|
|
], |
286
|
|
|
|
|
|
|
'system-browser' => [ |
287
|
|
|
|
|
|
|
0, |
288
|
|
|
|
|
|
|
'=s', |
289
|
|
|
|
|
|
|
$ENV{BROWSER} || 'firefox', |
290
|
|
|
|
|
|
|
'Browser to be invoked by B. You may specify an'. |
291
|
|
|
|
|
|
|
' executable, or a L command where "%s" gets replaced'. |
292
|
|
|
|
|
|
|
' with the file name (e.g. "firefox -profile x \'%s\'")', |
293
|
|
|
|
|
|
|
'BROWSER', |
294
|
|
|
|
|
|
|
'C<$BROWSER> (environment variable), or C if not defined' |
295
|
|
|
|
|
|
|
], |
296
|
|
|
|
|
|
|
) |
297
|
|
|
|
|
|
|
}; |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# Transforms a flat mapping as $CONF_RECIPE into 'deep' hash table. Items in the |
300
|
|
|
|
|
|
|
# form 'foo-bar-baz' will be accessible as _hashify()->{foo}{bar}{baz}. |
301
|
|
|
|
|
|
|
sub _hashify { |
302
|
7
|
|
|
7
|
|
105
|
my %out; |
303
|
|
|
|
|
|
|
|
304
|
7
|
50
|
|
|
|
26
|
@_ % 2 and die "Odd number of args"; |
305
|
7
|
|
|
|
|
26
|
for (my $i = 0; $i < @_; $i += 2) { |
306
|
75
|
50
|
|
|
|
152
|
defined(my $val = $_[$i + 1]) or next; |
307
|
75
|
|
|
|
|
151
|
my @keys = split /-/, $_[$i]; |
308
|
|
|
|
|
|
|
|
309
|
75
|
50
|
|
|
|
126
|
die "Key is empty? \"$_[$i]\"" unless @keys; |
310
|
75
|
|
|
|
|
104
|
my $dst = \%out; |
311
|
75
|
|
|
|
|
132
|
while (@keys > 1) { |
312
|
89
|
|
|
|
|
146
|
my $k = shift @keys; |
313
|
|
|
|
|
|
|
$dst = exists $dst->{$k} |
314
|
|
|
|
|
|
|
? $dst->{$k} |
315
|
89
|
100
|
|
|
|
163
|
: do { $dst->{$k} = {} }; |
|
21
|
|
|
|
|
55
|
|
316
|
89
|
100
|
|
|
|
430
|
ref $dst ne 'HASH' and croak "Not pointing to hash: $_[$i]"; |
317
|
|
|
|
|
|
|
} |
318
|
74
|
|
|
|
|
107
|
my $k = shift @keys; |
319
|
74
|
100
|
66
|
|
|
260
|
exists $dst->{$k} && ref $dst->{$k} eq 'HASH' |
320
|
|
|
|
|
|
|
and croak "Overwriting $_[$i]"; |
321
|
73
|
|
|
|
|
219
|
$dst->{$k} = $val; |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
5
|
|
|
|
|
17
|
\%out; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# Read the %CONF_RECIPE map and return a mapping between each key and the |
328
|
|
|
|
|
|
|
# associated field. The first parameter is the index to select. The second |
329
|
|
|
|
|
|
|
# parameter is optional: if true retrieves only the configuration which evaluate |
330
|
|
|
|
|
|
|
# as true. |
331
|
|
|
|
|
|
|
sub _read_recipe { |
332
|
7
|
|
|
7
|
|
13
|
my $select = shift; |
333
|
7
|
|
|
|
|
13
|
my @out; |
334
|
7
|
100
|
|
|
|
28
|
if (my $filter = shift) { |
335
|
3
|
|
|
|
|
13
|
while (my($k, $vs) = each %CONF_RECIPE) { |
336
|
51
|
100
|
|
|
|
120
|
my $v = $vs->[$select] or next; |
337
|
18
|
|
|
|
|
43
|
push @out, $k => $v; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} else { |
340
|
4
|
|
|
|
|
27
|
while (my($k, $vs) = each %CONF_RECIPE) { |
341
|
68
|
|
|
|
|
219
|
push @out, $k => $vs->[$select]; |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
7
|
|
|
|
|
56
|
@out; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub pod_autogen { |
348
|
0
|
|
|
0
|
0
|
0
|
my @out = ('=over', ''); |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
|
|
0
|
for my $key (sort keys %CONF_RECIPE) { |
351
|
0
|
|
|
|
|
0
|
my $info = $CONF_RECIPE{$key}; |
352
|
|
|
|
|
|
|
|
353
|
0
|
|
|
|
|
0
|
my $optitem = "=item B<--${key}>"; |
354
|
0
|
0
|
|
|
|
0
|
if (my $optarg_name = $info->[$IDX_HELP_OPTARG_NAME]) { |
355
|
0
|
|
|
|
|
0
|
$optitem .= "=I<${optarg_name}>" |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
0
|
|
|
|
|
0
|
my $default = $info->[$IDX_HELP_DEFAULT]; |
359
|
0
|
0
|
|
|
|
0
|
unless (defined $default) { |
360
|
|
|
|
|
|
|
# The semantic explanation on the default is missing, using the |
361
|
|
|
|
|
|
|
# textual representation of the actual default. |
362
|
0
|
|
|
|
|
0
|
$default = "C<$info->[$IDX_DEFAULT]>" |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
0
|
|
|
|
|
0
|
push @out, |
366
|
|
|
|
|
|
|
"$optitem\n", |
367
|
|
|
|
|
|
|
"$info->[$IDX_HELP].", |
368
|
|
|
|
|
|
|
"Defaults to $default.", '', |
369
|
|
|
|
|
|
|
} |
370
|
|
|
|
|
|
|
|
371
|
0
|
|
|
|
|
0
|
join "\n", @out, '=back';# '', '=cut'; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
sub bash_completion_autogen { |
375
|
0
|
|
|
0
|
0
|
0
|
'--' . join "\n--", keys %CONF_RECIPE; |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
sub new_default { |
379
|
4
|
|
|
4
|
1
|
17
|
my $self = _hashify(_read_recipe($IDX_DEFAULT)); |
380
|
4
|
|
|
|
|
21
|
$self->{_root} = undef; |
381
|
4
|
|
|
|
|
19
|
bless $self, shift; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub _check_assign { |
385
|
3
|
|
|
3
|
|
49
|
my $self = shift; |
386
|
3
|
|
|
|
|
6
|
local $" = '-'; |
387
|
3
|
|
|
|
|
5
|
my $i; |
388
|
|
|
|
|
|
|
|
389
|
3
|
|
|
|
|
8
|
for my $mandk (grep { ++$i % 2 } _read_recipe($IDX_MANDATORY, 1)) { |
|
36
|
|
|
|
|
52
|
|
390
|
16
|
|
|
|
|
33
|
my @keys = split /-/, $mandk; |
391
|
16
|
|
|
|
|
18
|
my @path; |
392
|
|
|
|
|
|
|
|
393
|
16
|
|
|
|
|
20
|
my $c = $self; |
394
|
16
|
|
|
|
|
27
|
while (@keys > 1) { |
395
|
16
|
|
|
|
|
26
|
push @path, (my $k = shift @keys); |
396
|
16
|
50
|
|
|
|
35
|
confess "Missing section \"@path\"" unless $c->{$k}; |
397
|
16
|
|
|
|
|
19
|
$c = $c->{$k}; |
398
|
16
|
50
|
|
|
|
41
|
confess "Seeking \"@keys\" in \"@path\"" |
399
|
|
|
|
|
|
|
unless ref $c eq 'HASH'; |
400
|
|
|
|
|
|
|
} |
401
|
16
|
|
|
|
|
23
|
push @path, shift @keys; |
402
|
16
|
100
|
|
|
|
188
|
confess "Missing @path" unless exists $c->{$path[-1]}; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
sub new_load { |
407
|
2
|
|
|
2
|
1
|
9
|
my($cls, $root) = @_; |
408
|
|
|
|
|
|
|
|
409
|
2
|
|
|
|
|
5
|
my $self = do { |
410
|
2
|
50
|
|
|
|
4
|
my $enc_fname = isroot($root) |
411
|
|
|
|
|
|
|
or croak "$root is not a PFT site: $CONF_NAME is missing"; |
412
|
2
|
50
|
|
|
|
68
|
open(my $f, '<:encoding(locale)', $enc_fname) |
413
|
|
|
|
|
|
|
or croak "Cannot open $CONF_NAME in $root $!"; |
414
|
2
|
|
|
|
|
106
|
local $/ = undef; |
415
|
2
|
|
|
|
|
64
|
my $yaml = <$f>; |
416
|
2
|
|
|
|
|
21
|
close $f; |
417
|
|
|
|
|
|
|
|
418
|
2
|
|
|
|
|
10
|
YAML::Tiny::Load($yaml); |
419
|
|
|
|
|
|
|
}; |
420
|
2
|
|
|
|
|
2552
|
_check_assign($self); |
421
|
|
|
|
|
|
|
|
422
|
2
|
|
|
|
|
5
|
$self->{_root} = $root; |
423
|
2
|
|
|
|
|
13
|
bless $self, $cls; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
sub new_load_locate { |
427
|
1
|
|
|
1
|
1
|
4
|
my $cls = shift; |
428
|
1
|
|
|
|
|
3
|
my $root = locate(my $start = shift); |
429
|
1
|
50
|
|
|
|
5
|
croak "Not a PFT site (or any parent up to $start)" |
430
|
|
|
|
|
|
|
unless defined $root; |
431
|
|
|
|
|
|
|
|
432
|
1
|
|
|
|
|
3
|
$cls->new_load($root); |
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
sub new_getopt { |
436
|
0
|
|
|
0
|
1
|
0
|
my($cls, $wired_hash) = @_; |
437
|
|
|
|
|
|
|
|
438
|
0
|
|
|
|
|
0
|
my $self = _hashify( |
439
|
|
|
|
|
|
|
_read_recipe($IDX_DEFAULT), # defaults |
440
|
|
|
|
|
|
|
%$wired_hash, # override via wire_getopt |
441
|
|
|
|
|
|
|
); |
442
|
0
|
|
|
|
|
0
|
$self->{_root} = undef; |
443
|
0
|
|
|
|
|
0
|
bless $self, $cls; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head2 Utility functions |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=over |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=item isroot |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
The C function searches for the configuration file in |
453
|
|
|
|
|
|
|
the given directory path (not encoded). |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
Returns C if the file was not found, and the encoded file name |
456
|
|
|
|
|
|
|
(according to locale) if it was found. |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=cut |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
sub isroot { |
461
|
24
|
|
|
24
|
1
|
138
|
my $f = encode(locale_fs => catfile(shift, $CONF_NAME)); |
462
|
24
|
100
|
|
|
|
1518
|
-e $f ? $f : undef |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
=item locate |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
The C function locates a I configuration file. |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
It accepts as optional parameter a directory path (not encoded), |
470
|
|
|
|
|
|
|
defaulting on the current working directory. |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
Possible return values: |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
=over |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=item The input directory itself if the configuration file was |
477
|
|
|
|
|
|
|
found in it; |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=item The first encountered parent directory containing the configuration |
480
|
|
|
|
|
|
|
file; |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
=item C if no configuration file was found, up to the root of all |
483
|
|
|
|
|
|
|
directories. |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=back |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
=back |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
=cut |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
sub locate { |
492
|
9
|
|
66
|
9
|
1
|
8607
|
my $cur = shift || Cwd::getcwd; |
493
|
9
|
|
|
|
|
26
|
my $root; |
494
|
|
|
|
|
|
|
|
495
|
9
|
50
|
|
|
|
31
|
croak "Not a directory: $cur" unless -d encode(locale_fs => $cur); |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# No single root directory on Windows. File::Spec->rootdir does not |
498
|
|
|
|
|
|
|
# work as intended. Workaround: $prev is like $cur on the previous |
499
|
|
|
|
|
|
|
# step: we stay on the same directory even going up, we reached the |
500
|
|
|
|
|
|
|
# root. Thanks to Alexandr Ciornii for checking this. |
501
|
9
|
|
|
|
|
923
|
my $prev = ''; |
502
|
9
|
|
100
|
|
|
69
|
until ($cur eq rootdir or $cur eq $prev or defined($root)) { |
|
|
|
66
|
|
|
|
|
503
|
20
|
|
|
|
|
101
|
$prev = $cur; |
504
|
20
|
100
|
|
|
|
50
|
if (isroot($cur)) { |
505
|
4
|
|
|
|
|
25
|
$root = $cur |
506
|
|
|
|
|
|
|
} else { |
507
|
16
|
|
|
|
|
410
|
$cur = Cwd::abs_path catdir($cur, updir) |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
} |
510
|
9
|
|
|
|
|
56
|
$root; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub wire_getopt { |
514
|
0
|
|
|
0
|
1
|
0
|
my $hash = shift; |
515
|
0
|
0
|
|
|
|
0
|
confess 'Needs hash' unless ref $hash eq 'HASH'; |
516
|
|
|
|
|
|
|
|
517
|
0
|
|
|
|
|
0
|
my @out; |
518
|
0
|
|
|
|
|
0
|
my @recipe = _read_recipe($IDX_GETOPT_SUFFIX); |
519
|
0
|
|
|
|
|
0
|
for (my $i = 0; $i < @recipe; $i += 2) { |
520
|
0
|
|
|
|
|
0
|
push @out, $recipe[$i] . $recipe[$i + 1] => \$hash->{$recipe[$i]} |
521
|
|
|
|
|
|
|
} |
522
|
0
|
|
|
|
|
0
|
@out; |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
=head2 Methods |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=over 1 |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
=item save_to |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
Save the configuration to a file. This will also update the inner root |
532
|
|
|
|
|
|
|
reference, so the intsance will point to the saved file. |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
=cut |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
sub save_to { |
537
|
3
|
|
|
3
|
1
|
34
|
my($self, $root) = @_; |
538
|
|
|
|
|
|
|
|
539
|
3
|
|
|
|
|
64
|
my $orig_root = delete $self->{_root}; |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# YAML::Tiny does not like blessed items. I could unbless with |
542
|
|
|
|
|
|
|
# Data::Structure::Util, or easily do a shallow copy |
543
|
3
|
|
|
|
|
23
|
my $yaml = YAML::Tiny::Dump {%$self}; |
544
|
|
|
|
|
|
|
|
545
|
3
|
|
|
|
|
3264
|
eval { |
546
|
3
|
|
|
|
|
35
|
my $enc_root = encode(locale_fs => $root); |
547
|
3
|
50
|
33
|
|
|
213
|
-e $enc_root or make_path $enc_root |
548
|
|
|
|
|
|
|
or die "Cannot mkdir $root: $!"; |
549
|
3
|
50
|
|
3
|
|
257
|
open(my $out, |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
19
|
|
|
3
|
|
|
|
|
53
|
|
550
|
|
|
|
|
|
|
'>:encoding(locale)', |
551
|
|
|
|
|
|
|
encode(locale_fs => catfile($root, $CONF_NAME)), |
552
|
|
|
|
|
|
|
) or die "Cannot open $CONF_NAME in $root: $!"; |
553
|
3
|
|
|
|
|
3060
|
print $out $yaml; |
554
|
3
|
|
|
|
|
171
|
close $out; |
555
|
|
|
|
|
|
|
|
556
|
3
|
|
|
|
|
100
|
$self->{_root} = $root; |
557
|
|
|
|
|
|
|
}; |
558
|
3
|
50
|
|
|
|
28
|
$@ and do { |
559
|
0
|
|
|
|
|
|
$self->{_root} = $orig_root; |
560
|
0
|
|
|
|
|
|
croak $@ =~ s/ at.*$//sr; |
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
=back |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
=cut |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
use overload |
569
|
4
|
|
50
|
4
|
|
392
|
'""' => sub { 'PFT::Conf[ ' . (shift->{_root} || '?') . ' ]' }, |
570
|
3
|
|
|
3
|
|
1201
|
; |
|
3
|
|
|
|
|
983
|
|
|
3
|
|
|
|
|
23
|
|
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
1; |