Adding upstream version 2.25.15.
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
This commit is contained in:
parent
10737b110a
commit
b543f2e88d
GPG key ID:
BCC918A2ABD66424
485 changed files with 191459 additions and 0 deletions
418
lib/Devscripts/Config.pm
Normal file
418
lib/Devscripts/Config.pm
Normal file
|
|
@ -0,0 +1,418 @@
|
|||
|
||||
=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
|
||||
Loading…
Add table
Add a link
Reference in a new issue