1
2=head1 NAME
3
4Devscripts::Config - devscripts Perl scripts configuration object
5
6=head1 SYNOPSIS
7
8  # Configuration module
9  package Devscripts::My::Config;
10  use Moo;
11  extends 'Devscripts::Config';
12
13  use constant keys => [
14    [ 'text1=s', 'MY_TEXT', qr/^\S/, 'Default_text' ],
15    # ...
16  ];
17
18  has text1 => ( is => 'rw' );
19
20  # Main package or script
21  package Devscripts::My;
22
23  use Moo;
24  my $config = Devscripts::My::Config->new->parse;
25  1;
26
27=head1 DESCRIPTION
28
29Devscripts Perl scripts configuration object. It can scan configuration files
30(B</etc/devscripts.conf> and B<~/.devscripts>) and command line arguments.
31
32A devscripts configuration package has just to declare:
33
34=over
35
36=item B<keys> constant: array ref I<(see below)>
37
38=item B<rules> constant: hash ref I<(see below)>
39
40=back
41
42=head1 KEYS
43
44Each element of B<keys> constant is an array containing four elements which can
45be undefined:
46
47=over
48
49=item the string to give to L<Getopt::Long>
50
51=item the name of the B<devscripts.conf> key
52
53=item the rule to check value. It can be:
54
55=over
56
57=item B<regexp> ref: will be applied to the value. If it fails against the
58devscripts.conf value, Devscripts::Config will warn. If it fails against the
59command line argument, Devscripts::Config will die.
60
61=item B<sub> ref: function will be called with 2 arguments: current config
62object and proposed value. Function must return a true value to continue or
630 to stop. This is not simply a "check" function: Devscripts::Config will not
64do anything else than read the result to continue with next argument or stop.
65
66=item B<"bool"> string: means that value is a boolean. devscripts.conf value
67can be either "yes", 1, "no", 0.
68
69=back
70
71=item the default value
72
73=back
74
75=head2 RULES
76
77It is possible to declare some additional rules to check the logic between
78options:
79
80  use constant rules => [
81    sub {
82      my($self)=@_;
83      # OK
84      return 1 if( $self->a < $self->b );
85      # OK with warning
86      return ( 1, 'a should be lower than b ) if( $self->a > $self->b );
87      # NOK with an error
88      return ( 0, 'a must not be equal to b !' );
89    },
90    sub {
91      my($self)=@_;
92      # ...
93      return 1;
94    },
95  ];
96
97=head1 METHODS
98
99=head2 new()
100
101Constructor
102
103=cut
104
105package Devscripts::Config;
106
107use strict;
108use Devscripts::Output;
109use Dpkg::IPC;
110use File::HomeDir;
111use Getopt::Long qw(:config bundling permute no_getopt_compat);
112use Moo;
113
114# Common options
115has common_opts => (
116    is      => 'ro',
117    default => sub {
118        [[
119                'help', undef,
120                sub {
121                    if ($_[1]) { $_[0]->usage; exit 0 }
122                }
123            ]]
124    });
125
126# Internal attributes
127
128has modified_conf_msg => (is => 'rw', default => sub { '' });
129
130$ENV{HOME} = File::HomeDir->my_home;
131
132our @config_files
133  = ('/etc/devscripts.conf', ($ENV{HOME} ? "$ENV{HOME}/.devscripts" : ()));
134
135sub keys {
136    die "conffile_keys() must be defined in sub classes";
137}
138
139=head2 parse()
140
141Launches B<parse_conf_files()>, B<parse_command_line()> and B<check_rules>
142
143=cut
144
145sub BUILD {
146    my ($self) = @_;
147    $self->set_default;
148}
149
150sub parse {
151    my ($self) = @_;
152
153    # 1 - Parse /etc/devscripts.conf and ~/.devscripts
154    $self->parse_conf_files;
155
156    # 2 - Parse command line
157    $self->parse_command_line;
158
159    # 3 - Check rules
160    $self->check_rules;
161    return $self;
162}
163
164# I - Parse /etc/devscripts.conf and ~/.devscripts
165
166=head2 parse_conf_files()
167
168Reads values in B</etc/devscripts.conf> and B<~/.devscripts>
169
170=cut
171
172sub set_default {
173    my ($self) = @_;
174    my $keys = $self->keys;
175    foreach my $key (@$keys) {
176        my ($kname, $name, $check, $default) = @$key;
177        next unless (defined $default);
178        $kname =~ s/^\-\-//;
179        $kname =~ s/-/_/g;
180        $kname =~ s/[!\|=].*$//;
181        if (ref $default) {
182            unless (ref $default eq 'CODE') {
183                die "Default value must be a sub ($kname)";
184            }
185            $self->{$kname} = $default->();
186        } else {
187            $self->{$kname} = $default;
188        }
189    }
190}
191
192sub parse_conf_files {
193    my ($self) = @_;
194
195    my @cfg_files = @config_files;
196    if (@ARGV) {
197        if ($ARGV[0] =~ /^--no-?conf$/) {
198            $self->modified_conf_msg("  (no configuration files read)");
199            shift @ARGV;
200            return $self;
201        }
202        my @tmp;
203        while ($ARGV[0] and $ARGV[0] =~ s/^--conf-?file(?:=(.+))?//) {
204            shift @ARGV;
205            my $file = $1 || shift(@ARGV);
206            if ($file) {
207                unless ($file =~ s/^\+//) {
208                    @cfg_files = ();
209                }
210                push @tmp, $file;
211            } else {
212                return ds_die
213                  "Unable to parse --conf-file option, aborting parsing";
214            }
215        }
216        push @cfg_files, @tmp;
217    }
218
219    @cfg_files = grep { -r $_ } @cfg_files;
220    my $keys = $self->keys;
221    if (@cfg_files) {
222        my @key_names = map { $_->[1] ? $_->[1] : () } @$keys;
223        my %config_vars;
224
225        my $shell_cmd = q{for file ; do . "$file"; done ;};
226
227        # Read back values
228        $shell_cmd .= q{ printf '%s\0' };
229        my @shell_key_names = map { qq{"\$$_"} } @key_names;
230        $shell_cmd .= join(' ', @shell_key_names);
231        my $shell_out;
232        spawn(
233            exec => [
234                '/bin/bash', '-c',
235                $shell_cmd,  'devscripts-config-loader',
236                @cfg_files
237            ],
238            wait_child => 1,
239            to_string  => \$shell_out
240        );
241        @config_vars{@key_names} = map { s/^\s*(.*?)\s*/$1/ ? $_ : undef }
242          split(/\0/, $shell_out, -1);
243
244        # Check validity and set value
245        foreach my $key (@$keys) {
246            my ($kname, $name, $check, $default) = @$key;
247            next unless ($name);
248            $kname //= '';
249            $kname =~ s/^\-\-//;
250            $kname =~ s/-/_/g;
251            $kname =~ s/[!|=+].*$//;
252            # Case 1: nothing in conf files, set default
253            next unless (length $config_vars{$name});
254            if (defined $check) {
255                if (not(ref $check)) {
256                    $check
257                      = $self->_subs_check($check, $kname, $name, $default);
258                }
259                if (ref $check eq 'CODE') {
260                    my ($res, $msg)
261                      = $check->($self, $config_vars{$name}, $kname);
262                    ds_warn $msg unless ($res);
263                    next;
264                } elsif (ref $check eq 'Regexp') {
265                    unless ($config_vars{$name} =~ $check) {
266                        ds_warn("Bad $name value $config_vars{$name}");
267                        next;
268                    }
269                } else {
270                    ds_die("Unknown check type for $name");
271                    return undef;
272                }
273            }
274            $self->{$kname} = $config_vars{$name};
275            $self->{modified_conf_msg} .= "  $name=$config_vars{$name}\n";
276            if (ref $default) {
277                my $ref = ref $default->();
278                my @tmp = ($config_vars{$name} =~ /\s+"([^"]*)"(?>\s+)/g);
279                $config_vars{$name} =~ s/\s+"([^"]*)"\s+/ /g;
280                push @tmp, split(/\s+/, $config_vars{$name});
281                if ($ref eq 'ARRAY') {
282                    $self->{$kname} = \@tmp;
283                } elsif ($ref eq 'HASH') {
284                    $self->{$kname}
285                      = { map { /^(.*?)=(.*)$/ ? ($1 => $2) : ($_ => 1) }
286                          @tmp };
287                }
288            }
289        }
290    }
291    return $self;
292}
293
294# II - Parse command line
295
296=head2 parse_command_line()
297
298Parse command line arguments
299
300=cut
301
302sub parse_command_line {
303    my ($self, @arrays) = @_;
304    my $opts = {};
305    my $keys = [@{ $self->common_opts }, @{ $self->keys }];
306    # If default value is set to [], we must prepare hash ref to be able to
307    # receive more than one value
308    foreach (@$keys) {
309        if ($_->[3] and ref($_->[3])) {
310            my $kname = $_->[0];
311            $kname =~ s/[!\|=].*$//;
312            $opts->{$kname} = $_->[3]->();
313        }
314    }
315    unless (GetOptions($opts, map { $_->[0] ? ($_->[0]) : () } @$keys)) {
316        $_[0]->usage;
317        exit 1;
318    }
319    foreach my $key (@$keys) {
320        my ($kname, $tmp, $check, $default) = @$key;
321        next unless ($kname);
322        $kname =~ s/[!|=+].*$//;
323        my $name = $kname;
324        $kname =~ s/-/_/g;
325        if (defined $opts->{$name}) {
326            next if (ref $opts->{$name} eq 'ARRAY' and !@{ $opts->{$name} });
327            next if (ref $opts->{$name} eq 'HASH'  and !%{ $opts->{$name} });
328            if (defined $check) {
329                if (not(ref $check)) {
330                    $check
331                      = $self->_subs_check($check, $kname, $name, $default);
332                }
333                if (ref $check eq 'CODE') {
334                    my ($res, $msg) = $check->($self, $opts->{$name}, $kname);
335                    ds_die "Bad value for $name: $msg" unless ($res);
336                } elsif (ref $check eq 'Regexp') {
337                    if ($opts->{$name} =~ $check) {
338                        $self->{$kname} = $opts->{$name};
339                    } else {
340                        ds_die("Bad $name value in command line");
341                    }
342                } else {
343                    ds_die("Unknown check type for $name");
344                }
345            } else {
346                $self->{$kname} = $opts->{$name};
347            }
348        }
349    }
350    return $self;
351}
352
353sub check_rules {
354    my ($self) = @_;
355    if ($self->can('rules')) {
356        if (my $rules = $self->rules) {
357            my $i = 0;
358            foreach my $sub (@$rules) {
359                $i++;
360                my ($res, $msg) = $sub->($self);
361                if ($res) {
362                    ds_warn($msg) if ($msg);
363                } else {
364                    ds_error($msg || "config rule $i");
365                    # ds_error may not die if $Devscripts::Output::die_on_error
366                    # is set to 0
367                    next;
368                }
369            }
370        }
371    }
372    return $self;
373}
374
375sub _subs_check {
376    my ($self, $check, $kname, $name, $default) = @_;
377    if ($check eq 'bool') {
378        $check = sub {
379            $_[0]->{$kname} = (
380                  $_[1] =~ /^(?:1|yes)$/i ? 1
381                : $_[1] =~ /^(?:0|no)$/i  ? 0
382                : $default                ? $default
383                :                           undef
384            );
385            return 1;
386        };
387    } else {
388        $self->die("Unknown check type for $name");
389    }
390    return $check;
391}
392
393# Default usage: switch to manpage
394sub usage {
395    $progname =~ s/\.pl//;
396    exec("man", '-P', '/bin/cat', $progname);
397}
398
3991;
400__END__
401=head1 SEE ALSO
402
403L<devscripts>
404
405=head1 AUTHOR
406
407Xavier Guimard E<lt>yadd@debian.orgE<gt>
408
409=head1 COPYRIGHT AND LICENSE
410
411Copyright 2018 by Xavier Guimard <yadd@debian.org>
412
413This program is free software; you can redistribute it and/or modify
414it under the terms of the GNU General Public License as published by
415the Free Software Foundation; either version 2 of the License, or
416(at your option) any later version.
417
418=cut
419