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/.perl_checker | 1 + lib/Iurt/Chroot.pm | 515 ++++++++++++++++++++++++++++++++ lib/Iurt/Config.pm | 304 +++++++++++++++++++ lib/Iurt/DKMS.pm | 318 ++++++++++++++++++++ lib/Iurt/File.pm | 68 +++++ lib/Iurt/Mail.pm | 27 ++ lib/Iurt/Process.pm | 355 ++++++++++++++++++++++ lib/Iurt/Urpmi.pm | 789 +++++++++++++++++++++++++++++++++++++++++++++++++ lib/Iurt/Util.pm | 203 +++++++++++++ 9 files changed, 2580 insertions(+) create mode 100644 lib/Iurt/.perl_checker create mode 100644 lib/Iurt/Chroot.pm create mode 100644 lib/Iurt/Config.pm create mode 100644 lib/Iurt/DKMS.pm create mode 100644 lib/Iurt/File.pm create mode 100644 lib/Iurt/Mail.pm create mode 100644 lib/Iurt/Process.pm create mode 100644 lib/Iurt/Urpmi.pm create mode 100644 lib/Iurt/Util.pm (limited to 'lib') diff --git a/lib/Iurt/.perl_checker b/lib/Iurt/.perl_checker new file mode 100644 index 0000000..2326e2f --- /dev/null +++ b/lib/Iurt/.perl_checker @@ -0,0 +1 @@ +Basedir ../.. diff --git a/lib/Iurt/Chroot.pm b/lib/Iurt/Chroot.pm new file mode 100644 index 0000000..5f055fa --- /dev/null +++ b/lib/Iurt/Chroot.pm @@ -0,0 +1,515 @@ +package Iurt::Chroot; + +use strict; +use base qw(Exporter); +use MDV::Distribconf::Build; +use MDK::Common; +use Iurt::Process qw(clean sudo); +use Iurt::Config qw(dump_cache_par); +use Iurt::Util qw(plog); +use File::Temp 'mktemp'; +use File::Path 'mkpath'; + +our @EXPORT = qw( + clean_chroot_tmp + clean_unionfs + clean_all_chroot_tmp + clean_all_unionfs + clean_chroot + dump_rpmmacros + add_local_user + create_temp_chroot + remove_chroot + create_chroot + create_buid_chroot + check_chroot + check_build_chroot +); + +my $sudo = '/usr/bin/sudo'; + +=head2 clean_chroot($chroot, $run, $only_clean) + +Create or clean a chroot +I<$chroot> chroot path +I<$run> is the running environment +I<%only_clean> only clean the chroot, do not create a new one +Return true. + +=cut + +sub clean_chroot { + my ($chroot, $chroot_tar, $run, $config, $o_only_clean, $o_only_tar) = @_; + + plog('DEBUG', "clean chroot"); + if (-d $chroot && !$o_only_tar) { + system("$sudo umount $chroot/proc &> /dev/null"); + system("$sudo umount $chroot/dev/pts &> /dev/null"); + sudo($run, $config, '--rm', '-r', $chroot); + } + + return 1 if $o_only_clean; + + mkdir $chroot; + + # various integrity checking + return 1 if $o_only_tar && -f "$chroot/home/builder/.rpmmacros" && -d "$chroot/home/builder" && -d "$chroot/proc"; + + chdir $chroot; + + system($sudo, 'tar', 'xf', $chroot_tar) and create_build_chroot($chroot, $chroot_tar, $run, $config); + + create_build_chroot($chroot, $chroot_tar, $run, $config) if !-d "$chroot/proc" || !-d "$chroot/home/builder"; + + dump_rpmmacros($run, $config, "$chroot/home/builder/.rpmmacros") or return; + system("$sudo mount none -t proc $chroot/proc &>/dev/null") and return; + system("$sudo mount none -t devpts $chroot/dev/pts &>/dev/null") and return; + 1; +} + +sub dump_rpmmacros { + my ($run, $config, $file) = @_; + my $f; + + #plog("adding rpmmacros to $file"); + + if (!open $f, qq(| $sudo sh -c "cat > $file")) { + plog("ERROR: could not open $file ($!)"); + return 0; + } + my $packager = $run->{packager} || $config->{packager}; + + print $f qq(\%_topdir \%(echo \$HOME)/rpm +\%_tmppath \%(echo \$HOME)/rpm/tmp/ +\%distribution $config->{distribution} +\%vendor $config->{vendor} +\%packager $packager); + # need to be root for permission +} + +sub add_local_user { + my ($chroot_tmp, $run, $config, $luser, $uid) = @_; + my $program_name = $run->{program_name}; + + # change the builder user to the local user id + # FIXME it seems that unionfs does not handle well the change of the + # uid of files + # if (system(qq|sudo chroot $chroot_tmp usermod -u $run->{uid} builder|)) { + + # this should not be necessary as the builder user is supposed to have + # the macros already + + foreach my $p ('RPMS', 'BUILD', 'SPECS', 'SRPMS', 'SOURCES') { + -d "$chroot_tmp/home/builder/rpm/$p" and next; + sudo($run, $config, "--mkdir", "$chroot_tmp/home/builder/rpm/$p"); + } + + dump_rpmmacros($run, $config, "$chroot_tmp/home/builder/.rpmmacros") or return; + + if ($uid) { + if (system($sudo, 'chroot', $chroot_tmp, 'useradd', '-M', '-u', $uid, $luser) || + system("$sudo chroot $chroot_tmp id $luser >/dev/null 2>&1")) { + plog('ERR', "ERROR: setting userid $uid to $luser in " . + "$chroot_tmp failed, checking the chroot"); + check_build_chroot($run->{chroot_path}, $run->{chroot_tar}, $run, + $config) or return; + } + } else { + # the program has been launch as root, setting the home to /home/root for compatibility + system($sudo, 'chroot', $chroot_tmp, 'usermod', '-d', "/home/$luser", '-u', $uid, '-o', '-l', $luser, 'root'); + } + + if (system(qq($sudo chroot $chroot_tmp cp -R /home/builder /home/$luser))) { + plog("ERROR: could not initialized $luser directory"); + return; + } + + if (system(qq($sudo chroot $chroot_tmp chown -R $uid /home/$luser))) { + die "ERROR $program_name: could not initialized $luser directory\n"; + } + + 1; +} + +sub create_temp_chroot { + my ($run, $config, $cache, $union_id, $chroot_tmp, $chroot_tar, $srpm) = @_; + + my $home = $config->{local_home}; + my $debug_tag = $run->{debug_tag}; + my $unionfs_dir = $run->{unionfs_dir}; + + if ($run->{unionfs_tmp}) { + my $mount_point = "$unionfs_dir/unionfs.$run->{run}.$union_id"; + plog(2, "cleaning temp chroot $mount_point"); + if (!clean_mnt($run, $mount_point, $run->{verbose})) { + dump_cache_par($run); + die "FATAL: can't kill remaining processes acceding $mount_point"; + } + my $tmpfs; + + # we cannont just rm -rf $tmpfs, this create defunct processes + # afterwards (and lock particularly hard the urpmi database) + # + $union_id = clean_unionfs($unionfs_dir, $run, $run->{run}, $union_id); + $tmpfs = "$unionfs_dir/tmpfs.$run->{run}.$union_id"; + $chroot_tmp = "$unionfs_dir/unionfs.$run->{run}.$union_id"; + + if (!-d $tmpfs) { + if (!mkpath($tmpfs)) { + plog("ERROR: Could not create $tmpfs ($!)"); + return; + } + } + if (! -d $chroot_tmp) { + if (!mkpath($chroot_tmp)) { + plog("ERROR: Could not create $chroot_tmp ($!)"); + return; + } + } + if ($cache->{no_unionfs}{$srpm}) { + $run->{unionfs_tmp} = 0; + clean_chroot($chroot_tmp, $chroot_tar, $run, $config); + } else { + # if the previous package has been built without unionfs, chroot need to be cleaned + if (!$run->{unionfs_tmp}) { + clean_chroot($chroot_tmp, $chroot_tar, $run, $config); + } else { + # only detar the chroot if not already + clean_chroot($chroot_tmp, $chroot_tar, $run, $config, 0, 1); + } + $run->{unionfs_tmp} = 1; + if (system(qq($sudo mount -t tmpfs none $tmpfs &>/dev/null))) { + plog("ERROR: can't mount $tmpfs ($!)"); + return; + } + if (system(qq($sudo mount -o dirs=$tmpfs=rw:$home/chroot_$run->{distro_tag}$debug_tag=ro -t unionfs none $chroot_tmp &>/dev/null))) { + plog("ERROR: can't mount $tmpfs and $home/chroot_$run->{distro_tag}$debug_tag with unionfs ($!)"); + return; + } + if (system("$sudo mount -t proc none $chroot_tmp/proc &>/dev/null")) { + plog("ERROR: can't mount /proc in chroot $chroot_tmp ($!)"); + return; + } + if (!-d "$chroot_tmp/dev/pts") { + if (sudo($run, $config, "--mkdir", "$chroot_tmp/dev/pts")) { + plog("ERROR: can't create /dev/pts in chroot $chroot_tmp ($!)"); + return; + } + + if (system($sudo, "mount", "-t", "devpts", "none", "$chroot_tmp/dev/pts &>/dev/null")) { + plog("ERROR: can't mount /dev/pts in the chroot $chroot_tmp ($!)"); + return; + } + } + } + } else { + plog("Install new chroot"); + plog('DEBUG', "... in $chroot_tmp"); + clean_chroot($chroot_tmp, $chroot_tar, $run, $config); + } + $union_id, $chroot_tmp; +} + +sub remove_chroot { + my ($run, $dir, $func, $prefix) = @_; + + plog("Remove existing chroot"); + plog('DEBUG', "... dir $dir all $run->{clean_all} prefix $prefix"); + + if ($run->{clean_all}) { + opendir my $chroot_dir, $dir; + foreach (readdir $chroot_dir) { + next if !-d "$dir/$_" || /\.{1,2}/; + plog("cleaning old chroot for $_ in $dir"); + $func->($run, "$dir/$_", $prefix); + } + } else { + foreach my $user (@{$run->{clean}}) { + plog("cleaning old chroot for $user in $dir"); + $func->($run, "$dir/$user", $prefix); + } + } +} + +sub clean_mnt { + my ($run, $mount_point, $verbose) = @_; + return clean($run, $mount_point, "/sbin/fuser", "$sudo /sbin/fuser -k", $verbose); +} + +sub clean_all_chroot_tmp { + my ($run, $chroot_dir, $prefix) = @_; + + plog(1, "cleaning all old chroot remaining dir in $chroot_dir"); + + my $dir; + if (!opendir $dir, $chroot_dir) { + plog("ERROR: can't open $chroot_dir ($!)"); + return; + } + foreach (readdir($dir)) { + /$prefix/ or next; + clean_chroot_tmp($run, $chroot_dir, $_); + } + closedir $dir; +} + +sub clean_unionfs { + my ($unionfs_dir, $_run, $r, $union_id) = @_; + + -d "$unionfs_dir/unionfs.$r.$union_id" or return $union_id; + plog(2, "cleaning unionfs $unionfs_dir/unionfs.$r.$union_id"); + my $nok = 1; + my $path = "$unionfs_dir/unionfs.$r.$union_id"; + + while ($nok) { + $nok = 0; + foreach my $fs ([ 'proc', 'proc' ], [ 'dev/pts', 'devpts' ]) { + my ($dir, $type) = @$fs; + if (-d "$path/$dir" && check_mounted("$path/$dir", $type)) { + plog(1, "clean_unionfs: umounting $path/$dir\n"); + if (system("$sudo umount $path/$dir &>/dev/null")) { + plog("ERROR: could not umount $path/$dir"); + } + } + } + foreach my $t ('unionfs', 'tmpfs') { + # unfortunately quite oftem the unionfs is busy and could not + # be unmounted + + my $d = "$unionfs_dir/$t.$r.$union_id"; + if (-d $d && check_mounted($d, $t)) { + $nok = 1; + system("$sudo /sbin/fuser -k $d &> /dev/null"); + plog(3, "umounting $d"); + if (system(qq($sudo umount $d &> /dev/null))) { + plog(2, "WARNING: could not umount $d ($!)"); + return $union_id + 1; + } + } + } + } + + foreach my $t ('unionfs', 'tmpfs') { + my $d = "$unionfs_dir/$t.$r.$union_id"; + plog(2, "removing $d"); + if (system($sudo, 'rm', '-rf', $d)) { + plog("ERROR: removing $d failed ($!)"); + return $union_id + 1; + } + } + $union_id; +} + +sub clean_chroot_tmp { + my ($run, $chroot_dir, $dir) = @_; + my $d = "$chroot_dir/$dir"; + + foreach my $m ('proc', 'dev/pts') { + if (system("$sudo umount $d/$m &>/dev/null") && $run->{verbose} > 1) { + plog("ERROR: could not umount /$m in $d/"); + } + } + + plog(1, "cleaning $d"); + system("$sudo /sbin/fuser -k $d &> /dev/null"); + plog(1, "removing $d"); + system($sudo, 'rm', '-rf', $d); +} + +sub check_mounted { + my ($mount_point, $type) = @_; + + my $mount; + if (!open $mount, '/proc/mounts') { + plog("ERROR: could not open /proc/mounts"); + return; + } + $mount_point =~ s,//+,/,g; + local $_; + while (<$mount>) { + return 1 if /^\w+ $mount_point $type /; + } + 0; +} + +sub create_build_chroot { + my ($chroot, $chroot_tar, $run, $config) = @_; + create_chroot($chroot, $chroot_tar, $run, $config, + { packages => $config->{basesystem_packages} }); +} + +sub create_chroot { + my ($chroot, $chroot_tar, $run, $config, $opt) = @_; + my $tmp_tar = mktemp("$chroot_tar.tmp.XXXXXX"); + my $tmp_chroot = mktemp("$chroot.tmp.XXXXXX"); + my $rebuild; + my $clean = sub { + plog("Remove temporary chroot tarball"); + sudo($run, $config, '--rm', '-r', $tmp_chroot, $tmp_tar); + }; + + plog('NOTIFY', "creating chroot"); + plog('DEBUG', "... with packages " . join(', ', @{$opt->{packages}})); + + if (mkdir($tmp_chroot) && (!-f $chroot_tar || link $chroot_tar, $tmp_tar)) { + if (!-f $chroot_tar) { + plog("rebuild chroot tarball"); + $rebuild = 1; + if (!build_chroot($run, $config, $tmp_chroot, $chroot_tar, $opt)) { + $clean->(); + return; + } + } else { + plog('DEBUG', "decompressing /var/log/qa from $chroot_tar in $tmp_chroot"); + system($sudo, 'tar', 'xf', $chroot_tar, '-C', $tmp_chroot, "./var/log/qa"); + + my $qa; + if (open $qa, "$tmp_chroot/var/log/qa") { + my $ok; + my $f; + while (!$ok && ($f = <$qa>)) { + chomp $f; + if (!-f "$config->{basesystem_media_root}/media/$config->{basesystem_media}/$f") { + plog('DEBUG', "$f has changed"); + plog('NOTIFY', "Rebuilding chroot tarball"); + + $rebuild = 1; + sudo($run, $config, '--rm', '-r', $tmp_chroot); + mkdir $tmp_chroot; + if (!build_chroot($run, $config, $tmp_chroot, $chroot_tar, $opt)) { + $clean->(); + return; + } + $ok = 1; + } + } + } else { + plog('DEBUG', "can't open $tmp_chroot/var/log/qa"); + plog('ERR', "can't check chroot, recreating"); + + if (!build_chroot($run, $config, $tmp_chroot, $chroot_tar, $opt)) { + $clean->(); + return; + } + } + } + link $tmp_tar, $chroot_tar; + } else { + die "FATAL: could not initialize chroot ($!)\n"; + } + + if (!-d $chroot || $rebuild) { + plog('DEBUG', "recreate chroot $chroot"); + plog('NOTIFY', "recreate chroot"); + my $urpmi = $run->{urpmi}; + $urpmi->clean_urpmi_process($chroot); + sudo($run, $config, '--rm', '-r', $chroot, $tmp_tar); + mkdir_p $chroot; + system($sudo, 'tar', 'xf', $chroot_tar, '-C', $chroot); + plog('NOTIFY', "chroot recreated in $chroot_tar (live in $chroot)"); + } + + $clean->(); + + 1; +} + +sub build_chroot { + my ($run, $config, $tmp_chroot, $chroot_tar, $opt) = @_; + + plog('DEBUG', "building the chroot with " + . join(', ', @{$opt->{packages}})); + + sudo($run, $config, "--mkdir", "-p", "$tmp_chroot/dev/pts", + "$tmp_chroot/etc/sysconfig", "$tmp_chroot/proc"); + + # create empty files + foreach ('/etc/ld.so.conf', '/etc/mtab') { + system($sudo, 'touch', "$tmp_chroot$_"); + } + + system($sudo, 'mknod', "$tmp_chroot/dev/null", 'c', 1, 3); + system("$sudo chmod a+rw $tmp_chroot/dev/null"); + + #system(qq($sudo sh -c "echo 127.0.0.1 localhost > $tmp_chroot/etc/hosts")); + # warly some program perform a gethostbyname(hostname) and in the cluster the + # name are not resolved via DNS but via /etc/hosts + sudo($run, $config, '--cp', "/etc/hosts", "$tmp_chroot/etc/"); + sudo($run, $config, '--cp', "/etc/resolv.conf", "$tmp_chroot/etc/"); + + sudo($run, $config, "--initdb", $tmp_chroot); + # install chroot + my $urpmi = $run->{urpmi}; + $urpmi->set_command($tmp_chroot); + + # 20060826 warly urpmi --root does not work properly + $urpmi->install_packages( + "chroot", + $tmp_chroot, + $run->{local_spool}, + {}, + 'initialize', + "[ADMIN] creation of initial chroot failed on $run->{my_arch}", + { maintainer => $config->{admin} }, + @{$opt->{packages}} + ); + + if (-f "$tmp_chroot/bin/rpm") { + system($sudo, 'sh', '-c', "chroot $tmp_chroot rpm -qa --qf '\%{NAME}-\%{VERSION}-\%{RELEASE}.\%{ARCH}.rpm\n' > $tmp_chroot/var/log/qa"); + # + # CM: Choose a sub-500 uid to prevent collison with $luser + # + system($sudo, 'chroot', $tmp_chroot, 'adduser', '-o', '--uid', 499, 'builder'); + sudo($run, $config, "--mkdir", "-p", "$tmp_chroot/home/builder/rpm"); + foreach my $p (qw(RPMS BUILD SPECS SRPMS SOURCES tmp)) { + -d "$tmp_chroot/home/builder/rpm/$p" and next; + sudo($run, $config, "--mkdir", "$tmp_chroot/home/builder/rpm/$p"); + } + system($sudo, 'chown', '-R', 499, "$tmp_chroot/home/builder"); + sudo($run, $config, "--rm", "$tmp_chroot/var/lib/rpm/__db*"); + return !system($sudo, 'tar', 'czf', $chroot_tar, '-C', $tmp_chroot, '.'); + } +} + +sub check_build_chroot { + my ($chroot, $chroot_tar, $run, $config) = @_; + + check_chroot($chroot, $chroot_tar, $run, $config, + { packages => $config->{basesystem_packages} }); +} + +sub check_chroot { + my ($chroot, $chroot_tar, $run, $config, $opt) = @_; + + plog('DEBUG', "checking basesystem tar"); + + my (@stat) = stat $chroot_tar; + + if (time -$stat[9] > 604800) { + plog('WARN', "chroot tarball too old, force rebuild"); + sudo($run, $config, '--rm', '-r', $chroot, $chroot_tar); + } + create_chroot($chroot, $chroot_tar, $run, $config, $opt); +} + +sub clean_all_unionfs { + my ($run, $unionfs_dir) = @_; + + plog(2, "Cleaning old unionfs remaining dir in $unionfs_dir"); + + my $dir; + if (!opendir $dir, $unionfs_dir) { + plog(0, "FATAL could not open $unionfs_dir ($!)"); + return; + } + + foreach (readdir $dir) { + /unionfs\.((?:0\.)?\d+)\.(\d*)$/ or next; + clean_unionfs($unionfs_dir, $run, $1, $2); + } + + closedir $dir; +} + + +1; 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; diff --git a/lib/Iurt/DKMS.pm b/lib/Iurt/DKMS.pm new file mode 100644 index 0000000..5ab46c8 --- /dev/null +++ b/lib/Iurt/DKMS.pm @@ -0,0 +1,318 @@ +package Iurt::DKMS; + +use strict; +use base qw(Exporter); +use MDV::Distribconf::Build; +use Iurt::Chroot qw(clean_chroot add_local_user dump_rpmmacros); +use Iurt::Config qw(get_maint get_prefix dump_cache init_cache); +use File::NCopy qw(copy); +use Iurt::Process qw(sudo); +use Iurt::Util qw(plog); +use RPM4::Header; +use MDK::Common; + +our @EXPORT = qw( + search_dkms + dkms_compile +); + +sub new { + my ($class, %opt) = @_; + my $self = bless { + config => $opt{config}, + run => $opt{run}, + }, $class; + + $self; +} + +=head2 search_dkms($run, $config) + +Search for dkms packages which needs to be recompiled for new kernel +I<$run> is the running environment +I<%config> is the current configuration values +Return true. + +=cut + +sub search_dkms { + my ($self) = @_; + my $config = $self->{config}; + my $run = $self->{run}; + my $arch = $run->{my_arch}; + my $root = $config->{repository}; + my $distro = $run->{distro}; + my $cache = $run->{cache}; + my $path = "$root/$distro/$arch"; + if (!-d $path) { + plog('ERR', "ERROR: $path is not a directory"); + return; + } + my $distrib = MDV::Distribconf::Build->new($path); + plog("getting media config from $path"); + if (!$distrib->loadtree) { + plog('ERR', "ERROR: $path does not seem to be a distribution tree"); + return; + } + $distrib->parse_mediacfg; + my %dkms; + my @kernel; + my %modules; + my %kernel_source; + foreach my $media ($distrib->listmedia) { + $media =~ /(SRPMS|debug_)/ and next; + my $path = $distrib->getfullpath($media, 'path'); + my $media_ok = $run->{dkms}{media} ? $media =~ /$run->{dkms}{media}/ : 1; + my $kmedia_ok = $run->{dkms}{kmedia} ? $media =~ /$run->{dkms}{kmedia}/ : 1; + plog("searching in $path"); + opendir my $rpmdh, $path; + foreach my $rpm (readdir $rpmdh) { + if ($rpm =~ /^dkms-(.*)-([^-]+-[^-]+)\.[^.]+\.rpm/) { + # we only check for kernel or modules in this media + $media_ok or next; + my $hdr = RPM4::Header->new("$path/$rpm"); + my $files = $hdr->queryformat('[%{FILENAMES} ])'); + my ($name, $version) = ($1, $2); + my ($modulesourcedir) = $files =~ m, /usr/src/([^/ ]+),; + my $script = $hdr->queryformat('%{POSTIN})'); + my ($realversion) = $script =~ / -v (\S+)/; + plog('NOTIFY', "dkms $name version $version source $modulesourcedir realversion $realversion"); + push @{$dkms{$media}}, [ $name, $version, $modulesourcedir, $realversion, "$path/$rpm" ]; + } elsif ($rpm =~ /^kernel-((?:[^-]+-)?[^-]+.*)-[^-]+-[^-]+\.[^.]+\.rpm/ && $rpm !~ /win4lin|latest|debug|stripped|BOOT|xen|doc/) { + # we do not check for kernel in this media + $kmedia_ok or next; + my $hdr = RPM4::Header->new("$path/$rpm"); + my $files = $hdr->queryformat('[%{FILENAMES} ])'); + my $version = $1; + if ($version =~ /(.*)source-(.*)/) { + my $source = "$1$2"; + my ($sourcedir) = $files =~ m, /usr/src/([^/ ]+),; + plog('NOTIFY', "kernel source $version ($source sourcedir $sourcedir)"); + $kernel_source{$source} = [ $version, $sourcedir ]; + } else { + my ($modulesdir) = $files =~ m, /lib/modules/([^/ ]+),; + plog('NOTIFY', "kernel $version (modules dir $modulesdir)"); + push @kernel, [ $version, $modulesdir ]; + } + } elsif ($rpm =~ /^(.*)-kernel-([^-]+-[^-]+.*)-([^-]+-[^-]+)\.[^.]+\.rpm$/) { + plog('NOTIFY', "modules $1 version $3 for kernel $2"); + # module version kernel + $modules{$1}{$3}{$2} = 1; + } + } + } + my $nb; + foreach my $media (keys %dkms) { + foreach my $dkms (@{$dkms{$media}}) { + my ($module, $version, $modulesourcedir, $realversion, $file) = @$dkms; + foreach my $k (@kernel) { + my ($kernel, $modulesdir) = @$k; + plog("checking $module-kernel-$modulesdir-$realversion"); + next if $cache->{dkms}{"$module-kernel-$modulesdir-$realversion"} && !$run->{ignore_failure}; + if (!$modules{$module}{$version}{$modulesdir}) { + my ($name, $v) = $kernel =~ /^([^-]+)-.*-(2\..*)/; + my $source = "$name-$v"; + if (!$kernel_source{$source}) { + my ($name) = $kernel =~ /(2\..*)/; + plog('ERR', "ERROR: no source for kernel $kernel (source $source), testing $name"); + $source = $name; + if (!$kernel_source{$source}) { + my $name = $kernel; + plog('ERR', "ERROR: no source for kernel $kernel (source $source), testing $name"); + $source = $name; + if (!$kernel_source{$source}) { + plog('ERR', "ERROR: no source for kernel $kernel (source $source), ignoring"); + next; + } + } + } + plog("dkms module $module version $version should be compiled for kernel $kernel ($source)"); + $nb++; + push @{$run->{dkms_todo}}, [ $module, $version, $modulesourcedir, $realversion, $file, $kernel, $modulesdir, @{$kernel_source{$source}}, $media ]; + } + $modules{$module}{$version}{$modulesdir}++; + } + } + } + foreach my $module (keys %modules) { + foreach my $version (keys %{$modules{$module}}) { + foreach my $modulesdir (keys %{$modules{$module}{$version}}) { + next if $modules{$module}{$version}{$modulesdir} < 2; + plog('WARN', "dkms module $module version $version for kernel $modulesdir is obsolete"); + push @{$run->{dkms_obsolete}}, "$module-kernel-$modulesdir-$version"; + } + } + } + $nb; +} + +=head2 dkms_compile($class, $local_spool, $done) + +Compile the dkms against the various provided kernel +Return true. + +=cut + +sub dkms_compile { + my ($self, $local_spool, $done) = @_; + my $config = $self->{config}; + my $run = $self->{run}; + my $urpmi = $run->{urpmi}; + # For dkms build, the chroot is only installed once and the all the modules are recompiled + my $chroot_tmp = $run->{chroot_tmp}; + my $chroot_tar = $run->{chroot_tar}; + my $cache = $run->{cache}; + my $luser = $run->{user}; + my $to_compile = $run->{to_compile}; + + plog("building chroot: $chroot_tmp"); + clean_chroot($chroot_tmp, $chroot_tar, $run, $config); + my %installed; + # initialize urpmi command + $urpmi->urpmi_command($chroot_tmp, $luser); + # also add macros for root + add_local_user($chroot_tmp, $run, $config, $luser, $run->{uid}); + + if (!dump_rpmmacros($run, $config, "$chroot_tmp/home/$luser/.rpmmacros") || !dump_rpmmacros($run, $config, "$chroot_tmp/root/.rpmmacros")) { + plog('ERR', "ERROR: adding rpmmacros failed"); + return; + } + + my $kerver = `uname -r`; + chomp $kerver; + + my $dkms_spool = "$local_spool/dkms/"; + -d $dkms_spool or mkdir $dkms_spool; + + for (my $i; $i < @{$run->{dkms_todo}}; $i++) { + my ($name, $version, $_modulesourcedir, $realversion, $file, $kernel, $modulesdir, $source, $sourcedir, $media) = @{$run->{dkms_todo}[$i]}; + $done++; + + plog("dkms modules $name version $version for kernel $kernel [$done/$to_compile]"); + + # install kernel and dkms if not already installed + my $ok = 1; + # some of the dkms modules does not handle correclty the -k option and use uname -r to + # find kernel modules dir. + # FIXME must send a mail to the maintainer for that problem + # try to workarround with a symlink + if ($kerver ne $modulesdir) { + if (-e "$chroot_tmp/lib/modules/$kerver") { + system("sudo mv $chroot_tmp/lib/modules/$kerver $chroot_tmp/lib/modules/$kerver.tmp"); + } + if (system("sudo ln -sf $modulesdir $chroot_tmp/lib/modules/$kerver")) { + plog('ERR', "ERROR: creating a link from $chroot_tmp/lib/modules/$modulesdir to $kerver failed ($!)"); + next; + } + } + foreach my $pkg ("kernel-$source", "dkms", "kernel-$kernel", $file) { + my $pkgname = basename($pkg); + if ($run->{chrooted_urpmi} && -f $pkg) { + copy $pkg, "$chroot_tmp/tmp/"; + $pkg = "/tmp/$pkgname"; + } + if (!$installed{$pkg}) { + plog('DEBUG', "install package: $pkg"); + if (!$urpmi->install_packages("dkms-$name-$version", $chroot_tmp, $local_spool, {}, "dkms_$pkgname", "[DKMS] package $pkg installation error", { maintainer => $config->{admin} }, $pkg)) { + plog('ERR', "ERROR: error installing package $pkg"); + $ok = 0; + last; + } + $installed{$pkg} = 1; + } + # recreate the appropriate kernel source link + } + $ok or next; + + plog('DEBUG', "symlink from /lib/modules/$modulesdir/build to /usr/src/$sourcedir"); + + if (system("sudo ln -sf /usr/src/$sourcedir $chroot_tmp/lib/modules/$modulesdir/build")) { + plog('ERR', "linking failed ($!)"); + next; + } + # seems needed for some kernel + system("cd $chroot_tmp/usr/src/$sourcedir && sudo make prepare"); + # If the dkms packages get installed, the modules is correclty built + # but if we just compile it for a new kernel, we need to rebuild it manually + + foreach my $cmd ('add', 'build') { + my $command = "TMP=/home/$luser/tmp/ sudo chroot $chroot_tmp /usr/sbin/dkms $cmd -m $name -v $realversion --rpm_safe_upgrade -k $modulesdir --kernelsourcedir=/usr/src/$sourcedir"; + plog('DEBUG', "execute: $command"); + system($command); + } + + # now need to move dkms build if it wrongly assume a build for the running kernel + plog("search module in /var/lib/dkms/$name/$version/$kerver/"); + if (-d "$chroot_tmp/var/lib/dkms/$name/$version/$kerver/") { + system("sudo mv $chroot_tmp/var/lib/dkms/$name/$realversion/$kerver/ $chroot_tmp/var/lib/dkms/$name/$realversion/$modulesdir/"); + } + $cache->{dkms}{"$name-kernel-$modulesdir-$realversion"} = 1; + if (system("sudo chroot $chroot_tmp /usr/sbin/dkms mkrpm -m $name -v $realversion --rpm_safe_upgrade -k $modulesdir")) { + plog('FAIL', "build failed ($!)"); + next; + } + + plog('OK', "build succesful, copy packages to $dkms_spool/$media"); + + -d "$dkms_spool/$media" or mkdir_p "$dkms_spool/$media"; + + system("cp $chroot_tmp/home/$luser/rpm/RPMS/*/*.rpm $dkms_spool/$media/ &>/dev/null") && system("cp $chroot_tmp/usr/src/rpm/RPMS/*/*.rpm $dkms_spool/$media/ &>/dev/null") and $run->{LOG}->("ERROR: could not copy dkms packages from $chroot_tmp/usr/src/rpm/RPMS/*/*.rpm or $chroot_tmp/home/$luser/rpm/RPMS/*/*.rpm to $dkms_spool/$media ($!)\n"); + !sudo($run, $config, '--rm', "$chroot_tmp/home/$luser/rpm/RPMS/*/*.rpm") || !sudo($run, $config, '--rm', "$chroot_tmp/usr/src/rpm/RPMS/*/*.rpm") and $run->{LOG}->("ERROR: could not delete dkms packages from $chroot_tmp/usr/src/rpm/RPMS/*/*.rpm or $chroot_tmp/home/$luser/rpm/RPMS/*/*.rpm ($!)\n"); + + if ($kerver ne $modulesdir) { + system("sudo rm -f $kerver $chroot_tmp/lib/modules/$modulesdir"); + if (-e "$chroot_tmp/lib/modules/$kerver.tmp") { + system("sudo mv $chroot_tmp/lib/modules/$kerver.tmp $chroot_tmp/lib/modules/$kerver"); + } + } + process_dkms_queue($self, 0, 0, $media, "$dkms_spool/$media"); + # compile dkms modules + } + dump_cache($run); + $done; +} +# FIXME will replace the iurt2 process_qeue when youri-queue is active +sub process_dkms_queue { + my ($self, $wrong_rpm, $quiet, $media, $dir) = @_; + my $run = $self->{run}; + return if !$run->{upload} && $quiet; + my $config = $self->{config}; + my $cache = $run->{cache}; + $media ||= $run->{media}; + my $urpmi = $run->{urpmi}; + + $dir ||= "$config->{local_upload}/iurt/$run->{distro_tag}/$run->{my_arch}/$media}/"; + + plog("processing $dir"); + opendir my $rpmdir, $dir or return; + # get a new prefix for each package so that they will not be all rejected if only one is wrong + my $prefix = get_prefix('iurt'); + foreach my $rpm (readdir $rpmdir) { + my ($rarch, $srpm) = $urpmi->update_srpm($dir, $rpm, $wrong_rpm); + $rarch or next; + plog('DEBUG', $rpm); + next if !$run->{upload}; + + plog("copy $rpm to $config->{upload_queue}/$run->{distro}/$media/"); + + # recheck if the package has not been uploaded in the meantime + my $rpms_dir = "$config->{repository}/$run->{distro}/$run->{my_arch}/media/$media/"; + if (! -f "$rpms_dir/$rpm") { + my $err = system("/usr/bin/scp", "$dir/$rpm", $config->{upload_queue} . "/$run->{distro}/$media/$prefix$rpm"); + # try to keep the opportunity to prevent disk full " + if ($err) { + #$run->{LOG}->("ERROR process_queue: cannot copy $dir/$rpm to ", $config->{upload_queue}, "/$run->{distro}/$media/$prefix$rpm ($!)\n"); + next; + } + } + if ($run->{upload_source}) { + #should not be necessary + } + # should not be necessary to use sudo + sudo($run, $config, '--rm', "$dir/$rpm"); + $cache->{queue}{$srpm} = 1; + } + closedir $rpmdir; +} + +1; diff --git a/lib/Iurt/File.pm b/lib/Iurt/File.pm new file mode 100644 index 0000000..ba5f718 --- /dev/null +++ b/lib/Iurt/File.pm @@ -0,0 +1,68 @@ +package Iurt::File; + +use base qw(Exporter); +use Iurt::Util qw(plog); +use strict; + +our @EXPORT = qw( + check_upload_tree +); + +=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 check_upload_tree { + my ($_run, $todo, $func, $post) = @_; + + # Squash double slashes for cosmetics + $todo =~ s!/+!/!g; + + opendir my $dir, $todo; + plog('INFO', "check dir: $todo"); + + foreach my $f (readdir $dir) { + $f =~ /^\.{1,2}$/ and next; + if (-d "$todo/$f") { + plog('DEBUG', "checking target $todo/$f"); + opendir my $target_dir, "$todo/$f"; + + foreach my $m (readdir $target_dir) { + $m =~ /^\.{1,2}$/ and next; + if (-d "$todo/$f/$m") { + plog('DEBUG', "checking media $todo/$f/$m"); + opendir my $media_dir, "$todo/$f/$m"; + + foreach my $s (readdir $media_dir) { + $s =~ /^\.{1,2}$/ and next; + if (-d "$todo/$f/$m/$s") { + if ($func) { + opendir my $submedia_dir, "$todo/$f/$m/$s"; + foreach my $r (readdir $submedia_dir) { + $r =~ /^\.{1,2}$/ and next; + $func->($todo, $f, $m, $s, $r); + } + } + # cleaning + if ($post) { + opendir my $submedia_dir, "$todo/$f/$m/$s"; + foreach my $r (readdir $submedia_dir) { + $r =~ /^\.{1,2}$/ and next; + $post->($todo, $f, $m, $s, $r); + } + } + } else { + # may need to check also here for old target + } + } + } + } + } + } +} + diff --git a/lib/Iurt/Mail.pm b/lib/Iurt/Mail.pm new file mode 100644 index 0000000..b805db2 --- /dev/null +++ b/lib/Iurt/Mail.pm @@ -0,0 +1,27 @@ +package Iurt::Mail; + +use strict; +use MIME::Words qw(encode_mimewords); +use base qw(Exporter); + +our @EXPORT = qw( + sendmail +); + +sub sendmail { + my ($to, $cc, $subject, $text, $from, $debug) = @_; + do { print "Cannot find sender-email-address [$to]\n"; return } unless defined($to); + my $MAIL; + if (!$debug) { open $MAIL, "| /usr/sbin/sendmail -t" or return } else { open $MAIL, ">&STDOUT" or return } + my $sender = encode_mimewords($to); + $subject = encode_mimewords($subject); + print $MAIL "To: $sender\n"; + if ($cc) { $cc = encode_mimewords($cc); print $MAIL "Cc: $cc\n" } + print $MAIL "From: $from\n"; + print $MAIL "Subject: $subject\n"; + print $MAIL "\n"; + print $MAIL $text; + close($MAIL); +} + +1 diff --git a/lib/Iurt/Process.pm b/lib/Iurt/Process.pm new file mode 100644 index 0000000..6982a65 --- /dev/null +++ b/lib/Iurt/Process.pm @@ -0,0 +1,355 @@ +package Iurt::Process; + +use strict; +use base qw(Exporter); +use MDK::Common; +use Filesys::Df qw(df); +use Iurt::Mail qw(sendmail); +use Iurt::Config qw(dump_cache_par); +use Iurt::Util qw(plog); +use POSIX ":sys_wait_h"; + +our @EXPORT = qw( + kill_for_good + clean_process + check_pid + clean + perform_command + sudo +); + +=head2 config_usage($program_name, $run) + +Check that there is no other program running and create a pidfile lock +I<$run> current running options +Return true. + +=cut + +# CM: this actually doesn't offer race-free locking, a better system +# should be designed + +sub check_pid { + my ($run) = @_; + + my $pidfile = "$run->{pidfile_home}/$run->{pidfile}"; + + # Squash double slashes for cosmetics + $pidfile =~ s!/+!/!g; + + plog('DEBUG', "check pidfile: $pidfile"); + + if (-f $pidfile) { + my (@stat) = stat $pidfile; + + open my $test_PID, $pidfile; + my $pid = <$test_PID>; + close $test_PID; + + if (!$pid) { + plog('ERR', "ERROR: invalid pidfile ($pid), should be "); + unlink $pidfile; + } + + if ($pid && getpgrp $pid != -1) { + my $time = $stat[9]; + my $state = `ps h -o state $pid`; + chomp $state; + + if ($time < time()-7200 || $state eq 'Z') { + my $i; + + plog('WARN', "another instance [$pid] is too old, killing it"); + + while ($i < 5 && getpgrp $pid != -1) { + kill_for_good($pid); + $i++; + sleep 1; + } + } else { + plog("another instance [$pid] is already running for ", + time()-$time, " seconds"); + exit(); + } + } else { + plog('WARN', "cleaning stale lockfile"); + unlink $pidfile; + } + } + + open my $PID, ">$pidfile" + or die "FATAL: can't open pidfile $pidfile for writing"; + + print $PID $$; + close $PID; + $pidfile; +} + +=head2 perform_command($command, $run, $config, $cache, %opt) + +Run a command and check various running parameters such as log size, timeout... +I<$command> the command to run +I<$run> current running options +I<$config> the configuration +I<$cache> cached values +I<%opt> the options for the command run +Return true. + +=cut + +sub perform_command { + my ($command, $run, $config, $cache, %opt) = @_; + + $opt{timeout} ||= 300; + $opt{freq} ||= 24; + $opt{type} ||= 'shell'; + + plog('DEBUG', "Timeout $opt{timeout}"); + + my ($output, $fulloutput, $comment); + my ($kill, $pipe); + + if ($opt{debug}) { + if ($opt{type} eq 'perl') { + print "Would run perl command with timeout = $opt{timeout}\n"; + } else { + print "Would run $command with timeout = $opt{timeout}\n"; + } + return 1; + } + + local $SIG{PIPE} = sub { print "Broken pipe!\n"; $pipe = 1 }; + + my $retry = $opt{retry} || 1; + my $call_ret = 1; + my ($err, $pid, $try); + my $logfile = "$opt{log}/$opt{logname}.$run->{run}.log"; + my $max_retry = $config->{max_command_retry} < $retry ? + $retry : $config->{max_command_retry}; + + while ($retry) { + $try++; + if ($opt{retry} > 1) { + $logfile = "$opt{log}/$opt{logname}-$try.$run->{run}.log"; + } + if ($opt{log}) { + my $parent_pid = $$; + $pid = fork(); + #close STDIN; close STDERR;close STDOUT; + my $tot_time; + if (!$pid) { + plog('DEBUG', "Forking to monitor log size"); + $run->{main} = 0; + local $SIG{ALRM} = sub { exit() }; + $tot_time += sleep 30; + my $size_limit = $config->{log_size_limit}; + $size_limit =~ s/k/000/i; + $size_limit =~ s/M/000000/i; + $size_limit =~ s/G/000000000/i; + while ($tot_time < $opt{timeout}) { + my (@stat) = stat $logfile; + if ($stat[7] > $size_limit) { + plog('WARN', "WARNING: killing current command because of log size exceeding limit ($stat[7] > $config->{log_size_limit})"); + kill 14, "-$parent_pid"; + exit(); + } + my $df = df $opt{log}; + if ($df->{per} == 100) { + plog('WARN', "WARNING: killing current command because running out of disk space (only $df->{bavail}KB left)"); + kill 14, "-$parent_pid"; + exit(); + } + $tot_time += sleep 30; + } + exit(); + } + } + + eval { + local $SIG{ALRM} = sub { + print "Timeout!\n"; + $kill = 1; + die "alarm\n"; # NB: \n required + }; + + alarm $opt{timeout}; + + if ($opt{type} eq 'perl') { + plog('DEBUG', "perl command"); + $command->[0](@{$command->[1]}); + } else { + plog('DEBUG', $command); + if ($opt{log}) { + #$output = `$command 2>&1 2>&1 | tee $opt{log}/$opt{hash}.$run.log`; + system("$command &> $logfile"); + } else { + $output = `$command 2>&1`; + } + } + alarm 0; + }; + + $err = $?; + $err = 0 if any { $_ == $err } @{$opt{error_ok}}; + + # kill pid watching log file size + if ($pid) { + kill_for_good($pid); + } + + if ($@) { # timed out + # propagate unexpected errors + die "FATAL: unexpected signal ($@)" unless $@ eq "alarm\n"; + } + + # Keep the run first on the harddrive so that one can check the + # command status tailing it + if ($opt{log} && open my $log, $logfile) { + local $/; + $output = <$log>; + } + + $fulloutput .= $output; + if (ref $opt{callback}) { + $call_ret = $opt{callback}(\%opt, $output); + $call_ret == -1 and return 1; + $call_ret == -2 and return 0; + } + + if ($kill && $opt{type} ne 'shell') { + $comment = "Command killed after $opt{timeout}s: $command\n"; + my ($cmd_to_kill) = $command =~ /sudo(?: chroot \S+)? (.*)/; + clean_process($run, $cmd_to_kill, $run->{verbose}); + } elsif ($pipe) { + $comment = "Command received SIGPIPE: $command\n"; + sendmail($config->{admin}, '' , + "$opt{hash} on $run->{my_arch} for $run->{media}: broken pipe", + "$comment\n$output", "Iurt the build bot <$config->{admin}>", + $opt{debug_mail}); + } else { + if ($opt{type} eq 'shell') { + $comment = "Command failed: $command\n"; + } else { + $comment = "Command failed: $opt{type}\n"; + } + } + + # Maybe this has to be put before all the commands altering the + # $output var + + my $inc; + if ($opt{wait_regexp}) { + foreach my $wr (keys %{$opt{wait_regexp}}) { + if ($output =~ /$wr/m) { + if (ref $opt{wait_regexp}{$wr}) { + $inc = $opt{wait_regexp}{$wr}(\%opt, $output); + } + plog('ERR', "ERROR: $wr !"); + + sendmail($config->{admin}, '' , "$opt{hash} on $run->{my_arch} for $run->{media}: could not proceed", "$wr\n\n$comment\n$output", "Iurt the rebuild bot <$config->{admin}>", $opt{debug_mail}) if $opt{wait_mail}; + } + } + } + + if ($inc && $try < $max_retry) { + $retry += $inc; + } elsif ($call_ret && !$kill && !$err && !$opt{error_regexp} || $fulloutput !~ /$opt{error_regexp}/) { + $retry = 0; + } else { + $retry--; + } + } + + if (!$call_ret || $kill || $err || $opt{error_regexp} && $fulloutput =~ /$opt{error_regexp}/) { + + plog('ERR', "ERROR: call_ret=$call_ret kill=$kill err=$err ($opt{error_regexp})"); + + if ($opt{log} && $config->{log_url}) { + $comment = qq(See $config->{log_url}/$run->{distro_tag}/$run->{my_arch}/$run->{media}/log/$opt{srpm}/\n\n$comment); + } + + my $out; + if (length $fulloutput < 10000) { + $out = $fulloutput; + } else { + $out = "Message too big, see http link for details\n"; + } + + if ($opt{mail} && $config->{sendmail} && !$config->{no_mail}{$opt{mail}}) { + if (! ($cache->{warning}{$opt{hash}}{$opt{mail}} % $opt{freq})) { + my $cc = join ',', grep { !$config->{no_mail}{$_} } split ',', $opt{cc}; + sendmail($opt{mail}, $cc, $opt{error} , "$comment\n$out", "Iurt the rebuild bot <$config->{admin}>", $opt{debug_mail}); + } elsif ($config->{admin}) { + sendmail($config->{admin}, '' , $opt{error}, "$comment\n$out", "Iurt the rebuild bot <$config->{admin}>", $opt{debug_mail}); + } + } + $cache->{warning}{$opt{hash}}{$opt{mail}}++; + plog('FAIL', $comment); + plog('WARN', "--------------- Command failed, full output follows ---------------"); + plog('INFO', $fulloutput); + plog('WARN', "--------------- end of command output ---------------"); + + if ($opt{die}) { + dump_cache_par($run); + die "FATAL: $opt{error}."; + } + return 0; + } + 1; +} + +sub clean_process { + my ($run, $match, $verbose) = @_; + return clean($run, $match, "pgrep -u root -f", "sudo pkill -9 -u root -f", $verbose); +} + +sub clean { + my ($_run, $var, $cmd, $kill_cmd, $_verbose) = @_; + + plog('DEBUG', "clean command $var"); + $var or die "FATAL: no command given\n."; + + my $ps; + my $i; + + while ($ps = `$cmd "$var"`) { + system(qq($kill_cmd "$var" &>/dev/null)); + sleep 1; + $ps =~ s/\n/,/g; + plog('WARN', "Trying to remove previous blocked processes for $var ($ps)"); + waitpid(-1, POSIX::WNOHANG); + return 0 if $i++ > 10; + } + 1; +} + +sub kill_for_good { + my ($pid) = @_; + kill 14, $pid; + sleep 1; + waitpid(-1, POSIX::WNOHANG); + if (getpgrp $pid != -1) { + kill 15, $pid; + sleep 1; + waitpid(-1, POSIX::WNOHANG); + if (getpgrp $pid != -1) { + print STDERR "WARNING: have to kill -9 pid $pid\n"; + kill 9, $pid; + sleep 1; + waitpid(-1, POSIX::WNOHANG); + } + } +} + +sub sudo { + my ($_run, $config, @arg) = @_; + + #plog("Running $config->{iurt_root_command} @arg"); + + -x $config->{iurt_root_command} + or die "FATAL: $config->{iurt_root_command} command not found"; + + !system('/usr/bin/sudo', $config->{iurt_root_command}, @arg); +} + +1 diff --git a/lib/Iurt/Urpmi.pm b/lib/Iurt/Urpmi.pm new file mode 100644 index 0000000..f4628ee --- /dev/null +++ b/lib/Iurt/Urpmi.pm @@ -0,0 +1,789 @@ +package Iurt::Urpmi; + +use strict; +use RPM4::Header; +use File::Basename; +use File::NCopy qw(copy); +use MDV::Distribconf::Build; +use Iurt::Chroot qw(add_local_user create_temp_chroot check_build_chroot); +use Iurt::Process qw(perform_command clean clean_process sudo); +use Iurt::Config qw(dump_cache_par get_maint get_package_prefix); +use Iurt::Util qw(plog); + + +sub new { + my ($class, %opt) = @_; + my $self = bless { + config => $opt{config}, + run => $opt{run}, + urpmi_options => $opt{urpmi_options}, + }, $class; + my $config = $self->{config}; + my $run = $self->{run}; + + if ($run->{use_system_distrib}) { + $config->{basesystem_media_root} ||= $run->{use_system_distrib}; + } elsif ($run->{chrooted_urpmi}) { + my ($host) = $run->{chrooted_urpmi}{rooted_media} =~ m,(?:file|http|ftp)://([^/]*),; + my ($_name, $_aliases, $_addrtype, $_length, @addrs) = gethostbyname($host); + + my $ip = join('.', unpack('C4', $addrs[0])); + + $ip =~ /\d+\.\d+\.\d+\.\d+/ + or die "FATAL: could not resolve $host ip address"; + + $run->{chrooted_urpmi}{rooted_media} =~ s/$host/$ip/; + $run->{chrooted_media} = $run->{chrooted_urpmi}{rooted_media} . + "/$run->{distro}/$run->{my_arch}"; + + # Now squash all slashes that don't follow colon + $run->{chrooted_media} =~ s|(?{chrooted_media}"); + } + $self->{urpmi_media_options} .= + " --use-distrib $config->{repository}/$run->{distro}/$run->{my_arch}"; + + $self; +} + +sub set_command { + my ($self, $chroot_tmp) = @_; + $self->{urpmi_command} = "urpmi $self->{urpmi_options} $self->{urpmi_media_options} --root $chroot_tmp"; +} + +sub set_local_media { + my ($self, $local_media) = @_; + $self->{local_media} = $local_media; +} + +sub add_to_local_media { + my ($self, $chroot_tmp, $srpm, $luser) = @_; + my $local_media = $self->{local_media}; + + system("cp $chroot_tmp/home/$luser/rpm/RPMS/*/*.rpm $local_media &>/dev/null") and plog("ERROR: could not copy rpm files from $chroot_tmp/home/$luser/rpm/RPMS/ to $local_media ($!)"); + system("cp $chroot_tmp/home/$luser/rpm/SRPMS/$srpm $local_media &>/dev/null") and plog("ERROR: could not copy $srpm from $chroot_tmp/home/$luser/rpm/SRPMS/ to $local_media ($!)"); +} + +sub urpmi_command { + my ($self, $chroot_tmp, $_luser) = @_; + my $run = $self->{run}; + my $local_media = $self->{local_media}; + + #plog(3, "urpmi_command ($chroot_tmp user $luser)"); + if ($run->{chrooted_urpmi}) { + $self->{urpmi_command} = "urpmi $self->{urpmi_options} $self->{urpmi_media_options} --root $chroot_tmp "; + +# CM: commented out +# this was causing rpm database corruption problems and the packages +# are already installed +# +# if (!install_packages($self, 'chroot', $chroot_tmp, $local_spool, {}, 'configure', "[ADMIN] installation of urpmi and sudo failed in the chroot $run->{my_arch}", { maintainer => $config->{admin}, check => 1 }, 'urpmi', 'sudo')) { +# $run->{chrooted_urpmi} = 0; +# return +# } + + # Here should be added only the needed media for the given package + # main/release -> main/release + # main/testing -> main/release main/testing + # contrib/release -> contrib/release main/release + # contrib/testing -> contrib/testing contrib/release main/testing main/release + # non-free/release ... + # This is now done with an option in iurt2 --chrooted-urpmi -m media1 media2 -- media_url + + if ($run->{chrooted_urpmi}{media}) { + foreach my $m (@{$run->{chrooted_urpmi}{media}}) { + my $m_name = $m; + $m_name =~ s,/,_,g; + if (!add_media($self, $chroot_tmp, $m_name, + "$m_name $run->{chrooted_media}/media/$m")) { + $run->{chrooted_urpmi} = 0; + return; + } + } + } else { + if (!add_media($self, $chroot_tmp, 'Main', "--distrib $run->{chrooted_media}")) { + if (!add_media($self, $chroot_tmp, 'Main', "--wget --distrib $run->{chrooted_media}")) { + $run->{chrooted_urpmi} = 0; + return; + } + } + } + + if (-d "$local_media/hdlist.cz") { + mkdir("$chroot_tmp/iurt_media/"); + opendir my $dir, $local_media; + my $next; + foreach my $f (readdir $dir) { + $f =~ /(\.rpm|^hdlist.cz)$/ or next; + if (!link "$local_media/$f", "$chroot_tmp/iurt_media") { + if (!copy "$local_media/$f", "$chroot_tmp/iurt_media") { + plog("ERROR: could not copy file $local_media/$f to $chroot_tmp/iurt_media"); + $next = 1; + last; + } + } + } + next if $next; + add_media($self, $chroot_tmp, 'iurt_group', "iurt_group file:///iurt_media") or next; + } + + $self->{urpmi_command} = "chroot $chroot_tmp urpmi $self->{urpmi_options} "; + return 1; + } else { + $self->{urpmi_command} = "urpmi $self->{urpmi_options} $self->{urpmi_media_options} --root $chroot_tmp"; + } +} + +sub check_media_added { + my ($chroot, $media) = @_; + my $medias = `sudo chroot $chroot urpmq --list-media 2>&1`; + print "MEDIA $medias ($media)\n"; + $medias =~ /$media/m; +} + +sub add_media { + my ($self, $chroot, $regexp, $media) = @_; + my $run = $self->{run}; + my $config = $self->{config}; + my $cache = $run->{cache}; + + plog("add chroot media: $run->{chrooted_media}"); + + if (!perform_command("sudo chroot $chroot urpmi.addmedia --probe-hdlist $media", + $run, $config, $cache, + mail => $config->{admin}, + timeout => 300, + freq => 1, + retry => 2, + debug_mail => $run->{debug})) { + } + if (!check_media_added($chroot, $regexp)) { + plog('ERR', "ERROR iurt could not add media into the chroot"); + return; + } + 1; +} + +sub add_packages { + my ($self, $chroot, $_user, @packages) = @_; + my $run = $self->{run}; + my $config = $self->{config}; + my $cache = $run->{cache}; + if (!perform_command("sudo $self->{urpmi_command} @packages", + $run, $config, $cache, + timeout => 300, + freq => 1, + retry => 2, + error_ok => [ 11 ], + debug_mail => $run->{debug}, + error_regexp => 'cannot be installed', + wait_regexp => { + 'is needed by' => sub { + plog("WARNING: rpm database seems corrupted, retrying"); + system("sudo chroot $chroot rm -rf /var/lib/rpm/__db* &> /dev/null"); + 1; + }, + 'database locked' => sub { + plog("WARNING: urpmi database locked, waiting..."); + sleep 30; + $self->{wait_limit}++; + if ($self->{wait_limit} > 10) { + $self->{wait_limit} = 0; + system(qq(sudo pkill -9 urpmi &>/dev/null)); + return; + } + 1; + } },)) { + plog("ERROR: could not install @packages inside $chroot"); + return 0; + } + 1; +} + +sub get_local_provides { + my ($self) = @_; + my $run = $self->{run}; + my $program_name = $run->{program_name}; + my $local_media = $self->{local_media}; + + opendir my $dir, $local_media; + plog(1, "get local provides ($local_media)"); + require URPM; + my $urpm = new URPM; + foreach my $d (readdir $dir) { + $d =~ /\.src\.rpm$/ and next; + $d =~ /\.rpm$/ or next; + my $id = $urpm->parse_rpm("$local_media/$d"); + my $pkg = $urpm->{depslist}[$id]; + plog(3, "$program_name: checking $d provides"); + foreach ($pkg->provides, $pkg->files) { + plog(3, "$program_name: adding $_ as provides of $d"); + $run->{local_provides}{$_} = $d; + } + } + 1; +} + +sub get_build_requires { + my ($self, $union_id, $luser) = @_; + my $run = $self->{run}; + my $config = $self->{config}; + my $cache = $run->{cache}; + + $run->{todo_requires} = {}; + plog("get_build_requires"); + + my ($u_id, $chroot_tmp) = create_temp_chroot($run, $config, $cache, $union_id, $run->{chroot_tmp}, $run->{chroot_tar}) or return; + add_local_user($chroot_tmp, $run, $config, $luser, $run->{uid}) or return; + $union_id = $u_id; + + my $urpm = new URPM; + foreach my $p (@{$run->{todo}}) { + my ($dir, $srpm, $s) = @$p; + recreate_srpm($self, $run, $config, $chroot_tmp, $dir, $srpm, $run->{user}) or return; + $s or next; + my $id = $urpm->parse_rpm("$dir/$srpm"); + my $pkg = $urpm->{depslist}[$id]; + foreach ($pkg->requires) { + plog(3, "adding $_ as requires of $srpm"); + $run->{todo_requires}{$_} = $srpm; + } + } + 1; +} + +sub order_packages { + my ($self, $union_id, $provides, $luser) = @_; + my $run = $self->{run}; + my @packages = @{$run->{todo}}; + my $move; + + plog(1, "order_packages"); + get_local_provides($self) or return; + if (!$run->{todo_requires}) { + get_build_requires($self, $union_id, $luser) or return; + } + my %visit; + my %status; + do { + $move = 0; + foreach my $p (@packages) { + my ($_dir, $rpm, $status) = @$p; + defined $status{$rpm} && $status{$rpm} == 0 and next; + plog("checking packages $rpm"); + foreach my $r (@{$run->{todo_requires}{$rpm}}) { + plog("checking requires $r"); + if (!$run->{local_provides}{$r}) { + if ($provides->{$r}) { + $status = 1; + } else { + $status = 0; + } + } elsif ($visit{$rpm}{$r}) { + # to evit loops + $status = 0; + } elsif ($run->{done}{$rpm} && $run->{done}{$provides->{$r}}) { + if ($run->{done}{$rpm} < $run->{done}{$provides->{$r}}) { + $move = 1; + $status = $status{$provides->{$r}} + 1; + } else { + $status = 0; + } + } elsif ($status < $status{$provides->{$r}}) { + $move = 1; + $status = $status{$provides->{$r}} + 1; + } + $visit{$rpm}{$r} = 1; + } + $status{$rpm} = $status; + $p->[2] = $status; + } + } while $move; + $run->{todo} = [ sort { $a->[2] <=> $b->[2] } @packages ]; + if ($run->{verbose}) { + foreach (@packages) { + plog("order_packages $_->[1]"); + } + } + @packages; +} + +sub wait_urpmi { + my ($self) = @_; + my $run = $self->{run}; + + plog("WARNING: urpmi database locked, waiting...") if $run->{debug}; + sleep 30; + $self->{wait_limit}++; + if ($self->{wait_limit} > 8) { + $self->{wait_limit} = 0; system(qq(sudo pkill -9 urpmi &>/dev/null)); + } +} + +sub install_packages_old { + my ($self, $local_spool, $srpm, $log, $error, @packages) = @_; + my $run = $self->{run}; + my $config = $self->{config}; + my $cache = $run->{cache}; + my $log_spool = "$local_spool/log/$srpm/"; + -d $log_spool or mkdir $log_spool; + if (!perform_command("sudo $self->{urpmi_command} @packages", + $run, $config, $cache, + # mail => $maintainer, + error => $error, + hash => "${log}_$srpm", + srpm => $srpm, + timeout => 600, + retry => 2, + debug_mail => $run->{debug}, + freq => 1, + wait_regexp => { 'database locked' => \&wait_urpmi }, + error_regexp => 'unable to access', + log => $log_spool)) { + $cache->{failure}{$srpm} = 1; + $run->{status}{$srpm} = 'binary_test_failure'; + return 0; + } + 1; +} + +sub install_packages { + my ($self, $title, $chroot_tmp, $local_spool, $pack_provide, $log, $error, $opt, @packages) = @_; + + my $maintainer = $opt->{maintainer}; + my $run = $self->{run}; + my $config = $self->{config}; + my $cache = $run->{cache}; + my $program_name = $run->{program_name}; + my $ok; + my @to_install; + + plog('DEBUG', "installing @packages"); + + if ($run->{chrooted_urpmi}) { + @to_install = map { s/$chroot_tmp//; $_ } @packages; + } else { + push @to_install, @packages; + } + + @to_install or return 1; + + (my $log_dirname = $title) =~ s/.*:(.*)\.src.rpm/$1/; + + my $log_spool = "$local_spool/log/$log_dirname/"; + + mkdir $log_spool; + + my $try_urpmi = 1; + my @rpm = grep { !/\.src\.rpm$/ } @to_install; + + return 1 if ($opt->{check} && -f "$chroot_tmp/bin/rpm" && @rpm && !system("sudo chroot $chroot_tmp rpm -q @to_install")); + + if ($try_urpmi) { + foreach my $try ( + [ '', 'using urpmi' ], + [ '', 'rebuild rpm base and retry', '_retry' ], + [ ' --allow-nodeps', 'retrying with nodeps' , '_nodeps' ], + [ ' --no-install', 'using rpm directly', '_rpm' ] + ) { + my ($opt, $msg, $suf) = @$try; + + plog('INFO', "install dependencies: $msg"); + my $unsatisfied; + + if (!perform_command( + "sudo $self->{urpmi_command} $opt @to_install", + $run, $config, $cache, + error => $error, + logname => "${log}$suf", + hash => "${log}_$title$suf", + timeout => 600, + srpm => $title, + freq => 1, + #cc => $cc, + retry => 3, + debug_mail => $run->{debug}, + error_regexp => 'cannot be installed', + wait_regexp => { + 'database locked' => \&wait_urpmi, + 'is needed by' => sub { + plog('WARN', "WARNING: rpm database seems corrupted, retrying"); + system("sudo chroot $chroot_tmp rm -rf /var/lib/rpm/__db* &> /dev/null"); + 1; + }, + }, + log => $log_spool, + callback => sub { + my ($opt, $output) = @_; + plog('DEBUG', "calling callback for $opt->{hash}"); + +# 20060614 +# it seems the is needed urpmi error is due to something else (likely a +# database corruption error). +# my @missing_deps = $output =~ /(?:(\S+) is needed by )|(?:\(due to unsatisfied ([^[ ]*)(?: (.*)|\[(.*)\])?\))/g; +# + + my @missing_deps = $output =~ /([^ \n]+) \(due to unsatisfied ([^[ \n]*)(?: ([^\n]*)|\[([^\n]*)\])?\)/g; + + # as it seems that rpm db corruption is making urpmi + # returning false problem on deps installation, try + # to compile anyway + + @missing_deps or return 1; + $unsatisfied = 1; + + while (my $missing_package = shift @missing_deps) { + my $missing_deps = shift @missing_deps; + my $version = shift @missing_deps; + my $version2 = shift @missing_deps; + $version ||= $version2 || 0; + my $p = $pack_provide->{$missing_deps} || $missing_deps; + my ($missing_package_name, $first_maint); + if ($missing_package !~ /\.src$/) { + ($first_maint, $missing_package_name) = get_maint($run, $missing_package); + plog(5, "likely $missing_package_name need to be rebuilt ($first_maint)"); + } else { + $missing_package = ''; + } + + my ($other_maint) = get_maint($run, $p); + plog('FAIL', "missing dep: $missing_deps ($other_maint) missing_package $missing_package ($first_maint)"); + $run->{status}{$title} = 'missing_dep'; + foreach my $m ($first_maint, $other_maint) { # FIXME: (tv) this loop is useless !!! + if ($other_maint && $other_maint ne 'NOT_FOUND') { + $opt->{mail} = $config->{admin}; + #$opt->{mail} .= ", $other_maint"; + } + } + + if (!$opt->{mail}) { + $opt->{mail} = $config->{admin}; + } + + # remember what is needed, and do not try to + # recompile until it is available + + if ($missing_package) { + $opt->{error} = "[MISSING] $missing_deps, needed by $missing_package to build $title, is not available on $run->{my_arch} (rebuild $missing_package?)"; + $cache->{needed}{$title}{$missing_deps} = { package => $missing_package , version => $version, maint => $first_maint || $other_maint || $maintainer }; + } else { + $opt->{error} = "[MISSING] $missing_deps, needed to build $title, is not available on $run->{my_arch}"; + $cache->{needed}{$title}{$missing_deps} = { package => $missing_package , version => $version, maint => $maintainer || $other_maint }; + } + } + 0; + }, + )) { + if (!clean_process($run, "$self->{urpmi_command} $opt @to_install", $run->{verbose})) { + dump_cache_par($run); + die "FATAL $program_name: Could not have urpmi working !"; + } + $unsatisfied and last; + } else { + if (!@rpm || !system("sudo chroot $chroot_tmp rpm -q @rpm")) { + plog("installation successful"); + $ok = 1; + } + } + + if (-f "$chroot_tmp/bin/rpm") { + if (!$ok && system("sudo chroot $chroot_tmp rm -rf /var/lib/rpm/__db*; sudo chroot $chroot_tmp rpm --rebuilddb")) { + plog("ERROR: rebuilding rpm db failed, aborting ($!)"); + last; + } + if ($suf eq '_rpm') { + plog(1, "trying to install all the rpms in $chroot_tmp/var/cache/urpmi/rpms/ manually"); + if (!system("sudo chroot $chroot_tmp rpm -Uvh --force --nodeps /var/cache/urpmi/rpms/*.rpm")) { + $ok = 1; + last; + } else { + $ok = 0; + } + } + } + last if $ok == 1; + } + } + if (!-f "$chroot_tmp/bin/rpm" || @rpm && system("sudo chroot $chroot_tmp rpm -q @to_install")) { + plog(1, "ERROR: urpmi is not working, doing it manually"); + my $root = "$config->{repository}/$run->{distro}/$run->{my_arch}"; + my $depslist = "$root/media/media_info/depslist.ordered"; + if (-f $depslist) { + my $distrib = $self->{distrib}; + if (!$distrib) { + $distrib = MDV::Distribconf::Build->new($root); + plog(3, "getting media config from $root"); + if (!$distrib->loadtree) { + plog(1, "ERROR: $root does not seem to be a distribution tree\n"); + return; + } + $distrib->parse_mediacfg; + foreach my $media ($distrib->listmedia) { + $media =~ /(SRPMS|debug_)/ and next; + my $path = $distrib->getfullpath($media, 'path'); + opendir my $rpmdh, $path; + foreach my $rpm (readdir $rpmdh) { + if ($rpm =~ /^(.*)-([^-]+)-([^-]+)\.([^.]+)\.rpm/) { + $distrib->{file}{"$1-$2-$3.$4"} = "$path/$rpm"; + } + } + } + } + $self->{distrib} = $distrib; + plog(3, "using $depslist to resolve dependencies"); + open my $depsfh, $depslist; + my %packages; + my @deps; + my $i; + my @install; + my @pack; + while (<$depsfh>) { + my ($pack, $_size, @d) = split ' '; + $pack =~ s/:\d+$//; + push @deps, \@d; + my ($name, $version, $release, $arch) = $pack =~ /(.*)-([^-]+)-([^-]+)\.([^.]+)$/; + $pack[$i] = $pack; + $packages{$pack} ||= $i; + if ($arch ne 'src' && !$packages{$name}) { + $packages{$name} = $i; + $packages{"$name-$version"} = $i; + $packages{"$name-$version-$release"} = $i; + } + $i++; + } + plog(4, "$i packages found"); + my %done; + # rpm -root $chroot -qa does not work + if (-f "$chroot_tmp/bin/rpm") { + my $qa = `sudo chroot $chroot_tmp rpm -qa --qf "\%{name}-\%{version}-\%{release}.\%{arch}\n"`; + foreach my $rpm (split "\n", $qa) { + plog(6, "$rpm already installed"); + $done{$rpm} = 1; + } + } + foreach my $p (@to_install) { + my $pa = $pack[$packages{$p}]; + $done{$pa} and next; + my $f = $distrib->{file}{$pa}; + if ($f) { + push @install, $pa; + } else { + plog(1, "ERROR: main package $p is not present in the repository"); + return 0; + } + } + my $dok; + while (!$dok) { + $dok = 1; + foreach my $p (@install) { + $done{$p} and next; + $done{$p} = 1; + plog(5, "adding deps for $p (", join(', ', @{$deps[$packages{$p}]}, ")")); + foreach my $d (@{$deps[$packages{$p}]}) { + plog("$d (pack $pack[$d]) done $done{$d} done pack $done{$pack[$d]}"); + $done{$d} and next; + $done{$pack[$d]} and next; + $done{$d} = 1; + if ($d =~ /\d+/) { + my $f = $distrib->{file}{$pack[$d]}; + if ($f) { + $dok = 1; + plog(5, "adding $pack[$d]"); + push @install, $pack[$d]; + } else { + plog(2, "ERROR: deps for $p, $pack[$d] ($d) is not present in the repository"); + } + } elsif ($d =~ /\|/) { + my $done; + foreach my $a (split '\|', $d) { + my $f = $distrib->{file}{$pack[$a]}; + if ($f) { + $done = 1; + if (!$done{$pack[$a]}) { + $dok = 1; + plog(5, "adding $pack[$a]"); + push @install, $pack[$a]; + $done{$pack[$a]} = 1; + } + last; + } else { + plog(2, "ERROR: alternate deps, $pack[$a] ($d) is not present in the repository, using alternative"); + } + } + if (!$done) { + plog(2, "ERROR: no alternatives present in the repository"); + } + } + } + } + } + my $rpms; + my %install_done; + # FIXME: (tv) this loop could be simplified with uniq() from MDK::Common: + # eg: $rpms = join(map { "$distrib->{file}{$_}" } uniq(@install)) + foreach my $rpm (@install) { + $install_done{$rpm} and next; + print "$program_name: will install $rpm ($distrib->{file}{$rpm})\n" if $run->{verbose} > 3; + $install_done{$rpm} = 1; + $rpms .= "$distrib->{file}{$rpm} "; + } + if ($rpms) { + return !system("sudo rpm --ignoresize --nosignature --root $chroot_tmp -Uvh $rpms"); + } + $ok = 1; + } + } + $ok; +} + +sub clean_urpmi_process { + my ($self) = @_; + my $run = $self->{run}; + my $program_name = $run->{program_name}; + if (!$run->{chrooted_urpmi}) { + my $match = $self->{urpmi_command} or return; + if (!clean_process($run, $match, $run->{verbose})) { + dump_cache_par($run); + die "FATAL $program_name: Could not have urpmi working !"; + } + } +} + +sub update_srpm { + my ($self, $dir, $rpm, $wrong_rpm) = @_; + my $run = $self->{run}; + my $cache = $run->{cache}; + my ($arch) = $rpm =~ /([^\.]+)\.rpm$/ or return 0; + my $srpm = $cache->{rpm_srpm}{$rpm}; + if (!$srpm) { + my $hdr = RPM4::Header->new("$dir/$rpm"); + $hdr or return 0; + $srpm = $hdr->queryformat('%{SOURCERPM}'); + $cache->{rpm_srpm}{$rpm} = $srpm; + } + $srpm = fix_srpm_name($cache, $srpm, $rpm, $wrong_rpm); + $arch, $srpm; +} + +sub fix_srpm_name { + my ($cache, $srpm, $rpm, $wrong_rpm) = @_; + my $old_srpm = $srpm; + if ($srpm =~ s/^lib64/lib/) { + push @$wrong_rpm, [ $old_srpm, $rpm ] if ref $wrong_rpm; + $cache->{rpm_srpm}{$rpm} = $srpm; + } + $srpm; +} + +sub recreate_srpm { + my ($_self, $run, $config, $chroot_tmp, $dir, $srpm, $luser, $b_retry) = @_; +# recreate a new srpm for buildarch condition in the spec file + my $program_name = $run->{program_name}; + my $cache = $run->{cache}; + my $with_flags = $run->{with_flags}; + + plog('NOTIFY', "recreate srpm: $srpm"); + + perform_command([ + sub { + my ($s, $d) = @_; + sudo($run, $config, '--cp', $s, $d) } , [ "$dir/$srpm", "$chroot_tmp/home/$luser/rpm/SRPMS/" ] ], + $run, $config, $cache, + type => 'perl', + mail => $config->{admin}, + error => "[REBUILD] cannot copy $srpm to $chroot_tmp", + debug_mail => $run->{debug}, + hash => "copy_$srpm") or return; + + my %opt = (mail => $config->{admin}, + error => "[REBUILD] cannot install $srpm in $chroot_tmp", + debug_mail => $run->{debug}, + hash => "install_$srpm", + retry => $b_retry, + callback => sub { + my ($opt, $output) = @_; + plog('DEBUG', "calling callback for $opt->{hash}"); + if ($output =~ /warning: (group|user) .* does not exist - using root|Header V3 DSA signature/i) { + return 1; + } elsif ($output =~ /user $luser does not exist|cannot write to \%sourcedir/) { + plog('WARN', "WARNING: chroot seems corrupted!"); + $opt->{error} = "[CHROOT] chroot is corrupted"; + $opt->{retry} ||= 1; + return; + } + 1; + }); + plog('DEBUG', "recreating src.rpm..."); + if (!perform_command(qq(sudo chroot $chroot_tmp su $luser -c "rpm -i /home/$luser/rpm/SRPMS/$srpm"), + $run, $config, $cache, %opt)) { + plog("ERROR: chrooting failed (retry $opt{retry}") if $run->{debug}; + if ($opt{retry}) { + check_build_chroot($run->{chroot_path}, $run->{chroot_tar}, $run, $config) or return; + return -1; + } + return; + } + + my $spec; + my $oldsrpm = "$chroot_tmp/home/$luser/rpm/SRPMS/$srpm"; + my $filelist = `rpm -qlp $oldsrpm`; + my ($name) = $srpm =~ /(?:.*:)?(.*)-[^-]+-[^-]+\.src\.rpm$/; + foreach my $file (split "\n", $filelist) { + if ($file =~ /(.*)\.spec/) { + if (!$spec) { + $spec = $file; + } elsif ($1 eq $name) { + $spec = $file; + } + } + } + # 20060515 This should not be necessairy any more if urpmi *.spec works, but it doesn't + # + my $ret = perform_command(qq(sudo chroot $chroot_tmp su $luser -c "rpm --nodeps -bs $with_flags /home/$luser/rpm/SPECS/$spec"), + $run, $config, $cache, + mail => $config->{admin}, + error => "[REBUILD] cannot create $srpm in $chroot_tmp", + debug_mail => $run->{debug}, + hash => "create_$srpm" + ); + + # Return if we can't regenerate srpm + # + return (0, ,) unless $ret; + + # CM: was: foreach my $file (readdir $dir) + # The above line returned entries in a strange order in my test + # system, such as + # .. + # cowsay-3.03-11mdv2007.1.src.rpm + # cowsay-3.03-11mdv2007.0.src.rpm + # . + # assigning '.' to $new_rpm. Now sorting the output. + + # we should better perform a rpm -qp -qf "%{name}-%{version}-%{release}.src.rpm" $spec + my $file; + my $stat; + foreach my $f (glob "$chroot_tmp/home/$luser/rpm/SRPMS/$name-*.src.rpm") { + my (@s) = stat $f; + if ($s[9] > $stat) { + $file = $f; + $stat = $s[9]; + } + } + my ($new_srpm) = basename($file); + my $prefix = get_package_prefix($srpm); + my $newfile = "$chroot_tmp/home/$luser/rpm/SRPMS/$prefix$new_srpm"; + if (-f $file && $newfile ne $file) { + if (-f $newfile) { + sudo($run, $config, '--rm', $newfile) or die "$program_name: could not delete $newfile ($!)"; + } + sudo($run, $config, '--ln', $file, $newfile) or die "$program_name: linking $file to $newfile failed ($!)"; + unlink $file; + unlink $oldsrpm if $oldsrpm ne $newfile; + } + plog('NOTIFY', "new srpm: $prefix$new_srpm"); + ($ret, "$prefix$new_srpm", $spec); +} + +1; diff --git a/lib/Iurt/Util.pm b/lib/Iurt/Util.pm new file mode 100644 index 0000000..a101f76 --- /dev/null +++ b/lib/Iurt/Util.pm @@ -0,0 +1,203 @@ +package Iurt::Util; + +use base qw(Exporter); +use strict; + +our @EXPORT = qw( + plog_init + plog + pdie + ssh_setup + ssh + sout + sget + sput +); + +my ($plog_name, $plog_file, $plog_level, $plog_color); + +=head2 LOG HELPERS + +=over 8 + +=item plog_init($program_name, $logfile) + +=item plog_init($program_name, $logfile, $level) + +Initialize plog with the program name, log file and optional log level. +If not specified, the log level will be set to 9999. + +=cut + +my %plog_ctr = ( + red => "\x1b[31m", + green => "\x1b[32m", + yellow => "\x1b[33m", + blue => "\x1b[34m", + magenta => "\x1b[35m", + cyan => "\x1b[36m", + grey => "\x1b[37m", + bold => "\x1b[1m", + normal => "\x1b[0m", +); + +my @plog_prefix = ( + "", + "E: ", + "W: ", + "*: ", + "F: ", + "O: ", + "N: ", + "I: ", + "D: ", +); + +my %plog_level = ( + NONE => 0, + ERR => 1, + WARN => 2, + MSG => 3, + FAIL => 4, + OK => 5, + NOTIFY => 6, + INFO => 7, + DEBUG => 8, +); + +sub plog_init { + $plog_name = shift; + $plog_file = shift; + $plog_level = shift @_ || 9999; + $plog_color = shift @_ || 0; + + $plog_level = 9999 if $ENV{PLOG_DEBUG}; + + $plog_color = 0 unless -t fileno $plog_file; + + foreach (@plog_prefix) { $_ .= "[$plog_name] " } + + if ($plog_color) { + $plog_prefix[1] .= "$plog_ctr{bold}$plog_ctr{red}"; + $plog_prefix[2] .= "$plog_ctr{bold}$plog_ctr{yellow}"; + $plog_prefix[3] .= $plog_ctr{bold}; + $plog_prefix[4] .= $plog_ctr{red}; + $plog_prefix[5] .= $plog_ctr{green}; + $plog_prefix[6] .= $plog_ctr{cyan}; + $plog_prefix[8] .= $plog_ctr{yellow}; + } + + 1; +} + +=item plog($message) + +=item plog($level, @message) + +Print a log message in the format "program: I\n" to the log +file specified in a call to plog_init(). If a level is specified, +the message will be printed only if the level is greater or equal the +level set with plog_init(). + +=back + +=cut + +sub plog { + my $level = $#_ ? shift : 'INFO'; + $level = $plog_level{$level}; + my ($p, $e) = ($plog_prefix[$level], $plog_ctr{normal}); + + print $plog_file "$p@_$e\n" if $plog_level >= $level; +} + +sub pdie { + my $level = $plog_level{ERROR}; + my ($p, $e) = ($plog_prefix[$level], $plog_ctr{normal}); + + print $plog_file "$p@_$e\n" if $plog_level >= $level; + die $@; +} + +=head2 SSH HELPERS + +=over 8 + +=item ssh_setup($options, $user, $host) + +Set up ssh connections with the specified options, user and remote +host. Return an ssh handle to be used in ssh-based operations. + +=cut + +sub ssh_setup { + my $opt = shift; + my $user = shift; + my $host = shift; + my @conf = ($opt, $user, $host); + \@conf; +} + +=item ssh($handle, @commmand) + +Open an ssh connection with parameters specified in ssh_setup() and +execute I<@command>. Return the command execution status. + +=cut + +# This is currently implemented using direct calls to ssh/scp because. +# according to Warly's comments in ulri, using the perl SSH module +# gives us some performance problems + +sub ssh { + my $conf = shift; + my ($opt, $user, $host) = @$conf; + system("ssh $opt -x $user\@$host @_"); +} + +=item sout($handle, @commmand) + +Open an ssh connection with parameters specified in ssh_setup() and +execute I<@command>. Return the command output. + +=cut + +sub sout { + my $conf = shift; + my ($opt, $user, $host) = @$conf; + `ssh $opt -x $user\@$host @_ 2>/dev/null`; +} + +=item sget($handle, $from, $to) + +Get a file using scp, from the remote location I<$from> to the +local location I<$to>, using host and user specified in ssh_setup(). + +=cut + +sub sget { + my $conf = shift; + my ($_opt, $user, $host) = @$conf; + system('scp', '-q', '-rc', 'arcfour', "$user\@$host:$_[0]", $_[1]); +} + +=item sput($handle, $from, $to) + +Send a file using scp, from a local location I<$from> to the remote +location I<$to>, using host and user specified in ssh_setup(). + +=back + +=cut + +sub sput { + my $conf = shift; + my ($_opt, $user, $host) = @$conf; + system('scp', '-q', '-rc', 'arcfour', $_[0], "$user\@$host:$_[1]"); +} + +=back + +=cut + +1; -- cgit v1.2.1