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