path: root/tools/oem-prepare

#!/usr/bin/perl

my ($mode, $dir, $reject_dir, $lang) = @ARGV;
$mode =~ s/^--(rebuild|clean)$/$1/ or die "mode should be --rebuild or --clean\n";
-e "$dir/Mandrake/base/hdlists" && -d $reject_dir or die "usage: oem-prepare <--rebuild|--clean> <top_dir> <reject_dir> <lang>\n";

#- detect language used and default options.
open F, "$dir/VERSION" or die "no installation found on $dir";
while (<F>) {
    /[\s-]fr/ and $lang = 'fr';
    /\[lang[=:]([^]]*)\]/ and $lang = $1;
    /[\[\-]server[\]\-]/ and $options{server} = '';
}
close F;

my ($flang, $charset);
#- default language fall to english ?
foreach ($lang || 'en') {
    /fr/ and ($lang, $flang, $charset) = ('fr', 'fr_FR@euro', 'iso-8859-15');
    /en/ and ($lang, $flang, $charset) = ('en', 'en_US', 'iso-8859-1');
    /de/ and ($lang, $flang, $charset) = ('de', 'de_DE@euro', 'iso-8859-15');
    /it/ and ($lang, $flang, $charset) = ('it', 'it_IT@euro', 'iso-8859-15');
    /es/ and ($lang, $flang, $charset) = ('es', 'es_ES@euro', 'iso-8859-15');
}
print "Found lang $lang\n";
foreach (keys %options) {
    print "Using option [$_" . ($options{$_} && "=$options{$_}") . "]\n";
}


my $packages = select_packages($dir, $lang);

my @media;
open F, "$dir/Mandrake/base/hdlists";
foreach (<F>) {
    chomp;
    s/\s*#.*$//;
    /^\s*$/ and next;
    m/^\s*(hdlist\S*\.cz2?)\s+(\S+)\s*(.*)$/ or die "invalid hdlist description \"$_\" in hdlists file";

    push @media, { hdlist => $1, rpmsdir => $2, descr => $3 };
}
close F;


#- keep in mind all the rpm files available (according to hdlists).
my (%rpms, %files);

require packdrake;
foreach my $medium (@media) {
    my $packer = new packdrake("$dir/Mandrake/base/$medium->{hdlist}");
    foreach (@{$packer->{files}}) {
	$packer->{data}{$_}[0] eq 'f' or next;
	my ($fullname, $file) = /([^:]*):(.*)/ ? ($1, "$2.rpm") : ($_, "$_.rpm");
	$files{$fullname} = $file;
	$rpms{$file} = $medium->{rpmsdir};
	-e "$dir/$medium->{rpmsdir}/$file" and next; #- already exist in the right directory.
	if (-e "$reject_dir/$file") {
	    $mode eq 'rebuild' and system "mv", "-f", "$reject_dir/$file", "$dir/$medium->{rpmsdir}/";
	    next;
	}
	print STDERR "unable to find package $file listed in medium \"$medium->{descr}\"\n";
    }
}

if ($mode eq 'clean') {
    #- copy and install from each cd image.
    foreach my $medium (@media) {
	print "Examining packages from medium labeled \"$medium->{descr}\"\n";

	foreach my $pkg (@{$packages->{depslist}}) {
	    $pkg->{closure} && !$pkg->{selected} or next;
	    my $file = "$dir/$medium->{rpmsdir}/" . $files{rpm_fullname($pkg)};
	    if (-e $file) {
		delete $rpms{$files{rpm_fullname($pkg)}} or next;
		print "  copying $file\n";
		delete $pkg->{closure};
	    }
	}

	if (my $pkg = pkgs::packageByName($packages, 'glibc')) { #- HACK FOR GLIBC
	    if ($pkg->{selected}) {
		my $file = "$dir/$medium->{rpmsdir}/" . $files{rpm_fullname($pkg)};
		if (-e $file) {
		    delete $rpms{$files{rpm_fullname($pkg)}} or next;
		    print "  installing $file\n";
		    delete $pkg->{selected};
		}
	    }
	} else {
	    die "no glibc package found";
	}
	foreach my $pkg (@{$packages->{depslist}}) {
	    $pkg->{selected} or next;
	    my $file = "$dir/$medium->{rpmsdir}/" . $files{rpm_fullname($pkg)};
	    if (-e $file) {
		delete $rpms{$files{rpm_fullname($pkg)}} or next;
		print "  installing $file\n";
		delete $pkg->{selected};
	    }
	}

	scalar(grep { $_->{selected} || $_->{closure} } @{$packages->{depslist}}) == 0 and last;
    }

    #- copy files.
    #- at this point, everything left in %rpms has to be moved to $reject_dir.
    foreach (keys %rpms) {
	-e "$reject_dir/$_" and next; #- already cleaned.
	-e "$dir/$rpms{$_}/$_" or print STDERR "file \"$_\" should be in [$dir/$rpms{$_}]\n", next;
	system "mv", "-f", "$dir/$rpms{$_}/$_", $reject_dir;
    }
}

#- provide package fullname that have to be installed and copied.
sub select_packages {
    my ($dir, $lang) = @_;
    my $o = { packages => read_depslist("$dir/Mandrake/base/depslist.ordered") };

    #- act as DrakX will do to select packages.
    pkgs::read_rpmsrate($o->{packages}, install_any::getFile("Mandrake/base/rpmsrate") || die "unable to read rpmsrate");
    ($o->{compssUsers}, $o->{compssUsersSorted}, $o->{compssUsersIcons}, $o->{compssUsersDescr}) = 
      pkgs::readCompssUsers($o->{packages}, $o->{meta_class});
    eval { install_any::getFile("XXX") }; #- close out any still opened filehandle..

    pkgs::selectPackage($o->{packages}, pkgs::packageByName($o->{packages}, 'basesystem') || die "no basesystem package found");
    #- by default, choose:
    $o->{compssUsersChoice}{$_} = 1 foreach 'GNOME', 'KDE', 'CONFIG', 'X';
    $o->{compssUsersChoice}{$_} = 1 
	foreach map { @{$o->{compssUsers}{$_}{flags}} } 'Workstation|Office Workstation', 'Workstation|Internet station';

    if (exists $options{server}) {
	foreach (qw(KDE ACCESSIBILITY PUBLISHING CUPS EDITORS TEXT_TOOLS COMMUNICATIONS TERMINALS
		    NETWORKING_FILE_TRANSFER NETWORKING_OTHER
		    NETWORKING_FILE_TRANSFER_SERVER NETWORKING_FIREWALLING_SERVER NETWORKING_LDAP_SERVER
		    NETWORKING_MAIL_SERVER NETWORKING_OTHER_SERVER
		    NETWORKING_REMOTE_ACCESS NETWORKING_REMOTE_ACCESS_SERVER NETWORKING_DNS NETWORKING_DNS_SERVER
		    NETWORKING_FILE NETWORKING_FILE_SERVER NETWORKING_WWW NETWORKING_WWW_SERVER
		    ARCHIVING DEVELOPMENT MONITORING FILE_TOOLS CONFIG BOOKS SYSTEM X DOCS)) {
	    $o->{compssUsersChoice}{$_} = 1;
	}
	#- additional packages to be selected for server, databases with MySQL (avoid rpmsrate modifications).
	foreach (qw(MySQL-client MySQL-shared MySQL perl-Mysql)) {
	    my $pkg = pkgs::packageByName($o->{packages}, $_);
	    $pkg and pkgs::selectPackage($o->{packages}, $pkg);
	}
    } else {
	$o->{compssUsersChoice}{$_} = 1 foreach map { @{$o->{compssUsers}{$_}} } @{$o->{compssUsersSorted}};
	$o->{compssUsersChoice}{$_} = 1 foreach qw(SYSTEM X DOCS);
	@{$o->{compssUsersChoice}}{grep { /SERVER|DATABASES/ } keys %{$o->{compssUsersChoice}}} = ();
    }

    my $lang_pkg = $lang && pkgs::packageByName($o->{packages}, "locales-$lang");
    if ($lang_pkg) {
	pkgs::selectPackage($o->{packages}, $lang_pkg);
	$o->{compssUsersChoice}{qq(LOCALES"$lang")} = 1;
	$o->{compssUsersChoice}{qq(LOCALES"$flang")} = 1;
	$o->{compssUsersChoice}{qq(CHARSET"$charset")} = 1;
    }

    pkgs::setSelectedFromCompssList($o->{packages}, $o->{compssUsersChoice}, 4, 0);
    #- save selected, but keep selected property.
    foreach my $pkg (@{$o->{packages}{depslist}}) {
	$pkg->{selected} and $pkg->{save_selected} = $pkg->{selected};
    }

    #- extend selection to closure now, make all selected as closure and restore selected after.
    $o->{compssUsersChoice}{$_} = 1 foreach qw(BURNER DVD PCMCIA BIGMEM SMP 3D TV SCANNER PHOTO SOUND);
    pkgs::setSelectedFromCompssList($o->{packages}, $o->{compssUsersChoice}, 4, 0);
    $o->{compssUsersChoice}{$_} = 0 foreach qw(BURNER DVD PCMCIA BIGMEM SMP 3D TV SCANNER PHOTO SOUND);
    #- INSTALL class need to be copied as closure (unless installed after).
    #- but we have to remove kernel22 and kernel22-smp now obsolete for oem.
    foreach (@{$o->{packages}{needToCopy}}) {
	/^(kernel22.*|raidtools|lvm|reiserfsprogs|xfsprogs|jfsprogs|XFree86-(Mach8|Mach32|Mono|W32|3DLabs|P9000|8514|VGA16|I128|AGX))$/ and next;
	my $pkg = pkgs::packageByName($o->{packages}, $_);
	pkgs::selectPackage($o->{packages}, $pkg);
    }
    #- first select package that have to go to closure according to their names.
    foreach my $pkg (@{$o->{packages}{depslist}}) {
	$pkg->{name} =~ /kernel-(\d|smp|enterprise)/ and pkgs::selectPackage($o->{packages}, $pkg);
	$pkg->{name} =~ /NVIDIA/ and pkgs::selectPackage($o->{packages}, $pkg);
    }
    foreach my $pkg (@{$o->{packages}{depslist}}) {
	delete $pkg->{selected} && !$pkg->{save_selected} and $pkg->{closure} = 1;
	$pkg->{save_selected} and $pkg->{selected} = $pkg->{save_selected};
    }

    #- package that have to selected here as a bonus for oem install.
    foreach (qw(cups cups-drivers a2ps drakprofile draksync numlock icewm-light
		Mesa Mesa-demos alsa alsa-utils curl
                glibc vim-minimal kernel gcc-cpp
	       ), exists $options{server} ? qw(openldap-migration openldap-clients pam_ldap) : ()) {
	my $pkg = pkgs::packageByName($o->{packages}, $_);
	$pkg and pkgs::selectPackage($o->{packages}, $pkg);
    }

    #- special packages that are to be move to closure always ...
    foreach (qw(nfs-utils-client numlock usbd hotplug alsa alsa-utils
	        Aurora Aurora-Monitor-NewStyle-Categorizing-WsLib bootsplash)) {
	my $pkg = pkgs::packageByName($o->{packages}, $_);
	if ($pkg) {
	    pkgs::selectPackage($o->{packages}, $pkg);
	    $pkg->{closure} = 1;
	    delete $pkg->{selected};
	}
    }

    #- special packages that are to be removed always... BEWARE THIS IS A HACK !!!
#    foreach (qw(gmc gcc3.0 gcc3.0-c++ gcc3.0-cpp libstdc++3.0 libstdc++3.0-devel)) {
#	my $pkg = pkgs::packageByName($o->{packages}, $_);
#	if ($pkg) {
#	    delete $pkg->{closure};
#	    delete $pkg->{selected};
#	}
#    }

    $o->{packages};
}

sub chop_version {
    ($_[0] =~ /^([^:\s]*)-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*(?::\S*)?/)[0] || die "unable to parse $_[0]";
}
sub rpm_fullname {
    ($_[0]{name} =~ /^([^:\s]*-[^:\-\s]+-[^:\-\s]+\.[^:\.\-\s]*)(?::\S*)?/)[0] || die "unable to parse $_[0]";
}

sub read_depslist {
    my ($file) = @_;
    my $packages = { depslist => [], names => {} };

    #- read depslist.oredered file.
    my $id = 0;

    open F, "$file" or die "unable to open ordered dependencies list file";
    while (<F>) {
	my ($name, $size, @deps) = split;
	push @{$packages->{depslist}}, { id => $id++, name => $name, size => $size, deps => \@deps };
    }
    close F;

    foreach (@{$packages->{depslist}}) {
	$packages->{names}{chop_version($_->{name})} = $_;
    }

    print "read " . scalar(@{$packages->{depslist}}) . " package dependancies\n";
    $packages;
}

#- compability method for the below ones, wrap DrakX code extracted.
package log;
sub l {}

package detect_devices;
sub matching_desc { 1 }

package install_any;
sub getFile { open FILE, "$dir/$_[0]" or return; \*FILE }

package pkgs;
sub if_ { my $b = shift; $b or return (); wantarray ? @_ : $_[0] }
sub formatXiB { $_[0] } #- NOP
sub packageName { ::chop_version($_[0]{name}) }
sub packageFlagSelected { $_[0]{selected} }
sub packageSize { $_[0]{size} }
sub packageDepsId { @{$_[0]{deps}} }
sub packageRate { $_[0]{values}[0] }
sub packageRateRFlags { @{$_[0]{values}} }
sub packageSetRateRFlags {
    my ($pkg, @rate_rflags) = @_;
    $pkg->{values} = [ @rate_rflags ];
}
sub packageByName {
    my ($packages, $name) = @_;
    $packages->{names}{$name};
}
sub packageById {
    my ($packages, $id) = @_;
    $packages->{depslist}[$id];
}
sub selectedSize {
    my ($packages) = @_;
    my $size = 0;
    foreach (@{$packages->{depslist}}) {
	$_->{selected} and $size += $_->{size};
    }
    $size;
}
my @preferred = qw(perl-GTK postfix gcc gcc-cpp gcc-c++ proftpd ghostscript-X vim-minimal kernel db1 db2 ispell-en Bastille-Curses-module nautilus libxpm4);
sub selectPackage {
    my ($packages, $pkg, $base, $otherOnly, $check_recursion) = @_;

    #- avoid infinite recursion (mainly against badly generated depslist.ordered).
    $check_recursion ||= {}; exists $check_recursion->{$pkg->{name}} and return; $check_recursion->{$pkg->{name}} = undef;

    #- make sure base package are set even if already selected.
    $base and $pkg->{base} = 1;

    #- select package and dependancies, otherOnly may be a reference
    #- to a hash to indicate package that will strictly be selected
    #- when value is true, may be selected when value is false (this
    #- is only used for unselection, not selection)
    unless ($pkg->{selected}) {
	foreach (@{$pkg->{deps}}) {
	    my $preferred;	    
	    if (/\|/) {
		#- choice deps should be reselected recursively as no
		#- closure on them is computed, this code is exactly the
		#- same as pixel's one.
		my %preferred; @preferred{@preferred} = ();
		foreach (split '\|') {
		    my $dep = $packages->{depslist}[$_] or next;
		    $preferred ||= $dep;
		    $dep->{selected} and $preferred = $dep, last;
		    exists $preferred{::chop_version($dep->{name})} and $preferred = $dep;
		}
		selectPackage($packages, $preferred, $base, $otherOnly, $check_recursion) if $preferred;
	    } else {
		#- deps have been closed except for choices, so no need to
		#- recursively apply selection, expand base on it.
		my $dep = $packages->{depslist}[$_];
		$base and $dep->{base} = 1;
		$otherOnly and !$dep->{selected} and $otherOnly->{::chop_version($dep->{name})} = 1;
		$otherOnly or $dep->{selected} += 1;
	    }
	}
    }
    $otherOnly and !$pkg->{selected} and $otherOnly->{::chop_version($pkg->{name})} = 1;
    $otherOnly or $pkg->{selected} += 1;
    1;
}

#- this code is extracted from DrakX and SHOULD NOT BE MODIFIED, wrapper method exists above to provide a good choice.
sub read_rpmsrate {
    my ($packages, $f) = @_;
    my $line_nb = 0;
    my $fatal_error;
    my (@l);
    while (<$f>) {
	$line_nb++;
	/\t/ and die "tabulations not allowed at line $line_nb\n";
	s/#.*//; # comments

	my ($indent, $data) = /(\s*)(.*)/;
	next if !$data; # skip empty lines

	@l = grep { $_->[0] < length $indent } @l;

	my @m = @l ? @{$l[$#l][1]} : ();
	my ($t, $flag, @l2);
	while ($data =~ 
	       /^((
                   [1-5]
                   |
                   (?:            (?: !\s*)? [0-9A-Z_]+(?:".*?")?)
                   (?: \s*\|\|\s* (?: !\s*)? [0-9A-Z_]+(?:".*?")?)*
                  )
                  (?:\s+|$)
                 )(.*)/x) { #@")) {
	    ($t, $flag, $data) = ($1,$2,$3);
	    while ($flag =~ s,^\s*(("[^"]*"|[^"\s]*)*)\s+,$1,) {}
	    my $ok = 0;
	    $flag = join('||', grep { 
		if (my ($inv, $p) = /^(!)?HW"(.*)"/) {
		    ($inv xor detect_devices::matching_desc($p)) and $ok = 1;
		    0;
		} else {
		    1;
		}
	    } split '\|\|', $flag);
	    push @m, $ok ? 'TRUE' : $flag || 'FALSE';
	    push @l2, [ length $indent, [ @m ] ];
	    $indent .= $t;
	}
	if ($data) {
	    # has packages on same line
	    my ($rate) = grep { /^\d$/ } @m or die sprintf qq(missing rate for "%s" at line %d (flags are %s)\n), $data, $line_nb, join('&&', @m);
	    foreach (split ' ', $data) {
		if ($packages) {
		    my $p = packageByName($packages, $_) or next;
		    my @m2 = 
		      map { if_($_ && packageName($_) =~ /locales-(.*)/, qq(LOCALES"$1")) }
		      map { packageById($packages, $_) } packageDepsId($p);

		    my @m3 = ((grep { !/^\d$/ } @m), @m2);
		    if (@m3 >= 1 && $m3[0] eq 'INSTALL' || @m3 >=2 && $m3[1] eq 'INSTALL') {
			push @{$packages->{needToCopy} ||= []}, $_;
			next; #- don't need to put INSTALL flag for a package.
		    }
		    if (packageRate($p)) {
			my ($rate2, @m4) = packageRateRFlags($p);
			if (@m3 > 1 || @m4 > 1) {
			    log::l("can't handle complicate flags for packages appearing twice ($_)");
			    $fatal_error++;
			}
			log::l("package $_ appearing twice with different rates ($rate != $rate2)") if $rate != $rate2;
			packageSetRateRFlags($p, $rate, "$m3[0]||$m4[0]");
		    } else {
			packageSetRateRFlags($p, $rate, @m3);
		    }
		} else {
		    print "$_ = ", join(" && ", @m), "\n";
		}
	    }
	    push @l, @l2;
	} else {
	    push @l, [ $l2[0][0], $l2[$#l2][1] ];
	}
    }
    $fatal_error and die "$fatal_error fatal errors in rpmsrate";
}

sub readCompssUsers {
    my ($packages, $meta_class) = @_;
    my (%compssUsers, %compssUsersIcons, , %compssUsersDescr, @sorted, $l);
    my (%compss); 

    my $file = 'Mandrake/base/compssUsers';
    my $f = $meta_class && install_any::getFile("$file.$meta_class") || install_any::getFile($file) or die "can't find $file";
    local $_;
    while (<$f>) {
	/^\s*$/ || /^#/ and next;
	s/#.*//;

	if (/^(\S.*)/) {
	    my ($icon, $descr);
	    /^(.*?)\s*\[icon=(.*?)\](.*)/  and $_ = "$1$3", $icon  = $2;
	    /^(.*?)\s*\[descr=(.*?)\](.*)/ and $_ = "$1$3", $descr = $2;
	    $compssUsersIcons{$_} = $icon; 
	    $compssUsersDescr{$_} = $descr; 
	    push @sorted, $_;
	    $compssUsers{$_} = $l = [];
	} elsif (/^\s+(.*?)\s*$/) {
	    push @$l, $1;
	}
    }
    \%compssUsers, \@sorted, \%compssUsersIcons, \%compssUsersDescr;
}

sub setSelectedFromCompssList {
    my ($packages, $compssUsersChoice, $min_level, $max_size, $otherOnly) = @_;
    $compssUsersChoice->{TRUE} = 1; #- ensure TRUE is set
    my $nb = selectedSize($packages);
    foreach my $p (sort { packageRate($b) <=> packageRate($a) } values %{$packages->{names}}) {
	my ($rate, @flags) = packageRateRFlags($p);
	next if 
	  !$rate || $rate < $min_level || 
	  grep { !grep { /^!(.*)/ ? !$compssUsersChoice->{$1} : $compssUsersChoice->{$_} } split('\|\|') } @flags;

	#- determine the packages that will be selected when
	#- selecting $p. the packages are not selected.
	my %newSelection;
	selectPackage($packages, $p, 0, \%newSelection);

	#- this enable an incremental total size.
	my $old_nb = $nb;
	foreach (grep { $newSelection{$_} } keys %newSelection) {
	    $nb += packageSize($packages->{names}{$_});
	}
	if ($max_size && $nb > $max_size) {
	    $nb = $old_nb;
	    $min_level = packageRate($p);
	    last;
	}

	#- at this point the package can safely be selected.
	if ($otherOnly) {
	    selectPackage($packages, $p, 0, $otherOnly);
	} else {
	    selectPackage($packages, $p);
	}
    }
    unless ($otherOnly) {
	log::l("setSelectedFromCompssList: reached size ", formatXiB($nb), ", up to indice $min_level (less than ", formatXiB($max_size), ")");
	log::l("setSelectedFromCompssList: ", join(" ", sort map { packageName($_) } grep { packageFlagSelected($_) } @{$packages->{depslist}}));
    }
    $min_level;
}