summaryrefslogtreecommitdiffstats
path: root/lib/Devscripts/Config.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Devscripts/Config.pm')
-rw-r--r--lib/Devscripts/Config.pm418
1 files changed, 418 insertions, 0 deletions
diff --git a/lib/Devscripts/Config.pm b/lib/Devscripts/Config.pm
new file mode 100644
index 0000000..e13a5a1
--- /dev/null
+++ b/lib/Devscripts/Config.pm
@@ -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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-02 14:19:05 +0000