418 lines
11 KiB
Perl
418 lines
11 KiB
Perl
|
|
=head1 NAME
|
|
|
|
Devscripts::Config - devscripts Perl scripts configuration object
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
# Configuration module
|
|
package Devscripts::My::Config;
|
|
use Moo;
|
|
extends 'Devscripts::Config';
|
|
|
|
use constant keys => [
|
|
[ 'text1=s', 'MY_TEXT', qr/^\S/, 'Default_text' ],
|
|
# ...
|
|
];
|
|
|
|
has text1 => ( is => 'rw' );
|
|
|
|
# Main package or script
|
|
package Devscripts::My;
|
|
|
|
use Moo;
|
|
my $config = Devscripts::My::Config->new->parse;
|
|
1;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Devscripts Perl scripts configuration object. It can scan configuration files
|
|
(B</etc/devscripts.conf> and B<~/.devscripts>) and command line arguments.
|
|
|
|
A devscripts configuration package has just to declare:
|
|
|
|
=over
|
|
|
|
=item B<keys> constant: array ref I<(see below)>
|
|
|
|
=item B<rules> constant: hash ref I<(see below)>
|
|
|
|
=back
|
|
|
|
=head1 KEYS
|
|
|
|
Each element of B<keys> constant is an array containing four elements which can
|
|
be undefined:
|
|
|
|
=over
|
|
|
|
=item the string to give to L<Getopt::Long>
|
|
|
|
=item the name of the B<devscripts.conf> key
|
|
|
|
=item the rule to check value. It can be:
|
|
|
|
=over
|
|
|
|
=item B<regexp> ref: will be applied to the value. If it fails against the
|
|
devscripts.conf value, Devscripts::Config will warn. If it fails against the
|
|
command line argument, Devscripts::Config will die.
|
|
|
|
=item B<sub> ref: function will be called with 2 arguments: current config
|
|
object and proposed value. Function must return a true value to continue or
|
|
0 to stop. This is not simply a "check" function: Devscripts::Config will not
|
|
do anything else than read the result to continue with next argument or stop.
|
|
|
|
=item B<"bool"> string: means that value is a boolean. devscripts.conf value
|
|
can be either "yes", 1, "no", 0.
|
|
|
|
=back
|
|
|
|
=item the default value
|
|
|
|
=back
|
|
|
|
=head2 RULES
|
|
|
|
It is possible to declare some additional rules to check the logic between
|
|
options:
|
|
|
|
use constant rules => [
|
|
sub {
|
|
my($self)=@_;
|
|
# OK
|
|
return 1 if( $self->a < $self->b );
|
|
# OK with warning
|
|
return ( 1, 'a should be lower than b ) if( $self->a > $self->b );
|
|
# NOK with an error
|
|
return ( 0, 'a must not be equal to b !' );
|
|
},
|
|
sub {
|
|
my($self)=@_;
|
|
# ...
|
|
return 1;
|
|
},
|
|
];
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new()
|
|
|
|
Constructor
|
|
|
|
=cut
|
|
|
|
package Devscripts::Config;
|
|
|
|
use strict;
|
|
use Devscripts::Output;
|
|
use Dpkg::IPC;
|
|
use File::HomeDir;
|
|
use Getopt::Long qw(:config bundling permute no_getopt_compat);
|
|
use Moo;
|
|
|
|
# Common options
|
|
has common_opts => (
|
|
is => 'ro',
|
|
default => sub {
|
|
[[
|
|
'help', undef,
|
|
sub {
|
|
if ($_[1]) { $_[0]->usage; exit 0 }
|
|
}
|
|
]]
|
|
});
|
|
|
|
# Internal attributes
|
|
|
|
has modified_conf_msg => (is => 'rw', default => sub { '' });
|
|
|
|
$ENV{HOME} = File::HomeDir->my_home;
|
|
|
|
our @config_files
|
|
= ('/etc/devscripts.conf', ($ENV{HOME} ? "$ENV{HOME}/.devscripts" : ()));
|
|
|
|
sub keys {
|
|
die "conffile_keys() must be defined in sub classes";
|
|
}
|
|
|
|
=head2 parse()
|
|
|
|
Launches B<parse_conf_files()>, B<parse_command_line()> and B<check_rules>
|
|
|
|
=cut
|
|
|
|
sub BUILD {
|
|
my ($self) = @_;
|
|
$self->set_default;
|
|
}
|
|
|
|
sub parse {
|
|
my ($self) = @_;
|
|
|
|
# 1 - Parse /etc/devscripts.conf and ~/.devscripts
|
|
$self->parse_conf_files;
|
|
|
|
# 2 - Parse command line
|
|
$self->parse_command_line;
|
|
|
|
# 3 - Check rules
|
|
$self->check_rules;
|
|
return $self;
|
|
}
|
|
|
|
# I - Parse /etc/devscripts.conf and ~/.devscripts
|
|
|
|
=head2 parse_conf_files()
|
|
|
|
Reads values in B</etc/devscripts.conf> and B<~/.devscripts>
|
|
|
|
=cut
|
|
|
|
sub set_default {
|
|
my ($self) = @_;
|
|
my $keys = $self->keys;
|
|
foreach my $key (@$keys) {
|
|
my ($kname, $name, $check, $default) = @$key;
|
|
next unless (defined $default);
|
|
$kname =~ s/^\-\-//;
|
|
$kname =~ s/-/_/g;
|
|
$kname =~ s/[!\|=].*$//;
|
|
if (ref $default) {
|
|
unless (ref $default eq 'CODE') {
|
|
die "Default value must be a sub ($kname)";
|
|
}
|
|
$self->{$kname} = $default->();
|
|
} else {
|
|
$self->{$kname} = $default;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub parse_conf_files {
|
|
my ($self) = @_;
|
|
|
|
my @cfg_files = @config_files;
|
|
if (@ARGV) {
|
|
if ($ARGV[0] =~ /^--no-?conf$/) {
|
|
$self->modified_conf_msg(" (no configuration files read)");
|
|
shift @ARGV;
|
|
return $self;
|
|
}
|
|
my @tmp;
|
|
while ($ARGV[0] and $ARGV[0] =~ s/^--conf-?file(?:=(.+))?//) {
|
|
shift @ARGV;
|
|
my $file = $1 || shift(@ARGV);
|
|
if ($file) {
|
|
unless ($file =~ s/^\+//) {
|
|
@cfg_files = ();
|
|
}
|
|
push @tmp, $file;
|
|
} else {
|
|
return ds_die
|
|
"Unable to parse --conf-file option, aborting parsing";
|
|
}
|
|
}
|
|
push @cfg_files, @tmp;
|
|
}
|
|
|
|
@cfg_files = grep { -r $_ } @cfg_files;
|
|
my $keys = $self->keys;
|
|
if (@cfg_files) {
|
|
my @key_names = map { $_->[1] ? $_->[1] : () } @$keys;
|
|
my %config_vars;
|
|
|
|
my $shell_cmd = q{for file ; do . "$file"; done ;};
|
|
|
|
# Read back values
|
|
$shell_cmd .= q{ printf '%s\0' };
|
|
my @shell_key_names = map { qq{"\$$_"} } @key_names;
|
|
$shell_cmd .= join(' ', @shell_key_names);
|
|
my $shell_out;
|
|
spawn(
|
|
exec => [
|
|
'/bin/bash', '-c',
|
|
$shell_cmd, 'devscripts-config-loader',
|
|
@cfg_files
|
|
],
|
|
wait_child => 1,
|
|
to_string => \$shell_out
|
|
);
|
|
@config_vars{@key_names} = map { s/^\s*(.*?)\s*/$1/ ? $_ : undef }
|
|
split(/\0/, $shell_out, -1);
|
|
|
|
# Check validity and set value
|
|
foreach my $key (@$keys) {
|
|
my ($kname, $name, $check, $default) = @$key;
|
|
next unless ($name);
|
|
$kname //= '';
|
|
$kname =~ s/^\-\-//;
|
|
$kname =~ s/-/_/g;
|
|
$kname =~ s/[!|=+].*$//;
|
|
# Case 1: nothing in conf files, set default
|
|
next unless (length $config_vars{$name});
|
|
if (defined $check) {
|
|
if (not(ref $check)) {
|
|
$check
|
|
= $self->_subs_check($check, $kname, $name, $default);
|
|
}
|
|
if (ref $check eq 'CODE') {
|
|
my ($res, $msg)
|
|
= $check->($self, $config_vars{$name}, $kname);
|
|
ds_warn $msg unless ($res);
|
|
next;
|
|
} elsif (ref $check eq 'Regexp') {
|
|
unless ($config_vars{$name} =~ $check) {
|
|
ds_warn "Bad $name value $config_vars{$name}";
|
|
next;
|
|
}
|
|
} else {
|
|
ds_die "Unknown check type for $name";
|
|
return undef;
|
|
}
|
|
}
|
|
$self->{$kname} = $config_vars{$name};
|
|
$self->{modified_conf_msg} .= " $name=$config_vars{$name}\n";
|
|
if (ref $default) {
|
|
my $ref = ref $default->();
|
|
my @tmp = ($config_vars{$name} =~ /\s+"([^"]*)"(?>\s+)/g);
|
|
$config_vars{$name} =~ s/\s+"([^"]*)"\s+/ /g;
|
|
push @tmp, split(/\s+/, $config_vars{$name});
|
|
if ($ref eq 'ARRAY') {
|
|
$self->{$kname} = \@tmp;
|
|
} elsif ($ref eq 'HASH') {
|
|
$self->{$kname}
|
|
= { map { /^(.*?)=(.*)$/ ? ($1 => $2) : ($_ => 1) }
|
|
@tmp };
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
# II - Parse command line
|
|
|
|
=head2 parse_command_line()
|
|
|
|
Parse command line arguments
|
|
|
|
=cut
|
|
|
|
sub parse_command_line {
|
|
my ($self, @arrays) = @_;
|
|
my $opts = {};
|
|
my $keys = [@{ $self->common_opts }, @{ $self->keys }];
|
|
# If default value is set to [], we must prepare hash ref to be able to
|
|
# receive more than one value
|
|
foreach (@$keys) {
|
|
if ($_->[3] and ref($_->[3])) {
|
|
my $kname = $_->[0];
|
|
$kname =~ s/[!\|=].*$//;
|
|
$opts->{$kname} = $_->[3]->();
|
|
}
|
|
}
|
|
unless (GetOptions($opts, map { $_->[0] ? ($_->[0]) : () } @$keys)) {
|
|
$_[0]->usage;
|
|
exit 1;
|
|
}
|
|
foreach my $key (@$keys) {
|
|
my ($kname, $tmp, $check, $default) = @$key;
|
|
next unless ($kname);
|
|
$kname =~ s/[!|=+].*$//;
|
|
my $name = $kname;
|
|
$kname =~ s/-/_/g;
|
|
if (defined $opts->{$name}) {
|
|
next if (ref $opts->{$name} eq 'ARRAY' and !@{ $opts->{$name} });
|
|
next if (ref $opts->{$name} eq 'HASH' and !%{ $opts->{$name} });
|
|
if (defined $check) {
|
|
if (not(ref $check)) {
|
|
$check
|
|
= $self->_subs_check($check, $kname, $name, $default);
|
|
}
|
|
if (ref $check eq 'CODE') {
|
|
my ($res, $msg) = $check->($self, $opts->{$name}, $kname);
|
|
ds_die "Bad value for $name: $msg" unless ($res);
|
|
} elsif (ref $check eq 'Regexp') {
|
|
if ($opts->{$name} =~ $check) {
|
|
$self->{$kname} = $opts->{$name};
|
|
} else {
|
|
ds_die "Bad $name value in command line";
|
|
}
|
|
} else {
|
|
ds_die "Unknown check type for $name";
|
|
}
|
|
} else {
|
|
$self->{$kname} = $opts->{$name};
|
|
}
|
|
}
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub check_rules {
|
|
my ($self) = @_;
|
|
if ($self->can('rules')) {
|
|
if (my $rules = $self->rules) {
|
|
my $i = 0;
|
|
foreach my $sub (@$rules) {
|
|
$i++;
|
|
my ($res, $msg) = $sub->($self);
|
|
if ($res) {
|
|
ds_warn($msg) if ($msg);
|
|
} else {
|
|
ds_error($msg || "config rule $i");
|
|
# ds_error may not die if $Devscripts::Output::die_on_error
|
|
# is set to 0
|
|
next;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub _subs_check {
|
|
my ($self, $check, $kname, $name, $default) = @_;
|
|
if ($check eq 'bool') {
|
|
$check = sub {
|
|
$_[0]->{$kname} = (
|
|
$_[1] =~ /^(?:1|yes)$/i ? 1
|
|
: $_[1] =~ /^(?:0|no)$/i ? 0
|
|
: $default ? $default
|
|
: undef
|
|
);
|
|
return 1;
|
|
};
|
|
} else {
|
|
$self->die("Unknown check type for $name");
|
|
}
|
|
return $check;
|
|
}
|
|
|
|
# Default usage: switch to manpage
|
|
sub usage {
|
|
$progname =~ s/\.pl//;
|
|
exec("man", '-P', '/bin/cat', $progname);
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
=head1 SEE ALSO
|
|
|
|
L<devscripts>
|
|
|
|
=head1 AUTHOR
|
|
|
|
Xavier Guimard E<lt>yadd@debian.orgE<gt>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright 2018 by Xavier Guimard <yadd@debian.org>
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
=cut
|