From c2801c794b9bcdcfecb9ce95bc1d449e6c58b128 Mon Sep 17 00:00:00 2001 From: Gustavo De Nardin Date: Sat, 12 May 2007 20:11:53 +0000 Subject: Restoring code lost in the SVN breakage from an old checkout --- lib/Iurt/Config.pm | 304 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 304 insertions(+) create mode 100644 lib/Iurt/Config.pm (limited to 'lib/Iurt/Config.pm') diff --git a/lib/Iurt/Config.pm b/lib/Iurt/Config.pm new file mode 100644 index 0000000..9efcd24 --- /dev/null +++ b/lib/Iurt/Config.pm @@ -0,0 +1,304 @@ +package Iurt::Config; + +use base qw(Exporter); +use RPM4::Header; +use Data::Dumper; +use MDK::Common; +use Iurt::Util qw(plog); +use strict; + +our @EXPORT = qw( + config_usage + config_init + get_date + dump_cache + dump_cache_par + init_cache + get_maint + get_date + get_prefix + get_repsys_conf + check_arch + check_noarch + get_package_prefix + %arch_comp +); + +our %arch_comp = ( + 'i586' => { 'i386' => 1, 'i486' => 1, 'i586' => 1 }, + 'i686' => { 'i386' => 1, 'i486' => 1, 'i586' => 1, 'i686' => 1 }, + 'x86_64' => { 'x86_64' => 1 }, + 'ppc' => { 'ppc' => 1 }, + 'ppc64' => { 'ppc' => 1, 'ppc64' => 1 }, +); + + +=head2 config_usage($config_usage, $config) + +Create an instance of a class at runtime. +I<$config_usage> is the configuration help, +I<%config> is the current configuration values +Return true. + +=cut + +sub config_usage { + my ($config_usage, $config) = @_; + print " + + Iurt configuration keywords: + +"; + $Data::Dumper::Indent = 0; + $Data::Dumper::Terse = 1; + foreach my $k (sort keys %$config_usage) { + print " $k: $config_usage->{$k}{desc} + default: ", Data::Dumper->Dump([ $config_usage->{$k}{default} ]), ", current: ", Data::Dumper->Dump([ $config->{$k} ]), "\n"; + } + print "\n\n"; +} + +=head2 config_init($config_usage, $config, $rung) + +Create an instance of a class at runtime. +I<$config_usage> is the configuration help, +I<%config> is the current configuration values +I<%run> is the current running options +Return true. + +=cut + +sub config_init { + my ($config_usage, $config, $run) = @_; + + foreach my $k (keys %$config_usage) { + ref $config_usage->{$k}{default} eq 'CODE' and next; + $config->{$k} ||= $run->{config}{$k} || $config_usage->{$k}{default}; + } + # warly 20061107 + # we need to have all the default initialised before calling functions, so this + # cannot be done in the same loop + foreach my $k (keys %$config_usage) { + ref $config_usage->{$k}{default} eq 'CODE' or next; + my $a = $config_usage->{$k}{default}($config, $run); + $config->{$k} ||= $run->{config}{$k} || $a; + } +} + + +=head2 get_date($shift) + +Create a string based on the current date and time +I<$shift> number of second to shift the date +Return date-time and date + +=cut + +sub get_date { + my ($o_shift) = @_; + my ($sec, $min, $hour, $mday, $mon, $year) = gmtime(time() - $o_shift); + $year += 1900; + my $fulldate = sprintf "%4d%02d%02d%02d%02d%02d", $year, $mon+1, $mday, $hour, $min, $sec; + my $daydate = sprintf "%4d%02d%02d", $year, $mon+1, $mday; + $fulldate, $daydate; +} + +sub get_prefix { + my ($luser) = @_; + my $hostname = `hostname`; + my ($fulldate) = get_date(); + my ($host) = $hostname =~ /([^.]*)/; + join('.', $fulldate, $luser, $host, $$) . '_'; +} + +sub get_package_prefix { + my ($rpm) = @_; + my ($prefix1) = $rpm =~ /^(\d{14}\.\w+\.\w+\.\d+)_/; + my ($prefix2) = $rpm =~ /^(\@\d+:)/; + "$prefix1$prefix2"; +} +=head2 init_cache($run, $config) + +Create a string based on the current date and time +I<%run> is the current running options +I<%config> is the current configuration values +Initialize the cache + +=cut + +sub init_cache { + my ($run, $config, $empty) = @_; + my $program_name = $run->{program_name}; + my $cachefile = "$config->{cache_home}/$program_name.cache"; + my $cache; + if (-f $cachefile) { + $run->{LOG}->("$program_name: loading cache file $cachefile\n"); + $cache = eval(cat_($cachefile)) or print "FATAL $program_name: could not load cache $cachefile ($!)\n"; + } else { + $cache = $empty; + } + $run->{cachefile} = $cachefile; + $run->{cache} = $cache; + $cache; +} + +=head2 dump_cache($run, $config) + +Create a string based on the current date and time +I<%run> is the current running options +Dump the cache + +=cut + +sub dump_cache { + my ($run) = @_; + my $program_name = $run->{program_name}; + my $filename = $run->{cachefile}; + my $cache = $run->{cache}; + my $daydate = $run->{daydate}; + open my $file, ">$filename.tmp.$daydate" or die "FATAL $program_name dump_cache: cannot open $filename.tmp"; + $Data::Dumper::Indent = 1; + $Data::Dumper::Terse = 1; + print $file Data::Dumper->Dump([ $cache ], [ "cache" ]); + # flock does not work on network files and lockf seems to fail too + $run->{LOG}->("$program_name: locking to dump the cache in $filename\n"); + if (-f "$filename.lock") { + $run->{LOG}->("ERROR iurt: manual file lock exist, do not save the cache\n"); + } else { + open my $lock, ">$filename.lock"; + print $lock $$; + close $lock; + unlink $filename; + link "$filename.tmp.$daydate", $filename; + unlink "$filename.lock"; + } +} + +# FIXME need to merge with the simpler dump_cache +sub dump_cache_par { + my ($run) = @_; + my $filename = $run->{cachefile}; + my $cache = $run->{cache}; + my $daydate = $run->{daydate}; + + # Right now there are no mechanism of concurrent access/write to the cache. There is + # on global lock for one iurt session. A finer cache access would allow several iurt running + # but the idea is more to have a global parrallel build than several local ones. + return if $run->{debug} || !$run->{use_cache}; + open my $file, ">$filename.tmp.$daydate" or die "FATAL iurt dump_cache: cannot open $filename.tmp"; + if ($run->{concurrent_run}) { + plog('DEBUG', "merging cache"); + my $old_cache; + if (-f $filename) { + plog('DEBUG', "loading cache file $filename"); + $old_cache = eval(cat_($filename)); + + foreach my $k ('rpm_srpm', 'failure', 'no_unionfs', 'queue', 'needed', 'warning', 'buildrequires') { + foreach my $rpm (%{$old_cache->{$k}}) { + $cache->{$k}{$rpm} ||= $old_cache->{$k}{$rpm}; + } + } + } + # $cache = { rpm_srpm => {}, failure => {}, queue => {}, warning => {}, run => 1, needed => {}, no_unionfs => {} } + } + $Data::Dumper::Indent = 1; + $Data::Dumper::Terse = 1; + print $file Data::Dumper->Dump([ $cache ], [ "cache" ]); + # flock does not work on network files and lockf seems to fail too + my $status = 1; #File::lockf::lock($file); + if (!$status) { + unlink $filename; + link "$filename.tmp.$daydate", $filename; + File::lockf::ulock($file); + } else { + plog('WARN', "WARNING: locking the cache file $filename failed (status $status $!), try to lock manually"); + if (-f "$filename.lock") { + plog('ERR', "ERROR: manual file lock exist, do not save the cache"); + } else { + open my $lock, ">$filename.lock"; + print $lock $$; + close $lock; + unlink $filename; + link "$filename.tmp.$daydate", $filename; + unlink "$filename.lock"; + } + } +} + +sub get_maint { + my ($run, $srpm) = @_; + my ($srpm_name) = $srpm =~ /(.*)-[^-]+-[^-]+\.[^.]+$/; + $srpm_name ||= $srpm; + if ($run->{maint}{$srpm}) { + return $run->{maint}{$srpm}, $srpm_name; + } + my $maint = `rpmmon -s -p "$srpm_name"`; + chomp $maint; + $run->{maint}{$srpm} = $maint; + $maint, $srpm_name; +} + +sub get_repsys_conf { + my ($file) = @_; + open my $fh, $file or return; + my %mail; + my $ok; + local $_; + while (<$fh>) { + if (/\[users\]/) { + $ok = 1; + } elsif (/\[/) { + $ok = 0; + } + $ok or next; + my ($user, $mail) = split " = "; + chomp $mail; + $mail{$user} = $mail; + $mail or next; + } + \%mail; +} + +sub check_noarch { + my ($rpm) = @_; + my $hdr = RPM4::Header->new($rpm); + + # Stupid rpm doesn't return an empty list so we must check for (none) + + my ($build_archs) = $hdr->queryformat('%{BUILDARCHS}'); + + if ($build_archs ne '(none)') { + ($build_archs) = $hdr->queryformat('[%{BUILDARCHS} ]'); + my @list = split ' ', $build_archs; + return 1 if member('noarch', @list); + } + + return 0; +} + +sub check_arch { + my ($rpm, $arch) = @_; + my $hdr = RPM4::Header->new($rpm); + + # Stupid rpm doesn't return an empty list so we must check for (none) + + my ($exclusive_arch) = $hdr->queryformat('%{EXCLUSIVEARCH}'); + + if ($exclusive_arch ne '(none)') { + ($exclusive_arch) = $hdr->queryformat('[%{EXCLUSIVEARCH} ]'); + my @list = split ' ', $exclusive_arch; + return 0 unless any { $arch_comp{$arch}{$_} } @list; + } + + my ($exclude_arch) = $hdr->queryformat('[%{EXCLUDEARCH} ]'); + + if ($exclude_arch ne '(none)') { + ($exclude_arch) = $hdr->queryformat('[%{EXCLUDEARCH} ]'); + my @list = split ' ', $exclude_arch; + return 0 if member($arch, @list); + } + + return 1; +} + +1; -- cgit v1.2.1