#!/usr/bin/perl -w
# Paulo Trezentos - Caixa Mágica 2009,2010
# Sofia Flores - Caixa Magica, IST 2009
# This is the main wrapper responsible for the pipeline of apt-pbo
#
# For example:
# apt-pbo install car
# |__ apt-get pboinstall car
# + /tmp/problem.pbo
# |__ minisat+ /tmp/problem.pbo
# + car turbo wheel
# |__ apt-get install car turbo wheel
# use strict;
use Term::ANSIColor;
use Switch;
use File::Copy;
use Getopt::Long;
use AptPkg::Config '$_config';
use AptPkg::System '$_system';
use AptPkg::Cache;
use AptPkg::Version;
(my $self = $0) =~ s#.*/##;
# Arguments
my $pbopolicy="";
my $solver="";
my $pbooptimal="";
my $cudfarg;
my $benchmark = 0;
my $interactive = 0;
# Process arguments
GetOptions("p=s"=>\$pbopolicy,
"b" =>\$benchmark,
"i" =>\$interactive,
"s=s" =>\$solver,
"c=s" =>\$optconf,
"to=i"=> \$pbooptimal,
"cudfin=s" => \$cudfin,
"cudfout=s" => \$cudfout);
# $ARGV[0] must be "install"
#$packagename=$ARGV[1];
usage() if ((! defined $cudfin) && (! defined $ARGV[0]) && ($ARGV[0] ne "install") );
my $logdir;
my $aptdef;
my $dpkgdef;
my $aptconf;
my $checkbroken;
my $pbo ;
my $pkgsfile ;
my $statusfile;
my $minisatbin;
my $wbobin ;
my $opbdpbin ;
my $bsolobin ;
my $debugcounter = 0;
my $timeelapse = 0;
my $timepboenc = 0;
my $timeminisat = 0;
my $timeparsesol = 0;
my $timeparserdeps = 0;
my $timeinstall = 0;
my $timestart = 0;
my $timestop = 0;
my %cacheprovides ;
my %cacherdepends ;
my %cacherconflicts ;
my $tpkg = $ARGV[1];
my $instcmd;
my $line;
my $line2="";
my %installedpackages;
my %packages2install;
my %packages2remove;
my %packages2update;
my %ipackages;
my %upackages;
my %dpackages;
my %rpackages;
my $print_upkgs="";
my $print_dpkgs="";
my @check_rdeps=();
my @check_rconfs=();
our @pbopkgs;
my $worktodo=1;
my $numiterations=0;
my $allextraconstraints="";
my $extraconstraint="";
my $numvarsconstraints=0;
my $cache;
my $policy;
if (defined $cudfin) {
$homedir=".";
die "\n Error: the solver is not being run from the solver directory. Change into it or correct \$homedir variable.\n\n" if (! -f $homedir . "/cudf_parsing.pl");
require "$homedir/cudf_parsing.pl";
# Configuration variables
$logdir = "$homedir/log/";
$aptdef = "$homedir/tools/apt-get.sh"; # Can't use a static binary due to C++ global constructors and linker
$dpkgdef = "$homedir/tools/dpkg --admindir=dpkg/"; # static binary
$aptconf = "-c=$homedir/conf/apt.conf";
$checkbroken = "-f";
$pbo = "$homedir/tmp/problem.pbo";
$pkgsfile = "$homedir/repo/Packages";
$statusfile = "$homedir/dpkg/status";
$minisatbin = "./tools/minisat+";
$wbobin = "./tools/wbo";
$bsolobin = "./tools/bsolo";
$opbdpbin = "./tools/opbdp";
}
else
{
$bindir="/usr/bin/";
$tmpdir="/tmp/";
# Configuration variables
$logdir = $tmpdir;
$aptdef = $bindir . "apt-get";
# $aptdef = $bindir . "apt-get --reduced-tree";
$dpkgdef = `which dpkg`;
if (defined $optconf) {
$aptconf = "-c=" . $optconf;
}
else {
$aptconf = "";
}
$checkbroken = "";
$pbo = $tmpdir . "problem.pbo";
$minisatbin = $bindir . "minisat+";
$wbobin = $bindir . "wbo";
$opbdpbin = $bindir . "opbdp";
$bsolobin = $bindir . "bsolo";
}
if ($instcmd = `which rpm` ne "")
{
$pkgsystem="rpm";
$instcmd = `which rpm`;
chomp($instcmd);
}elsif ($instcmd = `which dpkg` ne "")
{
$pkgsystem="deb";
$instcmd = $dpkgdef;
chomp($instcmd);
}
else
{
die "Can't find rpm or dpkg commands!\n";
}
sub usage {
print "apt-pbo (http://aptpbo.caixamagica.pt) \n";
print "Usage: apt-pbo [options] install pkg \n\n";
print "Apt-pbo is a meta-installer that uses pseudo-boolean optimization to find a solution of the packages to install / remove.\n\n";
print "Options:\n";
print " -p=? Policy for choosing the solution (-p=freshness|-removal|-number)\n";
print " -s=? PBO solver to be used (-s=minisat+[default]|bsolo|opbdp|wbo) \n";
print " -cudf=? CUDF file to load \n";
print " -o Solver provides the optimal solution.\n\n";
die "Error: wrong number of arguments. \n\n";
}
sub get_provides {
my ($name, $version) = @_;
if (! defined $version) {
print (" Package $name does not have version. Broken? Ignoring it. \n");
return ;
}
if (!defined $cacheprovides{$name}) {
my $p = $cache->{$name};
unless ($p)
{
# warn "$self: Don't know anything about package `$name'\n";
return;
}
if (my $available = $p->{VersionList})
{
for my $v (@$available) {
if ($v->{VerStr} eq $version) {
if (my $prov = $v->{ProvidesList})
{
$cacheprovides{$name}=join ' ', map $_->{Name}, @$prov;
return (map $_->{Name}, @$prov);
}
}
}
}
$cacheprovides{$name}="";
}
else {
return $cacheprovides{$name};
}
}
sub extract_version() {
my ($elem)=@_;
my $name;
my $version;
# Finding version and release
#print "Elem: $elem \n" if ($elem =~ m/libstdc/);
# In debian, the regular expression should be:
# if ($elem =~ /(.+)_(\d[^_]*-[^-]*)$/)
# because versions must start with a digit.
# But RPM is more permissive and we had to relax the regexp
if ($elem =~ /(.+)_([0-9a-zA-Z][^_]*-[^-]*)$/)
{
$name=$1;
$version=$2;
$elem =~ s/-([^-]*-[^-]*)$/.............................$1/g;
}
elsif ($elem =~ /(.+)_(\d[^_]*)$/)
{
#print " Package name no release: $elem - $1 - $2.\n";
# Package name does not have release, so by the rules
# version number can not have "-"
# print "Package name:$1\n";
$name=$1;
# print "Version-release:$2\n";
$version=$2;
}
else
{
$name=$elem;
}
# $version =~ s/(-[\w+\.]+\d)$//g; # Apaga a release
# Remove epoch
# $version =~ s/^[\d]://g;
# print "$name | $version\n";
return ($name,$version);
}
sub extract_qa_rpm(){
my ($elem)=@_;
my $name;
my $version;
my $release;
my $tversion;
if($elem =~ s/-([^-]*)$//g){
$release=$1;
}
# removing non-existen epochs in RPM
$elem =~ s/\(none\)\://g;
# have to remove epoch "0:" because libapt doesn't print epoch ":0" in pboinstall
# and when comparing apt-pbo says that is a download
$elem =~ s/0\://g;
if($elem =~ s/-([\:|\w+.\w+]*)$/-$1/g){
$tversion=$1;
}
if($elem =~ s/-([^-]*)$//g){
$name=$elem;
}
$version = $tversion . "-" . $release;
return ($name, $version);
}
sub extract_qa_deb(){
my ($elem)=@_;
my $name;
my $version;
# format of dpkg -l:
# ii apt-pbo 0.91-1 An meta-installer that uses PBO solving
if($elem =~ s/^\w\w\s+(\S+)\s+(\S+)//g){
$name=$1;
$version=$2;
# Remove epoch
# $version =~ s/^[\d]://g;
}
# print " - $name | $version - \n";
return ($name, $version);
}
sub list_pkg {
my $pkglist = ( $pkgsystem eq "rpm" ) ? "$instcmd -qa --queryformat \"%{NAME}-%{EPOCH}:%{VERSION}-%{RELEASE}\n\"" : "$instcmd -l ";
# my $pkglist = ( $pkgsystem eq "rpm" ) ? "$instcmd -qa --queryformat \"%{NAME}-%{VERSION}-%{RELEASE}\n\"" : "$instcmd -l ";
my %ipkgs;
my ($name, $version);
open(PKGLIST, "$pkglist |") or die "Can't execute '$pkglist'!\n";
foreach $elem (<PKGLIST>) {
chomp($elem);
if ($pkgsystem eq "rpm") {
($name,$version) = &extract_qa_rpm($elem);
}
elsif ($pkgsystem eq "deb") {
if ($elem =~ /^\wi/ || $elem =~ /^\wU/) {
# ii/iU and rc are valid lines in dpkg output
($name,$version) = &extract_qa_deb($elem);
}
else {
next;
}
}
$ipkgs{$name}=$version;
}
close (PKGLIST);
return %ipkgs;
}
sub print {
my ($options, $string) = @_;
print color $options;
print $string;
print color 'reset';
}
sub pboencoding{
my $pbotmp=shift(@_);
my $pkgtmp = join(' ',@_);
if ( $numiterations eq 1) {
print "\nBeginning dependencies problem solving...\n";
}
else {
print "\n New iteration (#$numiterations) \n";
}
print " [1] Encoding problem as PBO...\n";
# print "$aptdef $pbotmp pboinstall $pkgtmp\n";
$timestart=time();
$pbopolicy="removal" if ($pbopolicy eq "" );
# TO DO. uncomment after having apt-get static
open(APTPBOCMD, "$aptdef $aptconf $checkbroken -p=$pbopolicy pboinstall $pkgtmp 2>&1 |") or die "Can't execute apt-get 'apt-get pboinstall $ARGV[1]'\n!\n";
# print "Debug: $aptdef $aptconf $checkbroken -p=$pbopolicy pboinstall $pkgtmp \n";
while (<APTPBOCMD>) {
$line = $_;
# Unable to locate package aasas
die "Can't execute '$aptdef $aptconf $checkbroken -p=$pbopolicy pboinstall $pkgtmp'\n $line\n"
if ( ($line =~/^W:/) || ($line =~ /^E:/) );
}
close(APTPBOCMD);
if($allextraconstraints ne "") {
open(FILE, ">>$pbo");
print FILE "$allextraconstraints";
close(FILE);
}
$timestop = time();
$timepboenc = $timepboenc + $timestop - $timestart;
my $pbologname=$pkgtmp;
$pbologname =~ s/ //g;
$pbologname =~ s/://g;
$pbologname = substr($pbologname, 0, 32);
copy($pbo, $logdir . "pbo/" . $pbologname . "." . $numiterations . ".pbo");
print " PBO problem encoding finished. \n";
# print " Stored in: $pbo. \n\n";
}
sub parsing_solver_output{
my $solverSolution;
while (<MINICMD>) {
$line = $_;
if ( $line =~ /^v/) {
# wbo / minisat+ output solution
$line =~ s/^v //g;
$solverSolution = $line;
}
elsif ( $line =~ /^0-1 Variables fixed to 1 :/) {
# opbdp output solution
$line =~ s/^0-1 Variables fixed to 1 : //g;
$solverSolution = $line;
# print "opbdp: $line \n";
}
elsif (( $line =~ /^s\sUNSATISFIABLE/) || ( $line =~ /^Constraint Set is unsatisfiable/)) {
print "\n [3] No solution found. \n";
my @broken;
my $failmsg;
open(PBOFILE, "<$pbo") or die "Can't open PBO file to parse ($pbo)!\n";
while (<PBOFILE>) {
$line = $_;
if($line =~ s/BROKEN_(\w[^_]+)_(\w[^_]+)_(.*?)\s+(.*)//g){
@brokdep=($1,$2,$3,$4);
if ( $brokdep[3] =~ /^-1\*(.*?)\s+/ ) {
print " Relation \"package $1 $brokdep[0] -> $brokdep[1]-$brokdep[2]\" is broken in the repository\n";
$failmsg=$failmsg . "Relation \"package $1 $brokdep[0] -> $brokdep[1]-$brokdep[2]\" is broken in the repository\n";
}
}
}
close (PBOFILE);
if (defined $cudfout) {
&write_no_solution_cudf($cudfout,$failmsg) ;
exit(0);
}
die "\n \n";
} elsif ( $line =~ /^s\sUNKNOWN/)
{
if (defined $cudfout) {
&write_no_solution_cudf($cudfout,"Solver timeout") ;
exit(2);
}
}
}
return $solverSolution;
}
sub parsing_solution_install{
while(my($name1, $version1) = each(%packages2install)){
if (exists $installedpackages{$name1}){ # Pacote já está instalado
my $version2 = $installedpackages{$name1};
if(!($version1 eq $version2)){ # Exists but with a different version
# fetch a versioning system
my $vs = $_system->versioning;
# if($version1 gt $version2){ # Upgrade
if($vs->compare($version1, $version2) > 0) { #upgrade
$upackages{$name1}=$version1;
$print_upkgs = $print_upkgs . ' ' . $name1 . "(" . $version2 . " -> " . $version1 .")"; # user msg
if ( ! grep( /^upgrade-$name1$/,@check_rdeps ) ) {
push(@check_rdeps,"upgrade-" . $name1); # check rdeps of removed packaged
}
if ( ! grep( /^upgrade-$name1$/,@check_rconfs ) ) {
push(@check_rconfs,"upgrade-" . $name1); # check rconfs of new package
}
}elsif ($vs->compare($version1, $version2) > 0) { # Downgrade
# print " Downgrade: $name1 - |$version1| - |$version2| \n";
$dpackages{$name1}=$version1;
$print_dpkgs = $print_dpkgs . ' ' . $name1 . "(" . $version2 . " -> " . $version1 .")"; # downgrade user msg
if ( ! grep( /^downgrade-$name1$/,@check_rdeps ) ) {
push(@check_rdeps,"downgrade-" . $name1); # check rdeps of removed packaged
}
if ( ! grep( /^downgrade-$name1$/,@check_rconfs ) ) {
push(@check_rconfs,"downgrade-" . $name1); # check rconfs of new package
}
} else
{
# package is already installed in current version
# don't need to check rconfs with provides
next;
}
}
else
{
next;
}
# print "Installed: $name1 | $ipackages{$name1} | $version1\n";
}else{ # Package is not installed
$ipackages {$name1} = $version1;
# print "Not installed: $name1 | $ipackages{$name1} | $version1\n";
if ( ! grep( /^$name1$/,@check_rconfs ) ) {
push(@check_rconfs,$name1);
}
}
# If the package has a "Provides:" we have to check if it does not conflict with a installed package
my @provides=get_provides($name1, $version1);
# print "Provides: @provides \n";
foreach $elem (@provides) {
if ( ! grep( /^$elem$/,@check_rconfs ) ) {
push(@check_rconfs,$elem);
}
}
}
}
sub parsing_solution_remove{
foreach $name1 (keys %packages2remove) {
foreach $version1 (@{$packages2remove{$name1}}) {
# warn chomp($version1);
# print " H:$name1 1:$version1 \n";
if (exists $installedpackages{$name1}){ # Pacote está instalado
if(!exists $packages2install{$name1}){
my $version2 = $installedpackages{$name1};
#print " H:$name1 -$version1-$version2- \n";
if($version2 eq $version1){
$rpackages {$name1} = $version1;
if ( ! grep( /^$name1$/,@check_rdeps ) ) {
push(@check_rdeps,$name1);
}
# If the package has a "Provides:" we have to check if the provides is not a dependency of a installed package
my @provides=&get_provides($name1,$version1);
foreach $elem (@provides) {
if ( ! grep( /^$elem$/,@check_rdeps ) ) {
push(@check_rdeps,$elem);
}
}
}
}
}
else {
next;
}
}
}
}
sub parsing_solution{
my $solution=shift(@_);
my @foo = (split / /,$solution);
$numvarsconstraints=0;
$extraconstraint="";
foreach $elem (@foo) {
# print "elem: $elem ";
# storing in case the user request for a different solution
if ($elem =~ m/\s*^[^-].*/) { # Pacotes que não podem estar instalados
$extraconstraint=$extraconstraint . " +1 * " . $elem ;
$numvarsconstraints++;
}
# Remove architecture
if ($pkgsystem eq "deb") {
$elem =~ s/i386pbo_//g; # Remove architecture
$elem =~ s/allpbo_//g; # Remove architecture
$elem =~ s/amd64pbo_//g; # Remove architecture
} else {
$elem =~ s/noarchpbo_//g; # Remove architecture
$elem =~ s/i586pbo_//g; # Remove architecture
$elem =~ s/x86_64pbo_//g; # Remove architecture
}
if ($elem =~ m/^-.*/) { # Pacotes que não podem estar instalados
$elem =~ s/^-//g; # Remove o - do início
chomp($elem);
($name,$version) = &extract_version($elem);
if ($elem){
# A simple hash doesn't work because a package can have multiple versions.
# We use an array of the versions to be removed in the value of the hash.
push(@{ $packages2remove{$name} }, $version);
# $packages2remove{$name}=$version;
}
next
};
chomp($elem);
if ( ! $elem ) {
next
}
($name,$version) = &extract_version($elem);
if ( $elem ) {
# Remove epoch
# $version =~ s/^\d://g;
$packages2install{$name}=$version;
}
# print "$name | $version\n";
}
&parsing_solution_remove();
&parsing_solution_install();
}
sub call_solver{
# my %ipkgs =();
# my %upkgs =();
# my %dpkgs =();
# my %rpkgs =();
%packages2install=();
%packages2remove=();
%packages2update=();
%ipackages=();
%upackages=();
%dpackages=();
%rpackages=();
$print_upkgs="";
$print_dpkgs="";
if (! $pbooptimal) {
# Default. No timeout.
$msat_timeout=0;
} else
{
# User set alarm time (in seconds).
$msat_timeout=$pbooptimal;
}
my ($pbotmp) = @_;
my $line;
my $solution;
if (! $solver) {
$solver="minisat+";
}
print " [2] Executing solver ($solver)...\n";
$timestart = time();
open STDERR, '>&STDOUT';
if ($solver eq "minisat+") {
if ( ! -e $minisatbin) { die "Solver binary $wbobin is not present in the system\n\n"; }
open(MINICMD, "$minisatbin -alarm=$msat_timeout $pbotmp 2>&1 |") or die "Can't execute minisat '$minisatbin -alarm=$msat_timeout $pbotmp'\n!\n";
} elsif ( $solver =~ /wbo/) {
if ( ! -e $wbobin) { die "Solver binary $wbobin is not present in the system\n\n"; }
if (! $msat_timeout ) {
open(MINICMD, "$wbobin -file-format=opb $pbotmp 2>&1 |") or die "Can't execute solver '$wbobin -file-format=opb $pbotmp'\n!\n";
} else
{
open(MINICMD, "$wbobin -file-format=opb -search-mode=2 -time-limit=$msat_timeout $pbotmp 2>&1 |") or die "Can't execute solver '$wbobin -file-format=opb $pbotmp'\n!\n";
# print "Debug: $wbobin -file-format=opb -search-mode=2 -time-limit=$msat_timeout $pbotmp ";
}
} elsif ( $solver =~ /bsolo/) {
if ( ! -e $bsolobin) { die "Solver binary $bsolobin is not present in the system\n\n"; }
open(MINICMD, "$bsolobin -t$msat_timeout $pbotmp 2>&1 |") or die "Can't execute solver '$bsolobin -file-format=opb $pbotmp'\n!\n";
} elsif ( $solver =~ /opbdp/) {
if ( ! -e $opbdpbin) { die "Solver binary $opbdpbin is not present in the system\n\n"; }
open(MINICMD, "$opbdpbin -f$pbotmp -s 2>&1 |") or die "Can't execute solver '$opbdpbin -file$pbotmp'\n!\n";
} else {
die "\n Invalid solver. Solvers available: wbo, minisat+,opbd . \n\n";
}
close STDERR;
$solution=&parsing_solver_output();
close MINICMD;
$timestop = time();
$timeminisat = $timeminisat + $timestop-$timestart;
# print " Time minisat: $timeminisat \n";
print " Parsing the solution\n";
$timestart = time();
&parsing_solution($solution);
$timeparsesol = $timeparsesol + $timestop-$timestart;
# print " Time parsesol: $timeparsesol \n";
}
sub print_solution{
if ((keys( %ipackages ) == 0 ) && (keys( %upackages ) == 0) && (keys( %dpackages ) == 0) && (keys ( %rpackages ) == 0 ) ) {
if (defined $cudfout) {
# &write_no_solution_cudf($cudfout,"No solution found. Verify if package is not already installed or inexistent.\n\n") ;
return;
}
print " Verify if package is not already installed or inexistent.\n\n";
die "\n [3] No solution found.";
}
print " [3] Found a solution: \n";
if(keys( %ipackages ) != 0 ){
&print ("bold green", " Packages to install:");
while ( my ($key, $value) = each(%ipackages) ) {
print "$key(=$value) ";
}
&print ("bold", "\n Total packages to install: " . keys( %ipackages ) ."\n\n");
}
if(keys( %upackages ) != 0){
&print ("bold yellow", " Packages to update: ");
print "$print_upkgs\n";
&print ("bold", " Total packages to update: ". keys( %upackages ) ." \n\n");
}
if(keys ( %dpackages ) != 0){
&print ("bold yellow", " Packages to downgrade: ");
print "$print_dpkgs\n";
&print ("bold", " Total packages to downgrade: ". keys( %dpackages ) ."\n\n");
}
if(keys ( %rpackages ) != 0){
&print ("bold red", " Packages to remove: ");
while ( my ($key, $value) = each(%rpackages) ) {
print "$key(=$value) ";
}
&print ("bold", "\n Total packages to remove: ". keys( %rpackages ) ."\n");
}
}
sub install_packages{
# TODO
# 1.- este install package tem de ter o caminho para o ficheiro
# 2.- O caminho tem de ter a versao escapada
my @installpackages;
$timestart = time();
# Merge dpkgs into upkgs
@ipackages{keys %dpackages} = values %dpackages;
@ipackages{keys %upackages} = values %upackages;
my @removepackages=(keys(%rpackages));
if ($pkgsystem eq "rpm") {
while ( my ($key, $value) = each(%ipackages) ) {
my $esc_version = $value;
$esc_version=~ s/\d*://g;
push(@installpackages, '/var/cache/apt/archives/' . $key . "-" . $esc_version . ".*.rpm");
}
$raptcmd = $instcmd . " -e @removepackages";
$iaptcmd = $instcmd . " -Uh @installpackages";
}
elsif ($pkgsystem eq "deb") {
while ( my ($key, $value) = each(%ipackages) ) {
my $esc_version = $value;
$esc_version=~ s/:/%3a/g;
push(@installpackages, '/var/cache/apt/archives/' . $key . "_" . $esc_version . "_*deb");
}
$raptcmd = $instcmd . " -r --force-depends --force-conflicts @removepackages";
$iaptcmd = $instcmd . " -i --force-depends --force-conflicts @installpackages";
}
if ($interactive eq "0") {
print "\n [4]";
} else
{
print "\n ";
}
print " Preparing packages to install \n";
if (keys ( %rpackages ) != 0) {
print " Removing packages...\n";
open(RAPTCMD, "$raptcmd |") or die "Can't execute apt '$raptcmd'!\n";
while (<RAPTCMD>) {
$line = $_;
# print $line;
}
close(RAPTCMD);
}
# We will ask apt to download packages. Possible reasons to not download: already locally cached, file method,...
# This options may change in the future. Allow unsigned? Avoid recommends?
print " Downloading packages (if needed)...\n";
@installpackages=();
while ( my ($key, $value) = each(%ipackages) ) {
push(@installpackages, " $key=$value");
}
# my $daptcmd = "$aptdef -y --allow-unauthenticated --force-yes --no-install-recommends -d install @installpackages" ;
my $daptcmd = "$aptdef -y --force-yes -d install @installpackages" ;
# print "CMD-$daptcmd \n";
open(APTCMD, "$daptcmd 2>&1 |") or die "Apt can't execute download of @installpackages !\n";
while (<APTCMD>) {
$line = $_;
print " " . $line if ( $line =~ /^Get:/ ); # Print Get lines...
#print "$line";
if ( $line =~/^E:/ ) {
print "$line";
die "\n Problems with package download. \n\n Instalation aborted \n\n" ;
}
}
close (APTCMD);
print " Installing / updating packages... \n";
# print "CMD-$iaptcmd \n";
open(IAPTCMD, "$iaptcmd 2>&1 |") or die "Can't execute package install '$iaptcmd'!\n";
while (<IAPTCMD>) {
$line = $_;
# print $line;
die "\n Problems with package installation. \n\n Instalation aborted \n\n"
if ( $line =~/Errors\swere\sencountered\swhile\sprocessing/ );
}
close(IAPTCMD);
$timestop = time();
$timeinstall = $timeinstall + $timestop-$timestart;
# print " Time install: $timeinstall \n";
# Benchmark: iterations , elapse , minisat , parse sol, parse rdeps , install pkgs
print " Benchmark: " . $numiterations . "," .
(time() - $timeelapse) . "," .
$timepboenc . "," .
$timeminisat . "," .
$timeparsesol . "," .
$timeparserdeps . "," .
$timeinstall . "\n" if $benchmark;
print " Instalation completed with success\n\n";
}
sub check_revdeps_confs {
# print "check_rconfs: @check_rconfs \n";
for my $elem (@check_rconfs) {
my $elem_transaction="";
if ($elem =~ s/^upgrade-(.*)$/$1/g)
{
#print "Upgrade:$elem\n" ;
$elem_transaction="upgrade";
} elsif ($elem =~ s/^downgrade-(.*)$/$1/g) {
#print "Downgrade:$elem\n" ;
$elem_transaction="downgrade";
}
else {
$elem_transaction="";
}
if (! defined $cacherconflicts{$elem}) {
$cacherconflicts{$elem}="";
my $p = $cache->{$elem};
unless ($p)
{
# warn "$self: Don't know anything about package `$name'\n";
next;
}
if (my $revdeps = $p->{RevDependsList})
{
my $parent = '';
my $type = '';
for my $r (@$revdeps)
{
my $new_parent = "$r->{ParentPkg}{Name} $r->{ParentVer}{VerStr}";
unless ($new_parent eq $parent)
{
$parent = $new_parent;
$type = '';
}
# print $r->{TargetPkg}{Name};
# print " ($r->{CompTypeDeb} $r->{TargetVer})" if $r->{TargetVer};
if ($r->{DepType} ne 'Conflicts' && $r->{DepType} ne 'Replaces') {
next;
}
if (($elem_transaction eq "upgrade") && ($r->{CompTypeDeb} eq "<<" || $r->{CompTypeDeb} eq "<=")) {
# print "$elem tem rdep de $1 (op $depsOper=$2 e operacao $elem_transaction)\n";
next;
}
if (($elem_transaction eq "downgrade") && ($r->{CompTypeDeb} eq ">>" || $r->{CompTypeDeb} eq ">=")) {
# print "$elem tem rdep de $1 (op $depsOper=$2 e operacao $elem_transaction)\n";
next;
}
if ($r->{DepType} ne $type)
{
# printf "\n %-30s", $type ? '' : $parent;
# $type = $r->{DepType};
# print " $parent $r->{DepType} $r->{CompTypeDeb}: $r->{TargetPkg}{Name} \n";
$cacherconflicts{$elem}=$cacherconflicts{$elem} . " " . $parent ;
}
}
}
}
for $relem (split(/ /, $cacherconflicts{$elem})) {
if ( (! exists $check_rconfs{ $relem }) && ( exists $installedpackages{ $relem } ) ) {
# print " Push rconfs pbo: $relem (a partir de $elem) \n";
push (@pbopkgs,$relem) ;
$check_rconfs { $relem } = 'checked';
$worktodo=1;
}
}
}
}
sub check_revdeps_deps {
# print "check_rdeps: @check_rdeps \n";
for my $elem (@check_rdeps) {
my $elem_transaction="";
if ($elem =~ s/^upgrade-(.*)$/$1/g)
{
#print "Upgrade:$elem\n" ;
$elem_transaction="upgrade";
} elsif ($elem =~ s/^downgrade-(.*)$/$1/g) {
#print "Downgrade:$elem\n" ;
$elem_transaction="downgrade";
}
else {
$elem_transaction="";
}
if (! defined $cacherdepends{$elem}) {
$cacherdepends{$elem}="";
my $p = $cache->{$elem};
unless ($p)
{
warn "$self: Don't know anything about package `$name'\n";
next;
}
if (my $revdeps = $p->{RevDependsList})
{
my $parent = '';
my $type = '';
for my $r (@$revdeps)
{
my $new_parent = "$r->{ParentPkg}{Name} $r->{ParentVer}{VerStr}";
unless ($new_parent eq $parent)
{
$parent = $new_parent;
$type = '';
}
# print "Revdeps: $r->{TargetPkg}{Name} ";
# print " ($r->{CompTypeDeb} $r->{TargetVer})" if $r->{TargetVer};
# print "\n";
if ($r->{DepType} ne 'Depends' && $r->{DepType} ne 'PreDepends') {
next;
}
if (($elem_transaction eq "upgrade") && ($r->{CompTypeDeb} eq ">>" || $r->{CompTypeDeb} eq ">=")) {
#print " $parent tem rdep $elem \n";
#print " Upgrade ($r->{CompTypeDeb}) - exiting \n";
next;
}
if (($elem_transaction eq "downgrade") && ($r->{CompTypeDeb} eq "<=" || $r->{CompTypeDeb} eq "<<")) {
#print " $parent tem rdep $elem \n";
#print " Downgrade ($r->{CompTypeDeb}) - exiting \n";
next;
}
if ($r->{DepType} ne $type)
{
# printf "\n %-30s", $type ? '' : $parent;
# $type = $r->{DepType};
# print " rcacherdepends += $parent ($r->{DepType}) \n";
$cacherdepends{$elem}=$cacherdepends{$elem} . " " . $parent;
}
}
}
}
for $relem (split(/ /, $cacherdepends{$elem})) {
if ( (! exists $check_rdeps{ $relem }) && ( exists $installedpackages{ $relem } ) ) {
# print " Push pbo: $relem (a partir de $elem) \n";
push (@pbopkgs,$relem);
$check_rdeps { $relem } = 'checked';
$worktodo=1;
}
}
}
}
sub check_revdeps {
$timestart = time();
$worktodo=0;
&check_revdeps_deps();
&check_revdeps_confs();
$timestop = time();
$timeparserdeps = $timeparserdeps + $timestop-$timestart;
# print " Time parserdeps: $timeparserdeps \n";
}
sub find_solution(){
my $somethingtodo=0;
for my $packagename (@pbopkgs) {
my $p = $cache->{$packagename};
unless ($p)
{
warn "$self: Don't know anything about package `$packagename'\n";
# die "\n Package is not available. Verify you repositories.\n\n";
next;
}
if ($p->{CurrentState} =~ /^Installed$/) {
warn "$self: Package '$packagename' is already installed. Will try to update it. \n";
# next;
}
$somethingtodo=1;
}
if ($somethingtodo == 0) {
die "\n\n Nothing to do. Exiting apt-pbo ....\n";
}
# separator of arguments to pass to "apt-get pboinstall"
push (@pbopkgs,"aux:");
%installedpackages=&list_pkg;
$timeelapse=time();
do {
$numiterations++;
&pboencoding($pbopolicy, @pbopkgs);
&call_solver($pbo);
$worktodo=0;
&check_revdeps();
} until ($worktodo eq 0);
&print_solution;
if (defined $cudfout) {
&write_solution_cudf($cudfout,\%ipackages,\%upackages,\%dpackages,\%rpackages,$print_upkgs,$print_dpkgs);
print " Benchmark: " . $numiterations . "," . (time() - $timeelapse) . "," . $timepboenc . "," . $timeminisat . "," . $timeparsesol . "," . $timeparserdeps . "," . $timeinstall . "\n" if $benchmark;
exit(0);
}
}
# What one can call "main"
# initialise the global config object with the default values and
# setup the $_system object
$_config->init;
# if needed, read cudf and generate cache
if (defined $cudfin) {
print "Reading CUDF and generating status / repo...\n";
@pbopkgs = &read_cudf ($cudfin,$statusfile,$pkgsfile);
print "Generating cache...\n";
open(UPDATECMD, "$aptdef $aptconf update |") or die "Can't execute apt '$raptcmd'!\n";
while (<UPDATECMD>) {
$line = $_;
# print $line;
}
close(UPDATECMD);
my @configarg;
push(@configarg,$aptconf);
$_config->parse_cmdline([ [ 'c', 'config-file', '', 'ConfigFile' ] ], @configarg );
} else {
@pbopkgs = @ARGV;
shift @pbopkgs; # discart "install" argument
}
sub query_install(){
print "Do you want to install the solution (y/n)? ";
$x=<STDIN>;
#$x="n";
#$x="y";
if ( $x =~ /y/ ) {
&install_packages;
exit;
} else{
if ($x =~ /n/){
# Benchmark: iterations , elapse , minisat , parse sol, parse rdeps , install pkgs
print " Benchmark: " . $numiterations . "," .
(time() - $timeelapse) . "," .
$timepboenc . "," .
$timeminisat . "," .
$timeparsesol . "," .
$timeparserdeps . "," .
$timeinstall . "\n" if $benchmark;
#print "Debug counter: $debugcounter \n";
exit;
}
}
}
sub dep_loop{
my ($pkg) = @_;
my @new_dep = ();
for $i ( 0 .. $#global_dep ){
# print "+$pkg ++$global_dep[0]->[0]\n";
if ($pkg =~ m/($global_dep[$i][0])/) {
if ($global_dep[$i][1] < 1) {
$global_dep[$i][1]++;
return $global_dep[$i][1];
} else {
return -1;
}
}
}
@new_dep = ($pkg, 0);
# push(@global_dep, @new_dep);
push @global_dep, [ @new_dep ];
}
sub show_conflicts{
my ($pkg, $sol, $level, $sol_u, $sol_r) = @_;
$sol_r =~ s/^\s+//; #remove white spaces from string beginning
$sol_r =~ s/\s+$//; #remove white spaces from string ending
open FILE, "<", "$pbo" or die $!;
my @lines = <FILE>;
shift(@lines); # removes the cost function
my @r_pkgs = (split / /, $sol_r);
my @conf_lines = ();
$sol = $sol_u . ' ' . $sol;
my @solution = (split / /, $sol);
foreach $r (@r_pkgs){
foreach $line (@lines){
if ($line =~ m/pbo_$r\s/){
push(@conf_lines, $line);
}
}
foreach $line (@conf_lines){
$line =~ s/\n//g; #remove line break
my @line_elem = split( / /, $line);
foreach $s (@solution){
if(($line =~ m/$s/) && ($s ne "")){
&print ("bold", "The package ");
($name, $version) = &extract_version($r);
&print ("bold red", "$name(= $version)");
&print ("bold"," will be removed because it has a conflit with ");
($name, $version) = &extract_version($s);
&print ("bold green", "$name(= $version)\n");
}
}
}
}
close FILE;
}
# Given a package prints all its dependencies
sub get_dependencies{
my ($pkg, $sol, $level, $sol_u, $sol_r) = @_;
open FILE, "<", "$pbo" or die $!;
my @lines = <FILE>;
my @dep = ();
my $res = 0;
$root = $pkg;
$pkg = $pkg . " >= 0 ;";
$sol_r =~ s/^\s+//; #remove white spaces from string beginning
$sol_r =~ s/\s+$//; #remove white spaces from string ending
foreach $elem (@lines){
chomp($elem);
# print " elem: $elem \n";
if ($elem =~ m/pbo_$pkg/){
my @all_dep = split(/ /, $elem);
pop(@all_dep); # removes the last element of the array
pop(@all_dep); # removes the last element of the array
pop(@all_dep); # removes the last element of the array
my $dep_lenght = scalar(@all_dep);
# @dep will have only valid entries. no white spaces or empty entries
foreach $d (@all_dep){
if (($d ne "") and ($d ne " ") and ($d !~ m/$root/)){
push(@dep, $d);
}
}
}
}
close FILE;
# remove duplicated entries from @dep
# and create a new array with dependencies @unique
my %hash = map {$_,1} @dep;
my @unique = keys %hash;
my @solution = (split / /, $sol);
my @solution_u = (split / /, $sol_u);
my @solution_r = (split / /, $sol_r);
#print "Dependencias de $root\n";
# foreach $u (@solution_r){
# print "$u\n";
# }
# print "---\n";
# Special case: main root
if ($level == 0){
my ($name, $version) = &extract_version($root);
&dep_loop($root);
&print ("bold", "+");
&print ("bold green"," $name(= $version)\n");
$level++;
}
foreach $elem (@unique){
foreach $s (@solution){
if(($elem =~ m/pbo_$s/) && ($s ne "")){
# print "$s está contido em $elem\n";
my $n=$level;
while($n != 0){
&print ("bold", "| ");
$n--;
}
&print ("bold", "+ ");
($name, $version) = &extract_version($s);
&print("bold green", "$name(= $version)\n");
$res = &dep_loop($s);
if($res != -1){
&get_dependencies($s, $sol, $level+1, $sol_u, $sol_r);
}
}
}
foreach $s (@solution_u){
if(($elem =~ m/pbo_$s/) && ($s ne "")){
# print "$s está contido em $elem\n";
my $n=$level;
while($n != 0){
print "| ";
$n--;
}
($name, $version) = &extract_version($s);
&print ("bold", "+ ");
&print("bold yellow", "$name(= $version)\n");
$res = &dep_loop($s);
if($res != -1){
&get_dependencies($s, $sol, $level+1, $sol_u, $sol_r);
}
}
}
foreach $s (@solution_r){
# print " ----s:$s | elem: $elem \n";
if(($elem =~ m/pbo_$s/) && ($s ne "")){
print " $s está contido em $elem\n";
my $n=$level;
while($n != 0){
print "| ";
$n--;
}
($name, $version) = &extract_version($s);
&print ("bold", "+ ");
&print("bold red", "$name(= $version)\n");
$res = &dep_loop($s);
if($res != -1){
&get_dependencies($s, $sol, $level+1, $sol_u, $sol_r);
}
}
}
}
}
sub handle_options{
my $answer="";
while ($answer ne "6") {
print "\n";
&print("bold blue", " [1] ");
print "Install- Install the proposed solution \n";
&print("bold blue", " [2] ");
print "Rerun - Find me another solution\n";
&print ("bold blue", " [3] ");
print "Weights - Change the default weights \n";
&print ("bold blue", " [4] ");
print "Blocking - Block packages you don't want to install or remove.\n";
&print ("bold yellow", " [5] ");
print "Draw Dependency Tree - Show the package dependency tree.\n";
&print ("bold red", " [6] ");
print "Quit - Quit the program\n";
print "Type your choice: ";
chomp($answer=<STDIN>);
switch($answer){
case /1/ {
&install_packages;
$answer=6;
}
case /2/ {
$allextraconstraints = $allextraconstraints . $extraconstraint . " < $numvarsconstraints ;\n";
&find_solution();
next;
}
case /3/ {
my $w_packageremoval="not defined";
my $w_versionremoval="not defined";
my $w_number="not defined";
my $w_freshness="not defined";
chomp(my $aptconfig= `which apt-config`);;
open(APTCONF, "$aptconfig dump |") or die "Can't execute apt-config dump!\n";
while (<APTCONF>) {
$line = $_;
$w_packageremoval=$1 if($line =~ s/APT::Get::Pbo-Package-Removal-Weight\s\"(.*)\"//g);
$w_versionremoval=$1 if($line =~ s/APT::Get::Pbo-Version-Removal-Weight\s\"(.*)\"//g);
$w_number=$1 if($line =~ s/APT::Get::Pbo-Number-Weight\s\"(.*)\"//g);
$w_freshness=$1 if($line =~ s/APT::Get::Pbo-Freshness-Weight\s\"(.*)\"//g);
}
close(APTCONF);
print " Defined weights: \n";
print " [P]ackage removal weight : $w_packageremoval \n";
print " [V]ersion removal weight : $w_versionremoval \n";
print " [N]umber of packages weight: $w_number \n";
print " [F]reshness weight : $w_freshness \n\n";
print " Introduce the corresponding letter: ";
my $optweight=<STDIN>;
unless ($optweight =~ m/^[pvnfPVNF]$/) {
print "\n\n That letter doesn't correspond to an existent weight. \n\n";
next;
} ;
print " Insert the new weight: ";
chomp(my $newweight=<STDIN>);
unless ($newweight =~ m/^\d+$/) {
print "\n\n The weight should only contain numbers. \n\n";
next;
} ;
my $chosenweight="";
my $aptconfexists=1;
switch($optweight){
case /[P|p]/ {
$chosenweight="APT::Get::Pbo-Package-Removal-Weight";
if ( $w_packageremoval eq "not defined") {
$aptconfexists=0;
}
}
case /[V|v]/ {
$chosenweight="APT::Get::Pbo-Version-Removal-Weight";
if ($w_versionremoval eq "not defined") {
$aptconfexists=0;
}
}
case /[N|n]/ {
$chosenweight="APT::Get::Pbo-Number-Weight";
if ($w_number eq "not defined") {
$aptconfexists=0;
}
}
case /[F|f]/ {
$chosenweight="APT::Get::Pbo-Freshness-Weight";
if ($w_freshness eq "not defined") {
$aptconfexists=0;
}
}
}
if ($aptconfexists eq 0) {
print "Vou escrever: asas \n";
open (APTCONF, '>>/etc/apt/apt.conf.d/caixamagica.conf') || die("Cannot Open File /etc/apt/apt.conf.d/caixamagica.conf");
print APTCONF "$chosenweight \"$newweight\";\n";
close(APTCONF);
}else {
open(APTCONF, "perl -pi -e 's/^$chosenweight.*\"/$chosenweight \"$newweight\"/' `find /etc/apt/ -type f` |") or die "Can't modify weight!\n";
close(APTCONF);
print "\n\n The weight $chosenweight is now defined to $newweight. \n\n";
}
next;
}
case /4/ {
if (keys ( %rpackages ) != 0) {
print "\n Type the packages you don't want to remove (\"pkg[=version]\" and space separated): ";
chomp (my $input = <STDIN>);
my @userremove = (split / /,$input);
foreach $pkgtmp (@userremove){
my $flagpkg=0;
$pkgtmp =~ s/=/_/;
my ($name,$version) = &extract_version($pkgtmp);
while ( my ($key, $value) = each(%rpackages) ) {
if ( $key eq $name) {
$flagpkg=1;
my $nummatch=0;
print " Package \"$key-$value\" will be marked to not be removed \n";
open(PBOFILE, "<$pbo") or die "Can't open PBO file to parse ($pbo)!\n";
if ( $version eq "") {
$version=".*";
}
my $string = <PBOFILE> ;
$extraconstraint="";
while ($string =~ /\*([^\*]*)pbo_(${key})_(${version}?)\s/g) {
$extraconstraint = $extraconstraint . " +1 * " . $1 . "pbo_" . $key . "_" . $3 ;
$nummatch++;
}
$extraconstraint = $extraconstraint . " >= 1;\n" ;
$allextraconstraints = $allextraconstraints . $extraconstraint ;
close (PBOFILE);
if ($nummatch eq 0) {
print " Nothing to be done. Didn't find package $key in solution. \n\n" ;
next;
}
}
}
if ($flagpkg eq "0") {
print " Error: package \"$pkgtmp\" is not in the solution as to be removed\n";
}
}
}
if (keys ( %ipackages ) != 0) {
print "\n Type the packages you don't want to install (\"pkg[=version]\" and space separated): ";
chomp (my $input = <STDIN>);
my @userinstall = (split / /,$input);
foreach $pkgtmp (@userinstall){
my $flagpkg=0;
$pkgtmp =~ s/=/_/;
my ($name,$version) = &extract_version($pkgtmp);
while ( my ($key, $value) = each(%ipackages) ) {
if ( $key eq $name) {
$flagpkg=1;
my $nummatch=0;
print " Package \"$key-$value\" will be marked to not be installed \n";
# $extraconstraint = " +1* $key< $numvarsconstraints ;\n"
open(PBOFILE, "<$pbo") or die "Can't open PBO file to parse ($pbo)!\n";
if ( $version eq "") {
$version=".*";
}
my $string = <PBOFILE> ;
$extraconstraint="";
while ($string =~ /\*([^\*]*)pbo_(${key})_(${version}?)\s/g) {
# print " BLA +1*" . $1 . "pbo_" . $key . "_" . $3 . "\n";
$extraconstraint = $extraconstraint . " +1 * " . $1 . "pbo_" . $key . "_" . $3 ;
$nummatch++;
}
$extraconstraint = $extraconstraint . " <= 0;\n" ;
$allextraconstraints = $allextraconstraints . $extraconstraint ;
close (PBOFILE);
if ($nummatch eq 0) {
print " Nothing to be done. Didn't find package $key in solution. \n\n" ;
next;
}
}
}
if ($flagpkg eq "0") {
print " Error: package \"$pkgtmp\" is not in the solution as to be installed\n";
}
}
}
&find_solution();
next;
}
case /5/{
my $ipackages_const="";
my $upackages_const="";
my $rpackages_const="";
my $root;
while ( my ($key, $value) = each(%ipackages) ) {
if ($key eq $ARGV[1]) {
$root = $key . "_" . $value;
# print " root: $root \n";
}
$ipackages_const=$ipackages_const . " " . $key . "_" . $value ;
}
while ( my ($key, $value) = each(%rpackages) ) {
$rpackages_const=$rpackages_const . " " . $key . "_" . $value ;
}
while ( my ($key, $value) = each(%upackages) ) {
$upackages_const=$upackages_const . " " . $key . "_" . $value ;
}
print "\nPrinting the dependency tree...\n\n";
&get_dependencies($root,$ipackages_const,0,$upackages_const,$rpackages_const);
&show_conflicts($root,$ipackages_const,0,$upackages_const,$rpackages_const);
next;
}
case /6/{
last;
}
}
}
}
$_system = $_config->system;
# Debug
#$_config->dump;
# supress cache building messages
$_config->{quiet} = 2;
# set up the cache
$cache = AptPkg::Cache->new;
if ($pkgsystem eq "deb") {
$policy = $cache->policy;
}
&find_solution();
if ($interactive eq "0") {
&query_install();
} else
{
&handle_options();
}
