2040 lines
45 KiB
Perl
2040 lines
45 KiB
Perl
package SL::Package;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Fcntl;
|
|
use IPC::Open3;
|
|
use IO::Select;
|
|
use Cwd 'abs_path';
|
|
use experimental 'smartmatch';
|
|
|
|
use parent 'SL';
|
|
|
|
our @EXPORT = qw(
|
|
installed
|
|
);
|
|
|
|
############################################################
|
|
#
|
|
# The FIELDS constant defines all available attributes for
|
|
# package files. The following is a brief description of
|
|
# each:
|
|
#
|
|
# * arch: The architecture for which the package is built
|
|
# * brief: short desription of package
|
|
# * builddeps: dependencies for building the package
|
|
# * bytes: total bytes of installed package
|
|
# * depends: comma separated list of package dependencies
|
|
# * description: long description of package
|
|
# * name: package name
|
|
# * path: path to package, either local or repo file
|
|
# * repo: repository where package is located, empty for
|
|
# local file
|
|
# * sha256: sha256sum for package file
|
|
# * sha256man: sha256sum for package manifest file
|
|
# * source: source server
|
|
# * srcpkg: name of git repo for package source
|
|
# * status: The current status of the package, one of:
|
|
# Failed config
|
|
# Failed extraction
|
|
# Failed postinst
|
|
# Failed postrm
|
|
# Failed preinst
|
|
# Failed prerm
|
|
# Failed purge
|
|
# Failed remove
|
|
# Installed
|
|
# Installed dependency
|
|
# Not installed
|
|
# Removed
|
|
# * url: upstream source url
|
|
# * version: version string
|
|
#
|
|
############################################################
|
|
|
|
use constant FIELDS => qw(
|
|
name
|
|
version
|
|
arch
|
|
depends
|
|
builddeps
|
|
srcpkg
|
|
status
|
|
bytes
|
|
url
|
|
path
|
|
source
|
|
repo
|
|
sha256
|
|
sha256man
|
|
brief
|
|
description
|
|
);
|
|
use constant STATS => {
|
|
FCONF => 'Failed config',
|
|
FEXT => 'Failed extraction',
|
|
FPOSTINST => 'Failed postinst',
|
|
FPOSTRM => 'Failed postrm',
|
|
FPREINST => 'Failed preinst',
|
|
FPRERM => 'Failed prerm',
|
|
FPURGE => 'Failed purge',
|
|
FREM => 'Failed remove',
|
|
INST => 'Installed',
|
|
INSTD => 'Installed dependency',
|
|
NINST => 'Not installed',
|
|
RM => 'Removed'
|
|
};
|
|
|
|
### new() ##################################################
|
|
#
|
|
# This creates a new package object. The attributes are
|
|
# defined in the FIELDS constant.
|
|
#
|
|
############################################################
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $package = shift;
|
|
my $slinfo = "$SL::sl->{'statdir'}/$package/slinfo";
|
|
my $self = {};
|
|
|
|
bless( $self, $class );
|
|
|
|
if ( ref( $package ) ) {
|
|
foreach my $attr ( FIELDS ) {
|
|
$self->{$attr} = $package->{$attr};
|
|
}
|
|
|
|
$slinfo = "$SL::sl->{'statdir'}/"
|
|
. "$package->{'name'}/slinfo";
|
|
}
|
|
elsif ( -f $package && SL->ispkg( $package ) ) {
|
|
my $sel = IO::Select->new();
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
my $pid;
|
|
|
|
eval { $pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $package slinfo" );
|
|
} || SL->error( int( $! ), "new(): open3(): $!" );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
$stdout .= <$fh>;
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat,
|
|
"Failed to read $package: $stderr" );
|
|
}
|
|
|
|
foreach ( split( /\n/, $stdout ) ) {
|
|
if ( $_ =~ /^(\S+):\s*(.*)$/ ) {
|
|
$self->{$1} = $2;
|
|
}
|
|
}
|
|
|
|
$self->{'source'} = 'localhost';
|
|
$self->{'path'} = abs_path( $package );
|
|
|
|
$slinfo = "$SL::sl->{'statdir'}/$self->{'name'}/slinfo";
|
|
}
|
|
elsif ( -f $slinfo ) {
|
|
open( my $fh, "<$slinfo" ) ||
|
|
SL->error( int( $! ), "open(): $slinfo: $!" );
|
|
|
|
while( <$fh> ) {
|
|
if ( $_ = /^(\S+):\s+(.*)$/ ) {
|
|
$self->{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( $fh ) || SL->error( int( $! ),
|
|
"close(): $slinfo: $!" );
|
|
|
|
if ( ! $self->{'status'} ) {
|
|
$self->{'status'} = STATS->{'INST'};
|
|
}
|
|
}
|
|
else {
|
|
SL->error( -2, "'$package': No such file or package found" );
|
|
}
|
|
|
|
if ( ! $self->{'srcpkg'} ) {
|
|
$self->{'srcpkg'} = $self->{'name'};
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# This is kind of a hack in that it could be done
|
|
# more cleanly in this sub. Good enough for now,
|
|
# but should be cleaned up in the future. Would be
|
|
# ideal to just have one bit that parses the
|
|
# slinfo file, but it'll take a little extra
|
|
# time to sort that out so we'll go with this!
|
|
#
|
|
# This sets the status of the package based on the
|
|
# slinfo file if one is found. If found, and the
|
|
# version matches the value of status will be
|
|
# pulled from the slinfo file. For now though
|
|
# we're also going to set it to installed if
|
|
# there is no status section in the slinfo file.
|
|
# In the future any slinfo file without a status
|
|
# should cause an error.
|
|
#
|
|
####################################################
|
|
|
|
if ( -f $slinfo ) {
|
|
my $installed = {};
|
|
|
|
open( my $fh, "<$slinfo" ) ||
|
|
SL->error( int( $! ), "open(): $slinfo: $!" );
|
|
|
|
while( <$fh> ) {
|
|
if ( $_ = /^(\S+):\s+(.*)$/ ) {
|
|
$installed->{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( $fh );
|
|
|
|
if ( ! $self->{'status'} && $self->{'version'} eq
|
|
$installed->{'version'} ) {
|
|
$self->{'status'} = $installed->{'status'} ||
|
|
STATS->{'INST'};
|
|
}
|
|
elsif ( ! $self->{'status'} ) {
|
|
$self->{'status'} = STATS->{'NINST'};
|
|
}
|
|
}
|
|
elsif ( ! $self->{'status'} ) {
|
|
$self->{'status'} = STATS->{'NINST'};
|
|
}
|
|
|
|
return( $self );
|
|
}
|
|
|
|
sub config {
|
|
my ( $self, $opts ) = @_;
|
|
my $pid;
|
|
my $sel;
|
|
my $stderr;
|
|
my $stat;
|
|
my $cnt = 0;
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar t $self->{'path'} config.tar.gz" );
|
|
};
|
|
|
|
if ( $stat = $? ) {
|
|
$self->setstat( 'FCONF' );
|
|
$self->writeinfo();
|
|
|
|
SL->error( $stat, "open3(): /usr/bin/ar: $!" );
|
|
}
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my $line = <$fh>;
|
|
chomp( $line );
|
|
|
|
if ( $line =~ /^config\.tar\.gz$/ ) {
|
|
$cnt++;
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
|
|
if ( $stderr =~ /^no entry config\.tar\.gz/ ) {
|
|
$cnt = 0;
|
|
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
$self->setstat( 'FCONF' );
|
|
$self->writeinfo();
|
|
|
|
SL->error( $stat, "config(): $self->{'name'}:"
|
|
. " $stderr\e[?25h" );
|
|
}
|
|
|
|
if ( ! $cnt ) {
|
|
return();
|
|
}
|
|
|
|
$cnt = 0;
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "\e[?25l\r";
|
|
}
|
|
|
|
eval {
|
|
my $target = $SL::sl->{'target'} || '/';
|
|
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $self->{'path'} config.tar.gz|"
|
|
. "tar --skip-old-files --keep-directory-symlink"
|
|
. " -hzvxf - -C $target" );
|
|
};
|
|
|
|
if ( $stat = $? ) {
|
|
$self->setstat( 'FCONF' );
|
|
$self->writeinfo();
|
|
|
|
SL->error( $stat, "open3(): /usr/bin/ar: $!" );
|
|
}
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my $line = <$fh>;
|
|
( my $file = $line ) =~ s/.*\/|\n$//;
|
|
chomp( $line );
|
|
chomp( $file );
|
|
|
|
if ( $file && ! $opts->{'dialog'} ) {
|
|
$cnt++;
|
|
|
|
print "\e[K$file\r";
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
my $line = <$fh>;
|
|
|
|
if ( $line =~ /skipping existing file/ ) {
|
|
$cnt--;
|
|
}
|
|
else {
|
|
$stderr .= $line;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
$self->setstat( 'FCONF' );
|
|
|
|
SL->error( $stat, "Failed config for $self->{'name'}:"
|
|
. " $stderr\e[?25h" );
|
|
}
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
if ( $cnt ) {
|
|
print "\e[K$cnt configuration files extracted\e[?25h\n";
|
|
}
|
|
else {
|
|
print "\e[K\e[?25h";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub conflicts {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $conflicts = {};
|
|
|
|
$self->files();
|
|
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
|
|
############################################
|
|
#
|
|
# We'll skip a check on an installed
|
|
# package with the same name since $self
|
|
# should be replacing it.
|
|
#
|
|
############################################
|
|
|
|
if ( $package->{'name'} eq $self->{'name'} ||
|
|
! $package->installed() ) {
|
|
next;
|
|
}
|
|
|
|
$package->files();
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
if ( exists( $package->{'files'}{$file} ) ) {
|
|
if ( ! $conflicts->{$package->{'name'}} ) {
|
|
$conflicts->{$package->{'name'}} = [];
|
|
}
|
|
|
|
push( @{$conflicts->{$package->{'name'}}},
|
|
$file );
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( keys( %$conflicts ) ) {
|
|
print STDERR "Package $self->{'name'} conflicts with the"
|
|
. " following packages:\n";
|
|
|
|
foreach my $pkgname ( sort { $a cmp $b } keys( %$conflicts ) ) {
|
|
print STDERR "\n[$pkgname]\n";
|
|
|
|
foreach my $file ( sort { $a cmp $b }
|
|
@{$conflicts->{$pkgname}} ) {
|
|
print " * $file\n";
|
|
}
|
|
}
|
|
|
|
SL->error( -1, "Exiting due to conflicts" );
|
|
}
|
|
}
|
|
|
|
### depends() ##############################################
|
|
#
|
|
# This should find all of the packages that $self depends
|
|
# on and add them the the $dependencies hashref. It also
|
|
# calls revdeps to make sure that any reverse dependencies
|
|
# get upgraded if they need to.
|
|
#
|
|
# Both depends() and revdeps() will probably require a bit
|
|
# more work. Combining them might be possible, or if
|
|
# anything they should be simplified.
|
|
#
|
|
############################################################
|
|
|
|
sub depends {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $dependencies = shift;
|
|
my $failures = shift;
|
|
my $selflist = shift;
|
|
|
|
if ( ! $failures ) {
|
|
$failures = [];
|
|
}
|
|
|
|
if ( ! $selflist ) {
|
|
$selflist = {};
|
|
}
|
|
|
|
if ( ! $selflist->{$self->{'name'}} ) {
|
|
$selflist->{$self->{'name'}} = $self;
|
|
}
|
|
else {
|
|
SL->error( -1, "$self->{'name'}=$self->{'version'}:"
|
|
. " Package $selflist->{$self->{'name'}}="
|
|
. "$selflist->{$self->{'name'}}{'version'}"
|
|
. " already slated for installation" );
|
|
}
|
|
|
|
if ( $self->{'depends'} ) {
|
|
foreach my $depend ( split( ',', $self->{'depends'} ) ) {
|
|
my ( $name, $req ) = split( /(((<|>)=?|=)(.*))/,
|
|
$depend );
|
|
my $package;
|
|
|
|
if ( $self->{'name'} eq $name ) {
|
|
SL->error( -1, "$self->{'name'}"
|
|
. "=$self->{'version'}:"
|
|
. " A package cannot be"
|
|
. " dependent on itself" );
|
|
}
|
|
|
|
if ( $selflist->{$name} && ( ! $req ||
|
|
SL->chkreq( $req,
|
|
$selflist->{$name}{'version'} ) ) ) {
|
|
next;
|
|
}
|
|
elsif ( $sources->{'status'}{$name} &&
|
|
$sources->{'status'}{$name}->installed() &&
|
|
( ! $req || SL->chkreq( $req,
|
|
$sources->{'status'}{$name}{'version'} ) ) ) {
|
|
next;
|
|
}
|
|
|
|
$package = ( $sources->search( {
|
|
name => $name,
|
|
version => $req
|
|
} ) )->[0];
|
|
|
|
if ( ! $package ) {
|
|
push( @$failures, "$depend" );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( ( grep { $_->{'name'} eq $package->{'name'} }
|
|
@$dependencies ) || $package->installed() ) {
|
|
next;
|
|
}
|
|
|
|
$package->depends( $sources, $dependencies,
|
|
$failures, $selflist );
|
|
|
|
####################################
|
|
#
|
|
# This flag just tells us if the
|
|
# package was installed as a
|
|
# dependency.
|
|
#
|
|
####################################
|
|
|
|
$package->{'status'} = 'installing dependency';
|
|
|
|
push( @$dependencies, $package );
|
|
}
|
|
}
|
|
|
|
if ( @$failures ) {
|
|
print STDERR "Failed to resolve dependencies\n";
|
|
|
|
SL->error( -1, "depends(): unresolved dependencies: "
|
|
. join( ",", @$failures ) );
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# We check reverse dependencies because they may
|
|
# need to be updated if they depend on any of the
|
|
# packages if they're being upgraded.
|
|
#
|
|
####################################################
|
|
|
|
$self->revdeps( $sources, $dependencies );
|
|
}
|
|
|
|
sub dump {
|
|
my( $self, $opts ) = @_;
|
|
my $pid;
|
|
my $sel;
|
|
my $cnt;
|
|
my $stderr;
|
|
my $stat;
|
|
local $| = 1;
|
|
|
|
print "Dumping $self->{'name'}-$self->{'version'}\n";
|
|
|
|
print "\e[?25l\r";
|
|
|
|
eval {
|
|
my $directory = $opts->{'directory'} ||
|
|
"$self->{'name'}-$self->{'version'}";
|
|
|
|
if ( ! -d $directory ) {
|
|
mkdir( $directory );
|
|
}
|
|
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $self->{'path'} files.tar.gz|"
|
|
. "tar --no-overwrite-dir --keep-directory-symlink"
|
|
. " -hzvxf - -C $directory" );
|
|
} || SL->error( int( $! ), "open3(): /usr/bin/ar: $!" );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my $line = <$fh>;
|
|
( my $file = $line ) =~ s/.*\/|\n$//;
|
|
chomp( $line );
|
|
chomp( $file );
|
|
|
|
if ( $file ) {
|
|
$cnt++;
|
|
|
|
print "\e[K$file\r";
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "Failed dumping $self->{'name'}:"
|
|
. " $stderr\e[?25h" );
|
|
}
|
|
|
|
print "\e[K$cnt files extracted\e[?25h\n";
|
|
}
|
|
|
|
### files() ################################################
|
|
#
|
|
# This sub will read a package manifest and add the list
|
|
# of files to $self->{'files'}. The files themselves are
|
|
# used as hash keys. The value of the $self->{'files'}
|
|
# hash are the 'sha' and 'perms' keys which contain the
|
|
# sha hash of the file and the permissions.
|
|
#
|
|
# By default it only adds files, but passing the argument
|
|
# { all => 1 } will cause directories to be added as well.
|
|
#
|
|
############################################################
|
|
|
|
sub files {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
my $manifestfile = "$SL::sl->{'statdir'}/$self->{'name'}/manifest";
|
|
|
|
if ( ref( $self->{'files'} ) eq 'HASH' &&
|
|
keys( %{$self->{'files'}} ) ) {
|
|
return;
|
|
}
|
|
|
|
$self->{'files'} = {};
|
|
|
|
if ( $self->{'path'} && -f $self->{'path'} ) {
|
|
my $sel = IO::Select->new();
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
my $pid;
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $self->{'path'} manifest" );
|
|
} || SL->error( int( $! ),
|
|
"open3(): /usr/bin/ar: $!" );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my ( $sha, $perms, $file ) =
|
|
split( /\s+/, <$fh> );
|
|
|
|
if ( ! $opts->{'all'} &&
|
|
$perms =~ /^d/ ) {
|
|
next;
|
|
}
|
|
|
|
$self->{'files'}{$file} = {
|
|
sha => $sha,
|
|
perms => $perms
|
|
};
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat || $stderr ) {
|
|
$stderr =~ s/.*: //;
|
|
|
|
if ( ! $stat ) {
|
|
$stat = -1;
|
|
}
|
|
|
|
SL->error( $stat, "Failed reading '$self->{'path'}':"
|
|
. " $stderr" );
|
|
}
|
|
}
|
|
elsif ( -f $manifestfile ) {
|
|
open( MANIFEST, "<$manifestfile" ) ||
|
|
SL->error( int( $! ), "open(): $manifestfile: $!" );
|
|
|
|
while ( <MANIFEST> ) {
|
|
my ( $sha, $perms, $file ) = split( /\s+/, $_ );
|
|
|
|
if ( ! $opts->{'all'} && $perms =~ /^d/ ) {
|
|
next;
|
|
}
|
|
|
|
$self->{'files'}{$file} = {
|
|
sha => $sha,
|
|
perms => $perms
|
|
};
|
|
}
|
|
|
|
close( MANIFEST ) ||
|
|
SL->error( int( $! ), "open(): $manifestfile: $!" );
|
|
}
|
|
}
|
|
|
|
### install() ##############################################
|
|
#
|
|
# The intention here is to only do what is needed to
|
|
# extract and install the package. This involves
|
|
# downloading the package (if needed), extracting the
|
|
# files, executing usher() preinst and postinst, as well
|
|
# as cleaning up old files from a package which is being
|
|
# upgraded or downgraded.
|
|
#
|
|
# It will NOT check for conflicts, so whatever calls this
|
|
# needs to check that itself.
|
|
#
|
|
############################################################
|
|
|
|
sub install {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $opts = shift;
|
|
my $pkgdir = "$SL::sl->{'statdir'}/$self->{'name'}";
|
|
my $slinfo = "$pkgdir/slinfo";
|
|
my $manifest = "$pkgdir/manifest";
|
|
my $displayname;
|
|
my $oldpkg;
|
|
my $pid;
|
|
my $sel;
|
|
my $cnt;
|
|
my $libcnt;
|
|
my $stderr;
|
|
my $stat;
|
|
my $filecnt = 0;
|
|
my $pct = 0;
|
|
local $| = 1;
|
|
|
|
if ( index( $self->{'name'}, $self->{'version'} ) != -1 ) {
|
|
$displayname = "$self->{'name'}";
|
|
}
|
|
else {
|
|
$displayname = "$self->{'name'}-$self->{'version'}";
|
|
}
|
|
|
|
if ( $opts->{'dialog'} ) {
|
|
$self->files();
|
|
|
|
$filecnt = int( keys( %{$self->{'files'}} ) );
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# This should attempt to get an exclusive lock on
|
|
# a temporary lock file. If it fails lock() will
|
|
# assume this means that a sl process is already
|
|
# running and die.
|
|
#
|
|
####################################################
|
|
|
|
SL->lock();
|
|
|
|
####################################################
|
|
#
|
|
# install() does not deal with downloading packages
|
|
# and it only installs packages that are present
|
|
# on the local filesystem. It first verifies that
|
|
# the package is present, and then also verifies
|
|
# the sha256 hash if present. If a file to be
|
|
# installed is not from a repo there will be
|
|
# no $self->{'sha256'} to check against.
|
|
#
|
|
####################################################
|
|
|
|
if ( ! -f $self->{'path'} ) {
|
|
SL->error( 1, "install(): $self->{'name'}: $self->{'path'}:"
|
|
. " No such file or directory" );
|
|
}
|
|
elsif ( $self->{'sha256'} && $self->{'sha256'} ne
|
|
SL->sha256( $self->{'path'} ) ) {
|
|
SL->error( 1, "install(): $self->{'name'}: sha256 for"
|
|
. " $self->{'path'} is invalid" );
|
|
}
|
|
|
|
if ( ! -d $pkgdir ) {
|
|
mkdir( $pkgdir, 0755 ) ||
|
|
SL->error( int( $! ), "mkdir(): $pkgdir: $!" );
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# If a different version of this package is
|
|
# installed we need to capture the file list from
|
|
# the old manifest file so that any files which are
|
|
# no longer a part of the package are cleaned up
|
|
# after installing the new version.
|
|
#
|
|
# We also move the old slinfo and manifest to
|
|
# temporary files which are cleaned up after the
|
|
# new package is successfully installed. Holding
|
|
# on to these things until after we're sure the
|
|
# install was successful is not a bad idea...
|
|
#
|
|
####################################################
|
|
|
|
if ( $sources->{'status'}{$self->{'name'}} &&
|
|
$sources->{'status'}{$self->{'name'}}->installed() ) {
|
|
$oldpkg = $sources->{'status'}{$self->{'name'}};
|
|
$oldpkg->files();
|
|
|
|
rename( $slinfo, "$slinfo.$oldpkg->{'version'}" ) ||
|
|
SL->error( int( $! ), "rename(): $slinfo: $!" );
|
|
rename( $manifest, "$manifest.$oldpkg->{'version'}" ) ||
|
|
SL->error( int( $! ), "rename(): $manifest: $!" );
|
|
}
|
|
|
|
open( AR, "ar p $self->{'path'} manifest|" ) ||
|
|
SL->error( int( $! ), "open(): $self->{'path'}: $!" );
|
|
sysopen( MANIFEST, $manifest, O_RDWR|O_TRUNC|O_CREAT, 0644 ) ||
|
|
SL->error( int( $! ), "sysopen(): $manifest: $!" );
|
|
|
|
while ( <AR> ) {
|
|
print MANIFEST $_;
|
|
}
|
|
|
|
close( MANIFEST ) || SL->error( int( $! ),
|
|
"sysopen(): $manifest: $!" );
|
|
close( AR ) || SL->error( int( $! ), "open(): $manifest: $!" );
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "Installing $displayname\n";
|
|
}
|
|
|
|
$self->usher( 'preinst', $sources, $opts );
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "\e[?25l\r";
|
|
}
|
|
|
|
eval {
|
|
my $target = $SL::sl->{'target'} || '/';
|
|
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $self->{'path'} files.tar.gz|"
|
|
. "tar --no-overwrite-dir --keep-directory-symlink"
|
|
. " -hzvxf - -C $target" );
|
|
};
|
|
|
|
if ( $? ) {
|
|
my $err = $!;
|
|
$self->setstat( 'FEXT' );
|
|
|
|
SL->error( int( $err ), "open3(): /usr/bin/ar: $err" );
|
|
}
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my $line = <$fh>;
|
|
( my $file = $line ) =~ s/.*\/|\n$//;
|
|
my $newpct;
|
|
chomp( $line );
|
|
chomp( $file );
|
|
|
|
if ( ! $file ) {
|
|
next;
|
|
}
|
|
|
|
############################
|
|
#
|
|
# Set trigger flag if info
|
|
# or lib files are found
|
|
#
|
|
############################
|
|
|
|
if ( $line =~ /usr\/share\/info\/.*info.*/ ) {
|
|
$SL::sl->{'installinfo'}++;
|
|
}
|
|
elsif ( $file =~ /^(lib|usr\/lib).*\.so\./ ) {
|
|
$SL::sl->{'ldconfig'}++;
|
|
}
|
|
elsif ( $file =~ /^\/hwdb\.d\/.*\.hwdb$/ ) {
|
|
$SL::sl->{'hwdb'}++;
|
|
}
|
|
|
|
$cnt++;
|
|
|
|
if ( $filecnt ) {
|
|
$newpct = int( $cnt / $filecnt * 100 );
|
|
}
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "\e[K$file\r";
|
|
}
|
|
elsif ( $pct != $newpct ) {
|
|
$pct = $newpct;
|
|
|
|
print "XXX\n$pct\n\nInstalling"
|
|
. " $displayname\nXXX\n";
|
|
}
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
$self->setstat( 'FEXT' );
|
|
$self->writeinfo();
|
|
|
|
SL->error( $stat, "Failed installing $self->{'name'}:"
|
|
. " $stderr\e[?25h" );
|
|
}
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
if ( $cnt ) {
|
|
print "\e[K$cnt files extracted\e[?25h\n";
|
|
}
|
|
else {
|
|
print "\e[K\e[?25h";
|
|
}
|
|
}
|
|
|
|
###########################################################
|
|
#
|
|
# Here we attempt to symlink any modules that are installed
|
|
# via package. The intention is for a particular snaplinux
|
|
# release to maintain the kernel ABI throughout the
|
|
# lifecycle so that modules installed via package will
|
|
# continue to work without requiring updates.
|
|
#
|
|
# After this we enable flags for mkinitramfs and
|
|
# grubmkconfig where appropriate.
|
|
#
|
|
###########################################################
|
|
|
|
if ( $self->iskern() || $self->ismodule() ) {
|
|
$self->linkmodules( $sources );
|
|
|
|
if ( ! $SL::sl->{'mkinitramfs'} ) {
|
|
$SL::sl->{'mkinitramfs'} = [];
|
|
}
|
|
|
|
if ( $self->iskern() ) {
|
|
$SL::sl->{'grubmkconfig'} = 1;
|
|
|
|
push( @{$SL::sl->{'mkinitramfs'}},
|
|
$self->{'version'} );
|
|
}
|
|
else {
|
|
push( @{$SL::sl->{'mkinitramfs'}}, 'all' );
|
|
}
|
|
}
|
|
|
|
$self->usher( 'postinst', $sources, $opts );
|
|
|
|
if ( $oldpkg ) {
|
|
foreach my $file ( keys( %{$oldpkg->{'files'}} ) ) {
|
|
if ( ! $self->{'files'}{$file} &&
|
|
-f $SL::sl->{'target'} . "/$file" ) {
|
|
unlink( $SL::sl->{'target'} . "/$file" ) ||
|
|
SL->error( int( $? ), "unlink(): "
|
|
. $SL::sl->{'target'}
|
|
. "/$file: $!\e[?25h" );
|
|
}
|
|
}
|
|
|
|
if ( -f "$slinfo.$oldpkg->{'version'}" ) {
|
|
unlink( "$slinfo.$oldpkg->{'version'}" ) ||
|
|
SL->error( int( $! ),
|
|
"unlink(): $slinfo: $!" );
|
|
}
|
|
|
|
if ( -f "$manifest.$oldpkg->{'version'}" ) {
|
|
unlink( "$manifest.$oldpkg->{'version'}" ) ||
|
|
SL->error( int( $! ),
|
|
"unlink(): $manifest: $!" );
|
|
}
|
|
}
|
|
|
|
$self->config( $opts );
|
|
|
|
SL->unlock();
|
|
|
|
if ( $self->{'status'} eq 'installing dependency' ) {
|
|
$self->setstat( 'INSTD' );
|
|
}
|
|
else {
|
|
$self->setstat( 'INST' );
|
|
}
|
|
|
|
$self->writeinfo();
|
|
|
|
$sources->{'status'}{$self->{'name'}} = $self;
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "Finished installing $self->{'name'}\n";
|
|
}
|
|
}
|
|
|
|
### installed() ############################################
|
|
#
|
|
# This will return 1 if $self is an installed package. It
|
|
# will otherwise return null. It will accept a string as
|
|
# the package name or a package object.
|
|
#
|
|
# When checking with the string rather than the object it
|
|
# will only verify that a package with that name is
|
|
# installed. If it is a package object then the version
|
|
# will also be verified.
|
|
#
|
|
# If the second argument is a hash reference with the
|
|
# key/value of skipread => 1 (or anything resolving to true)
|
|
# then this sub will not attempt to read the slinfo file.
|
|
#
|
|
############################################################
|
|
|
|
sub installed {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
my $data = {};
|
|
my $slinfo;
|
|
|
|
if ( ! ref( $self ) ) {
|
|
$slinfo = "$SL::sl->{'statdir'}/$self/slinfo";
|
|
}
|
|
else {
|
|
$slinfo = "$SL::sl->{'statdir'}/$self->{'name'}/slinfo";
|
|
}
|
|
|
|
if ( ! -f $slinfo ) {
|
|
return();
|
|
}
|
|
|
|
if ( ! $opts->{'skipread'} ) {
|
|
open( my $fh, "<$slinfo" ) ||
|
|
SL->error( int( $! ), "open: $!" );
|
|
|
|
while ( <$fh> ) {
|
|
if ( $_ =~ /^(\S+)\s*:\s*(.*)$/ ) {
|
|
$data->{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( $fh ) || SL->error( int( $! ), "open: $!" );
|
|
|
|
if ( ! ref( $self ) ) {
|
|
$self = SL::Package->new( $data );
|
|
}
|
|
else {
|
|
$self->{'status'} = $data->{'status'};
|
|
}
|
|
}
|
|
|
|
if ( $self->{'status'} && substr( $self->{'status'}, 0, 1 ) eq 'I' &&
|
|
$self->{'version'} eq $data->{'version'} ) {
|
|
return( 1 );
|
|
}
|
|
|
|
return();
|
|
}
|
|
|
|
############################################################
|
|
#
|
|
# This determines if the package is a kernel package and
|
|
# sets $self->{'iskern'} to 1. This allows sl to treat
|
|
# kernel packages in a special way - specifically allowing
|
|
# sl to symlink any compatible kernel modules so that
|
|
# this new kernel can use them.
|
|
#
|
|
############################################################
|
|
|
|
sub iskern {
|
|
my $self = shift;
|
|
|
|
if ( $self->{'iskern'} ) {
|
|
return( 1 );
|
|
}
|
|
|
|
$self->files();
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
if ( substr( $file, 0, 13 ) eq 'boot/vmlinuz-' ) {
|
|
$self->{'iskern'} = 1;
|
|
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
return();
|
|
}
|
|
|
|
############################################################
|
|
#
|
|
# This determines if the package is a module package and
|
|
# sets $self->{'ismodule'} to 1. This allows sl to treat
|
|
# modules in a special way - modules installed via package
|
|
# should be placed in /lib/modules/PKGNAME and sl will
|
|
# symlink to the files in the directories of all compatible
|
|
# kernels.
|
|
#
|
|
############################################################
|
|
|
|
sub ismodule {
|
|
my $self = shift;
|
|
|
|
if ( $self->{'ismodule'} ) {
|
|
return( 1 );
|
|
}
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
if ( $file =~ /^lib\/modules\/$self->{'name'}\/.*\.ko$/ ) {
|
|
$self->{'ismodule'} = 1;
|
|
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
return();
|
|
}
|
|
|
|
############################################################
|
|
#
|
|
# This is the bit that does the module symlinking in the
|
|
# kernel module directories. This is only done with kernels
|
|
# and modules that are installed via packages.
|
|
#
|
|
############################################################
|
|
|
|
sub linkmodules {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $modules = [];
|
|
my $kernels = [];
|
|
my $badsymvers = [];
|
|
my $missingsym = [];
|
|
|
|
if ( $self->iskern() ) {
|
|
|
|
############################################
|
|
#
|
|
# If the package is a kernel we will need
|
|
# to iterate through all packages that
|
|
# provide kernel modules and link all .ko
|
|
# files in the module tree for this version.
|
|
#
|
|
############################################
|
|
|
|
push( @$kernels, $self );
|
|
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
|
|
if ( $package->installed() && $package->ismodule() ) {
|
|
foreach my $file (
|
|
keys( %{$package->{'files'}} ) ) {
|
|
if ( $file =~ /^lib\/modules.*\.ko$/ ) {
|
|
push( @$modules, $file );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
elsif ( $self->ismodule() ) {
|
|
|
|
############################################
|
|
#
|
|
# If the package is a module we will only
|
|
# symlink the .ko files from this package.
|
|
#
|
|
############################################
|
|
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
|
|
if ( $package->installed() && $package->iskern() ) {
|
|
push( @$kernels, $package );
|
|
}
|
|
}
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
if ( $file =~ /^lib\/modules.*\.ko$/ ) {
|
|
push( @$modules, $file );
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach my $kernel ( @$kernels ) {
|
|
my $moddir = $SL::sl->{'statdir'}
|
|
. "/lib/modules/$kernel->{'version'}/sl";
|
|
my $pid;
|
|
my $sel;
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
|
|
if ( @$modules && ! -d $moddir ) {
|
|
mkdir( $moddir, 0755 ) || SL->error( int( $! ),
|
|
"linkmodules(): $!" );
|
|
}
|
|
|
|
foreach my $module ( @$modules ) {
|
|
( my $filename = $module ) =~ s/.*\///;
|
|
|
|
if ( -l "$moddir/$filename" ) {
|
|
unlink( "$moddir/$filename" );
|
|
}
|
|
|
|
symlink( "/$module", "$moddir/$filename" ) ||
|
|
SL->error( int( $! ), "symlink(): $!" );
|
|
}
|
|
|
|
print "Runnning depmod for linux-$kernel->{'version'}\n";
|
|
|
|
eval {
|
|
my $basedir = $SL::sl->{'target'} || '/';
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/sbin/depmod -b $basedir -aeE "
|
|
. $SL::sl->{'target'} . "/lib/modules/"
|
|
. "$kernel->{'version'}/Module.symvers"
|
|
. " -e $kernel->{'version'}" );
|
|
} || SL->error( int( $! ), "open3():"
|
|
. " /sbin/depmod: $!" );
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
$stdout .= <$fh>;
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
close( USHER );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "depmod failed for kernel"
|
|
. " $kernel->{'version'}: $stderr" );
|
|
}
|
|
|
|
if ( $stderr ) {
|
|
foreach my $line ( split( /\n/, $stderr ) ) {
|
|
my $modfile;
|
|
my $modname;
|
|
my $msg;
|
|
|
|
if ( $line =~
|
|
/^depmod: WARNING: (\/(.*)\.ko) (.*)/ ) {
|
|
$modfile = $1;
|
|
$modname = $2;
|
|
$msg = $3;
|
|
}
|
|
else {
|
|
next;
|
|
}
|
|
|
|
if ( ! -l $modfile ) {
|
|
next;
|
|
}
|
|
elsif ( $msg =~ /disagrees about version/ ) {
|
|
push( @$badsymvers, $modname );
|
|
}
|
|
elsif ( $msg =~ /needs unknown symbol/ ) {
|
|
push( @$missingsym, $modname );
|
|
}
|
|
|
|
unlink( $1 ) || SL->error( int( $! ),
|
|
"unlink(): $!" );
|
|
}
|
|
}
|
|
|
|
if ( @$badsymvers ) {
|
|
SL->error( 0, "Incorrect symbol version for the"
|
|
. " following modules with kernel"
|
|
. " $kernel->{'version'}: "
|
|
. join( ' ', @$badsymvers ) );
|
|
}
|
|
if ( @$missingsym ) {
|
|
SL->error( 0, "Missing symbols for the following"
|
|
. " modules with kernel $kernel->{'version'}: "
|
|
. join( ' ', @$badsymvers ) );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub printbrief {
|
|
my $self = shift;
|
|
|
|
if ( -t STDOUT ) {
|
|
printf( '%-1.1s ', $self->{'status'} || '' );
|
|
printf( '%-16.16s ', $self->{'name'} );
|
|
printf( '%-10.10s ', $self->{'version'} );
|
|
printf( '%.50s', $self->{'brief'} || $self->{'description'} );
|
|
}
|
|
else {
|
|
printf( '%-1.1s ', $self->{'status'} || '' );
|
|
printf( '%-30.30s', $self->{'name'} );
|
|
printf( '%-20.20s', $self->{'version'} );
|
|
print $self->{'brief'} || $self->{'description'};
|
|
}
|
|
|
|
print "\n";
|
|
}
|
|
|
|
sub printself {
|
|
my $self = shift;
|
|
|
|
foreach my $field ( FIELDS ) {
|
|
if ( $self->{$field} ) {
|
|
print "$field: $self->{$field}\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
sub purge {
|
|
my $self = shift;
|
|
my $slinfo = "$SL::sl->{'statdir'}/$self->{'name'}/slinfo";
|
|
my $usher = "$SL::sl->{'statdir'}/$self->{'name'}/usher";
|
|
|
|
$self->usher( 'purge' );
|
|
|
|
if ( -f $slinfo ) {
|
|
unlink( $slinfo ) || SL->error( int( $! ), "unlink():"
|
|
. " $slinfo: $!" );
|
|
}
|
|
if ( -f $usher ) {
|
|
unlink( $usher ) || SL->error( int( $! ), "unlink():"
|
|
. " $usher: $!" );
|
|
}
|
|
if ( -d "$SL::sl->{'statdir'}/$self->{'name'}" ) {
|
|
rmdir( "$SL::sl->{'statdir'}/$self->{'name'}" );
|
|
}
|
|
}
|
|
|
|
sub remove {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $slbase = '';
|
|
my $pkgdir = "$SL::sl->{'statdir'}/$self->{'name'}";
|
|
my $slinfo = "$pkgdir/slinfo";
|
|
my $manifest = "$pkgdir/manifest";
|
|
my $usher = "$pkgdir/usher";
|
|
my $cnt = 0;
|
|
|
|
SL->lock();
|
|
|
|
$self->files( { all => 1 } );
|
|
|
|
####################################################
|
|
#
|
|
# Here we're putting the sl-base package object
|
|
# into $slbase if present. This will be used to
|
|
# make sure we don't unlink any directories that
|
|
# are part of sl-base.
|
|
#
|
|
####################################################
|
|
|
|
if ( $sources->{'status'}{'sl-base'} &&
|
|
$sources->{'status'}{'sl-base'}->installed() ) {
|
|
$slbase = $sources->{'status'}{'sl-base'};
|
|
$slbase->files( { all => 1 } );
|
|
}
|
|
|
|
if ( index( $self->{'name'}, $self->{'version'} ) != -1 ) {
|
|
print "Removing $self->{'name'}\n";
|
|
}
|
|
else {
|
|
print "Removing $self->{'name'}-$self->{'version'}\n";
|
|
}
|
|
|
|
$self->usher( 'prerm' );
|
|
|
|
print "\e[?25l\r";
|
|
|
|
####################################################
|
|
#
|
|
# This sort is used to order the files from the
|
|
# deepest parts of the directory tree to the most
|
|
# shallow. This makes it easy to be sure we've
|
|
# deleted all the files in a directory before
|
|
# attempting to delete that directory.
|
|
#
|
|
# Of course, we also test that the directory is in
|
|
# fact empty first before deleting it. We also skip
|
|
# over any directories that are part of sl-base.
|
|
#
|
|
####################################################
|
|
|
|
foreach my $file ( sort { ( $b =~ tr/\/// ) <=>
|
|
( $a =~ tr/\/// ) }( keys( %{$self->{'files'}} ) ) ) {
|
|
( my $filename = $file ) =~ s/.*\///;
|
|
my $fullpath = "$SL::sl->{'target'}/$file";
|
|
|
|
if ( $slbase && $slbase->{'files'}{$file} ) {
|
|
next;
|
|
}
|
|
elsif ( ! -l $fullpath && -d $fullpath &&
|
|
SL->dirempty( $fullpath ) ) {
|
|
rmdir( $fullpath ) || SL->error( int( $! ),
|
|
"rmdir(): $fullpath: $!" );
|
|
}
|
|
elsif ( ! -d $fullpath && -e $fullpath ) {
|
|
unlink( $fullpath ) || SL->error( int( $! ),
|
|
"unlink(): $fullpath: $!" );
|
|
}
|
|
else {
|
|
next;
|
|
}
|
|
|
|
print "\e[K$filename\r";
|
|
|
|
$cnt++;
|
|
}
|
|
|
|
print "\e[K$cnt files removed\e[?25h\n";
|
|
|
|
####################################################
|
|
#
|
|
# This will allow us to unlink modules when either
|
|
# a module or kernel is removed.
|
|
#
|
|
####################################################
|
|
|
|
if ( $self->iskern() || $self->ismodule() ) {
|
|
foreach my $pkgname ( sort {
|
|
$sources->{'status'}{$a}{'name'} cmp
|
|
$sources->{'status'}{$b}{'name'} }
|
|
keys( %{$sources->{'status'}} ) ) {
|
|
$sources->{'status'}{$pkgname}->files(
|
|
{ quiet => 1 } );
|
|
}
|
|
|
|
$self->unlinkmodules( $sources );
|
|
}
|
|
|
|
$self->usher( 'postrm' );
|
|
|
|
if ( -f $manifest ) {
|
|
unlink( $manifest ) || SL->error( int( $! ), "unlink():"
|
|
. " $manifest: $!" );
|
|
}
|
|
|
|
$self->setstat( 'RM' );
|
|
|
|
####################################################
|
|
#
|
|
# This will update the package in the 'status' list
|
|
#
|
|
####################################################
|
|
|
|
$sources->{'status'}{$self->{'name'}} = $self;
|
|
|
|
SL->unlock();
|
|
|
|
print "Finished removing $self->{'name'}\n";
|
|
}
|
|
|
|
### revdeps() ##############################################
|
|
#
|
|
# This sub looks through all installed packages to
|
|
# discover any which may depend on $self. This is intended
|
|
# to be used for the following scenerios:
|
|
#
|
|
# * package upgrades/downgrades
|
|
# * package removal
|
|
#
|
|
# Packages which depend on $self may need to be upgraded
|
|
# if $self is upgraded. In the case that $self is being
|
|
# removed the recursive reverse dependencies need to be
|
|
# calculated so that all installed packages which depend
|
|
# on $self can be slated for removal.
|
|
#
|
|
# Regarding $opts->{'noreq'} - this tells us that it is
|
|
# unnecessary to attempt to verify that the package which
|
|
# depends on $self is satisfied with the version of $self.
|
|
# This is used in cases where we assume that the installed
|
|
# $self and its dependent package are compatible since
|
|
# the version should have been tested when they were
|
|
# initially installed.
|
|
#
|
|
# If we're doing an upgrade of $self we would want to check
|
|
# to see if any packages that depend on $self would need to
|
|
# be updated as well, so 'noreq' is not used in those cases.
|
|
#
|
|
############################################################
|
|
|
|
sub revdeps {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $revdeps = shift || [];
|
|
my $opts = shift;
|
|
|
|
####################################################
|
|
#
|
|
# Here we begin to iterate through all installed
|
|
# packages and check if they depend on $self.
|
|
#
|
|
####################################################
|
|
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
my $chgver = 0;
|
|
|
|
if ( ! $package->installed() || $self->{'name'} eq $pkgname ) {
|
|
next;
|
|
}
|
|
|
|
foreach my $depend ( split( /,/, $package->{'depends'} ) ) {
|
|
my ( $name, $req ) = split( /(((<|>)=?|=)(.*))/,
|
|
$depend );
|
|
|
|
if ( $self->{'name'} ne $name ) {
|
|
next;
|
|
}
|
|
elsif ( $opts->{'noreq'} && ! grep( $_->{'name'} eq
|
|
$package->{'name'}, @$revdeps ) ) {
|
|
push( @$revdeps, $package );
|
|
$package->revdeps( $sources, $revdeps, $opts );
|
|
|
|
last;
|
|
}
|
|
elsif ( ! $req || grep( $_->{'name'} eq
|
|
$package->{'name'}, @$revdeps ) ||
|
|
SL->chkreq( $req, $self->{'version'} ) ) {
|
|
last;
|
|
}
|
|
|
|
$chgver++;
|
|
|
|
last;
|
|
}
|
|
|
|
if ( ! $chgver ) {
|
|
next;
|
|
}
|
|
|
|
foreach my $newpkg ( sort { SL->vercmp( $a->{'version'},
|
|
$b->{'version'} ) } @{$sources->{'pkgs'}{$pkgname}} ) {
|
|
foreach my $depend ( split( /,/,
|
|
$newpkg->{'depends'} ) ) {
|
|
my ( $name, $req ) = split( /(((<|>)=?|=)(.*))/,
|
|
$depend );
|
|
|
|
if ( $self->{'name'} ne $name ) {
|
|
next;
|
|
}
|
|
elsif ( ! $req || SL->chkreq( $req,
|
|
$self->{'version'} ) ) {
|
|
$chgver = 0;
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( ! $chgver ) {
|
|
push( @$revdeps, $newpkg );
|
|
$newpkg->depends( $sources, $revdeps );
|
|
$newpkg->revdeps( $sources, $revdeps );
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
if ( $chgver ) {
|
|
SL->error( -1, "revdep(): Unable to find a version"
|
|
. " of $pkgname that is satisfied with"
|
|
. " $self->{'name'}=$self->{'version'}\n" );
|
|
}
|
|
}
|
|
|
|
if ( @$revdeps ) {
|
|
return( 1 );
|
|
}
|
|
|
|
return();
|
|
}
|
|
|
|
sub setstat {
|
|
my $self = shift;
|
|
my $stat = shift;
|
|
my $slinfo = "$SL::sl->{'statdir'}/$self->{'name'}/slinfo";
|
|
|
|
if ( STATS->{$stat} ) {
|
|
$self->{'status'} = &STATS->{$stat};
|
|
}
|
|
else {
|
|
SL->error( -1, "setstat(): $stat: invalid status" );
|
|
}
|
|
|
|
$self->writeinfo();
|
|
}
|
|
|
|
############################################################
|
|
#
|
|
# Might want to modify this... it doesn't currently work
|
|
# because the first shift gives you the class due to the
|
|
# fact that it must be called while specifying the namespace
|
|
#
|
|
# It has been modded on the central server only for now...
|
|
#
|
|
############################################################
|
|
|
|
sub sha256 {
|
|
my $pkgfile = shift;
|
|
my $digest = eval {
|
|
Digest::SHA->new( 256 )->addfile( $pkgfile );
|
|
} || SL->error( int( $! ), "sha256(): $pkgfile: $!" );
|
|
|
|
return( $digest->hexdigest );
|
|
}
|
|
|
|
sub source {
|
|
my $self = shift;
|
|
my $git = '/usr/bin/git';
|
|
my $gitcmd = "git clone https://git.snaplinux.org"
|
|
. "/main/$self->{'srcpkg'}.git";
|
|
my $stat;
|
|
my $pid;
|
|
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
exec( $gitcmd );
|
|
|
|
exit( 2 );
|
|
}
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "Failed to clone $self->{'srcpkg'}" );
|
|
}
|
|
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
chdir( $self->{'srcpkg'} );
|
|
exec( "git checkout v$self->{'version'}" );
|
|
|
|
exit( 2 );
|
|
}
|
|
}
|
|
|
|
sub unlinkmodules {
|
|
my $self = shift;
|
|
my $sources = shift;
|
|
my $modules = [];
|
|
my $kernels = [];
|
|
|
|
if ( $self->iskern() ) {
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
|
|
if ( $package->installed() && $package->ismodule() ) {
|
|
foreach my $file (
|
|
keys( %{$package->{'files'}} ) ) {
|
|
if ( $file =~ /^lib\/modules.*\.ko$/ ) {
|
|
push( @$modules, $file );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
elsif ( $self->ismodule() ) {
|
|
foreach my $pkgname ( keys( %{$sources->{'status'}} ) ) {
|
|
my $package = $sources->{'status'}{$pkgname};
|
|
|
|
if ( $package->installed() && $package->iskern() ) {
|
|
push( @$kernels, $package );
|
|
}
|
|
}
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
if ( $file =~ /^lib\/modules.*\.ko$/ ) {
|
|
push( @$modules, $file );
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach my $kernel ( @$kernels ) {
|
|
my $moddir = $SL::sl->{'statdir'}
|
|
. "/lib/modules/$kernel->{'version'}/snap";
|
|
|
|
foreach my $module ( @$modules ) {
|
|
( my $filename = $module ) =~ s/.*\///;
|
|
|
|
if ( -l "$moddir/$filename" ) {
|
|
unlink( "$moddir/$filename" ) ||
|
|
SL->error( int( $! ),
|
|
"unlinkmodules(): $!" );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
### usher() ################################################
|
|
#
|
|
# The usher sub can be expected to return 1 if there is
|
|
# an error, or 0 or NULL for success.
|
|
#
|
|
# This is so that a failure in usher can be handled by
|
|
# install(), and appropriate values can be placed for the
|
|
# status in the slinfo file.
|
|
#
|
|
############################################################
|
|
|
|
sub usher {
|
|
my ( $self, $action, $sources, $opts ) = @_;
|
|
my $usher = "$SL::sl->{'statdir'}/$self->{'name'}/usher";
|
|
my $pid;
|
|
my $sel;
|
|
my $stderr;
|
|
my $stat;
|
|
|
|
####################################################
|
|
#
|
|
# Here we expose the package version as an
|
|
# environment variable for the usher script to use
|
|
#
|
|
####################################################
|
|
|
|
$ENV{'VERSION'} = $self->{'version'};
|
|
|
|
if ( $action eq 'preinst' ) {
|
|
my $cnt = 0;
|
|
my $ar = '/usr/bin/ar';
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"/usr/bin/ar p $self->{'path'} usher" );
|
|
};
|
|
|
|
if ( $? ) {
|
|
SL->error( 0, "open3(): /usr/bin/ar: $!" );
|
|
|
|
return( 1 );
|
|
}
|
|
|
|
close( CHLDIN );
|
|
|
|
$sel = IO::Select->new();
|
|
$sel->add( *CHLDOUT, *CHLDERR );
|
|
|
|
sysopen( USHER, $usher, O_RDWR|O_TRUNC|O_CREAT, 0755 );
|
|
|
|
if ( $? ) {
|
|
SL->error( 0, "sysopen(): $usher: $!" );
|
|
|
|
return( 1 );
|
|
}
|
|
|
|
while ( my @fhs = $sel->can_read ) {
|
|
foreach my $fh ( @fhs ) {
|
|
if ( eof( $fh ) ) {
|
|
$sel->remove( $fh );
|
|
|
|
next;
|
|
}
|
|
|
|
if ( fileno( $fh ) == fileno( *CHLDOUT ) ) {
|
|
my $line = <$fh>;
|
|
|
|
print USHER $line;
|
|
|
|
$cnt++;
|
|
}
|
|
elsif ( fileno( $fh ) == fileno( *CHLDERR ) ) {
|
|
$stderr .= <$fh>;
|
|
|
|
if ( $stderr =~ /^no entry usher/ ) {
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
close( CHLDOUT );
|
|
close( CHLDERR );
|
|
close( USHER );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "usher(): $self->{'name'}:"
|
|
. " $stderr\e[?25h" );
|
|
}
|
|
|
|
if ( ! $cnt && -f $usher ) {
|
|
unlink( $usher );
|
|
|
|
return;
|
|
}
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# The usher script is forked and execed as a child
|
|
# process. For most packages the process will be
|
|
# executed in a chroot environment if a target has
|
|
# been specified.
|
|
#
|
|
# The presence of coreutils should indicate an
|
|
# environment in which a chroot would be successful.
|
|
# We also check for bash or dash since usher
|
|
# should always be a shell script. This should be
|
|
# reduced to only checking for dash in the future
|
|
# since the intention is for all usher scripts
|
|
# to use /bin/sh which is expected to be dash.
|
|
#
|
|
# Certain packages (such as glibc) need to be able
|
|
# to execute usher without a chroot if a full
|
|
# environment is unavailable.
|
|
#
|
|
# For non-root users a fake chroot environment is
|
|
# created (if fakeroot and fakechroot is present).
|
|
#
|
|
# There is a bit of a hack here to undef TARGET
|
|
# so that usher scripts which still attempt to
|
|
# perform a chroot will not do so.
|
|
#
|
|
####################################################
|
|
|
|
if ( ! -f $usher ) {
|
|
return;
|
|
}
|
|
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
elsif ( ! $SL::sl->{'target'} ) {
|
|
if ( $opts->{'dialog'} ) {
|
|
open( STDOUT, '>/dev/null' );
|
|
open( STDERR, '>/dev/null' );
|
|
}
|
|
|
|
exec( "$usher $action" ) || exit( 1 );
|
|
}
|
|
elsif ( installed( 'coreutils', { nameonly => 1 } ) &&
|
|
installed( 'dash', { nameonly => 1 } ) &&
|
|
installed( 'glibc', { nameonly => 1 } ) ) {
|
|
my $cmd;
|
|
$usher = substr( $usher, length( $SL::sl->{'target'} ) );
|
|
undef( $ENV{'TARGET'} );
|
|
|
|
if ( $> ) {
|
|
my $fakeroot = '/usr/bin/fakeroot';
|
|
my $fakechroot = '/usr/bin/fakechroot';
|
|
|
|
if ( ! -x $fakeroot && ! -x $fakechroot ) {
|
|
SL->error( 1, "$fakeroot and $fakechroot"
|
|
. " not found" );
|
|
}
|
|
elsif ( ! -x $fakeroot ) {
|
|
SL->error( 1, "$fakeroot not found" );
|
|
}
|
|
elsif ( ! -x $fakechroot ) {
|
|
SL->error( 1, "$fakechroot not found" );
|
|
}
|
|
|
|
$ENV{'PATH'} = "$ENV{'PATH'}:/sbin:/usr/sbin";
|
|
$cmd = "$fakeroot $fakechroot /usr/sbin/chroot "
|
|
. $SL::sl->{'target'}
|
|
. " sh -c 'PATH=/bin:/sbin"
|
|
. ':/usr/bin:/usr/sbin'
|
|
. " $usher $action'";
|
|
}
|
|
else {
|
|
chroot( $SL::sl->{'target'} );
|
|
chdir( '/' );
|
|
$cmd = "$usher $action";
|
|
}
|
|
|
|
if ( $opts->{'dialog'} ) {
|
|
open( STDOUT, '>/dev/null' );
|
|
open( STDERR, '>/dev/null' );
|
|
}
|
|
|
|
exec( $cmd ) || exit( 1 );
|
|
}
|
|
else {
|
|
exit;
|
|
}
|
|
|
|
if ( $stat ) {
|
|
$self->setstat( 'F' . uc( $action ) );
|
|
|
|
SL->error( $stat, "usher(): Failed in $action" );
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
### verify() ###############################################
|
|
#
|
|
# This verifies the sha hash for all files in an installed
|
|
# package.
|
|
#
|
|
############################################################
|
|
|
|
sub verify {
|
|
my $self = shift;
|
|
my $opts = shift;
|
|
my $result = {
|
|
failed => [],
|
|
verified => []
|
|
};
|
|
|
|
$self->files( { all => 1 } );
|
|
|
|
foreach my $file ( keys( %{$self->{'files'}} ) ) {
|
|
my $fullpath = "$SL::sl->{'target'}/$file";
|
|
my $shasum = '';
|
|
|
|
if ( -f $fullpath ) {
|
|
$shasum = SL->sha( $fullpath );
|
|
}
|
|
|
|
if ( substr( $self->{'files'}{$file}{'perms'}, 0, 1 ) eq '-' &&
|
|
$self->{'files'}{$file}{'sha'} ne $shasum ) {
|
|
push( @{$result->{'failed'}}, $fullpath );
|
|
}
|
|
elsif ( $opts->{'verbose'} ) {
|
|
push( @{$result->{'verified'}}, $fullpath );
|
|
}
|
|
}
|
|
|
|
return( $result );
|
|
}
|
|
|
|
### writeinfo() ###########################################
|
|
#
|
|
# This will update the slinfo file of a package
|
|
# (/var/lib/sl/status/<PACKAGE NAME>/slinfo) with the
|
|
# key/values in $self, though only with those keys listed
|
|
# in the FIELDS array. We do drop the 'path' key since
|
|
# it doesn't make sense to hang onto that.
|
|
#
|
|
############################################################
|
|
|
|
sub writeinfo {
|
|
my $self = shift;
|
|
my $slinfo = "$SL::sl->{'statdir'}/$self->{'name'}/slinfo";
|
|
|
|
sysopen( SLINFO, $slinfo, O_RDWR|O_TRUNC|O_CREAT, 0644 ) ||
|
|
SL->error( int( $! ), "sysopen(): $slinfo: $!" );
|
|
|
|
foreach ( FIELDS ) {
|
|
if ( $_ eq 'path' ) {
|
|
next;
|
|
}
|
|
|
|
my $value = $self->{$_} || '';
|
|
|
|
print SLINFO "$_: $value\n";
|
|
}
|
|
|
|
close( SLINFO ) || SL->error( int( $! ),
|
|
"sysopen(): $slinfo: $!" );
|
|
}
|
|
|
|
1;
|