1389 lines
28 KiB
Perl
1389 lines
28 KiB
Perl
package SL;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use SL::Commands;
|
|
use SL::Package;
|
|
use SL::Sources;
|
|
|
|
use Fcntl qw( :flock );
|
|
use IPC::Open3;
|
|
use IO::Socket::INET;
|
|
use Digest::SHA qw( sha1_hex sha256_hex );
|
|
use POSIX;
|
|
|
|
use parent 'Exporter';
|
|
our @EXPORT = qw(
|
|
chkyes
|
|
error
|
|
genpkg
|
|
httpget
|
|
human
|
|
infodir
|
|
kernver
|
|
ldconfig
|
|
list
|
|
listfiles
|
|
pullarg
|
|
virtfs
|
|
readconf
|
|
setup
|
|
sha
|
|
sha256
|
|
target
|
|
templates
|
|
termsize
|
|
trigger
|
|
vercmp
|
|
writelog
|
|
$sl
|
|
);
|
|
|
|
our $VERSION = '0.15';
|
|
|
|
############################################################
|
|
#
|
|
# Remove full path from process name
|
|
#
|
|
############################################################
|
|
|
|
$0 =~ s/.*\///;
|
|
|
|
############################################################
|
|
#
|
|
# Make sure we bring back the cursor if we're killed as
|
|
# well as umount any virtual filesystems that may have
|
|
# been mounted in $sl->{'target'}.
|
|
#
|
|
############################################################
|
|
|
|
$SIG{INT} = sub{
|
|
if ( $SL::sl->{'target'} ) {
|
|
virtfs( 'umount' );
|
|
}
|
|
|
|
unlock();
|
|
|
|
print "\e[?25h\n";
|
|
|
|
exit( 1 );
|
|
};
|
|
|
|
our $sl = SL->new();
|
|
|
|
############################################################
|
|
#
|
|
# Export $sl->{'target'} to the environment for usher
|
|
#
|
|
# This may be removed, in fact it probably should be. The
|
|
# idea is that packages shouldn't have to care if they are
|
|
# installed in a target, but we may find that there are
|
|
# cases where it will have to know.
|
|
#
|
|
############################################################
|
|
|
|
$ENV{TARGET} = $sl->{'target'};
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $self = {
|
|
debug => SL->pullarg( {
|
|
long => '--debug'
|
|
} ),
|
|
target => SL->pullarg( {
|
|
short => '-t',
|
|
long => '--target',
|
|
arg2 => 1,
|
|
keepargs => 1
|
|
} ),
|
|
version => $VERSION
|
|
};
|
|
|
|
############################################################
|
|
#
|
|
# Create target if not present
|
|
#
|
|
############################################################
|
|
|
|
if ( $self->{'target'} && ! -d $self->{'target'} ) {
|
|
print "Creating target directory '$self->{'target'}'\n";
|
|
mkdirp( $self->{'target'} );
|
|
}
|
|
|
|
####################################################
|
|
#
|
|
# Here we determine what sl.conf we'll use. If
|
|
# a target is used we will attempt to use the
|
|
# sl.conf that is present in the target.
|
|
#
|
|
####################################################
|
|
|
|
if ( $self->{'target'} && -f "$self->{'target'}/etc/sl.conf" ) {
|
|
$self->{'conffile'} = "$self->{'target'}/etc/sl.conf";
|
|
}
|
|
elsif ( -f '/etc/sl.conf' ) {
|
|
$self->{'conffile'} = '/etc/sl.conf';
|
|
}
|
|
else {
|
|
SL->error( 1, "Missing sl.conf" );
|
|
}
|
|
|
|
if ( $self->{'target'} && -f "$self->{'target'}/etc/sl_version" ) {
|
|
$self->{'verfile'} = "$self->{'target'}/etc/sl_version";
|
|
}
|
|
elsif ( -f '/etc/sl_version' ) {
|
|
$self->{'verfile'} = '/etc/sl_version';
|
|
}
|
|
else {
|
|
SL->error( 1, "Missing sl_version" );
|
|
}
|
|
|
|
$self->{'sldir'} = "$self->{'target'}/var/lib/sl";
|
|
$self->{'lockfile'} = "$self->{'target'}/.sl";
|
|
$self->{'pkgdir'} = "$self->{'sldir'}/packages";
|
|
$self->{'statdir'} = "$self->{'sldir'}/status";
|
|
$self->{'srcdir'} = "$self->{'sldir'}/sources";
|
|
|
|
open( my $fh, "<$self->{'verfile'}" ) ||
|
|
SL->error( int( $1 ), "open(): $!" );
|
|
$self->{'slver'} = <$fh>;
|
|
close( $fh );
|
|
chomp( $self->{'slver'} );
|
|
|
|
return( bless( $self, $class ) );
|
|
}
|
|
|
|
sub chkreq {
|
|
my $class = shift;
|
|
my $req = shift;
|
|
my $version = shift;
|
|
|
|
if ( $req eq $version ) {
|
|
return( 1 );
|
|
}
|
|
elsif ( $req && $req =~ /^((<|>)=?|=)\s*(.*)/ ) {
|
|
my $op = $1;
|
|
my $ver = $3;
|
|
my $chk = SL->vercmp( $version, $ver );
|
|
|
|
if ( $op &&
|
|
( $op eq '<' && $chk == -1 ) ||
|
|
( $op eq '<=' && $chk <= 0 ) ||
|
|
( $op eq '>' && $chk == 1 ) ||
|
|
( $op eq '>=' && $chk >= 0 ) ||
|
|
( $op eq '=' && $chk == 0 ) ) {
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
return( 0 );
|
|
}
|
|
|
|
sub chkyes {
|
|
my $yes = '';
|
|
|
|
while( ! $yes ){
|
|
$yes = <STDIN>;
|
|
chomp( $yes );
|
|
|
|
if ( lc( $yes ) eq 'n' ){
|
|
print STDERR "\nAborting!\n";
|
|
|
|
exit( 1 );
|
|
}
|
|
elsif ( lc( $yes ne 'y' ) ){
|
|
print "Answer 'y' or 'n': ";
|
|
|
|
undef( $yes );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub datetime{
|
|
my ( $sec, $min, $hour, $mday, $mon, $year ) = localtime( time );
|
|
my @months = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul',
|
|
'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
|
|
my $datetime = sprintf( '%s %2s %02d:%02d:%02d',
|
|
$months[$mon], $mday, $hour, $min, $sec );
|
|
|
|
return $datetime;
|
|
}
|
|
|
|
### dirempty() #############################################
|
|
#
|
|
# A simple test for an empty directory. The default $empty
|
|
# is 1 (meaning there are no files in the directory), and
|
|
# $empty is set to 0 if any files are found.
|
|
#
|
|
############################################################
|
|
|
|
sub dirempty {
|
|
my $class = shift;
|
|
my $dir = shift;
|
|
my $empty = 1;
|
|
|
|
if ( ! -d $dir ) {
|
|
SL->error( 1, "dirempty(): $dir: Invalid directory" );
|
|
}
|
|
|
|
opendir( my $dh, $dir ) || SL->error( int( $! ), "dirempty(): $!" );
|
|
|
|
while ( readdir( $dh ) ) {
|
|
if ( $_ ne '.' && $_ ne '..' ) {
|
|
$empty = 0;
|
|
|
|
last;
|
|
}
|
|
}
|
|
|
|
return( $empty );
|
|
}
|
|
|
|
### error() ################################################
|
|
#
|
|
# All errors should be sent here. This sub takes a status
|
|
# and error string as args. The status code is used as
|
|
# the exit code. This also iterates through the call stack
|
|
# which is dumped to STDERR
|
|
#
|
|
############################################################
|
|
|
|
sub error {
|
|
my $class = shift;
|
|
my $status = shift;
|
|
my $errstr = shift;
|
|
my $level = 1;
|
|
my @stack = ();
|
|
|
|
writelog( $errstr );
|
|
print "\e[?25h";
|
|
|
|
if ( $errstr ) {
|
|
chomp( $errstr );
|
|
|
|
print STDERR ( caller() )[1] .":\n $errstr at line "
|
|
. ( caller() )[2] . "\n";
|
|
|
|
if ( $sl->{'debug'} ) {
|
|
if ( caller( $level ) ) {
|
|
print "\n=== Stack Trace ===\n";
|
|
}
|
|
|
|
while ( my @trace = caller( $level++ ) ) {
|
|
print STDERR " $trace[1]:\n"
|
|
. " $trace[3]() called at"
|
|
. " line $trace[2]\n";
|
|
}
|
|
}
|
|
|
|
if ( $status ) {
|
|
print "\n";
|
|
}
|
|
}
|
|
|
|
if ( $status ) {
|
|
virtfs( 'umount' );
|
|
|
|
exit( $status );
|
|
}
|
|
}
|
|
|
|
### genpkg () ##############################################
|
|
#
|
|
# This sub generates a skeleton of directories and files
|
|
# that can be used as a starting point for creating a
|
|
# package.
|
|
#
|
|
############################################################
|
|
|
|
sub genpkg {
|
|
my $pkgname = shift || SL->error( 1, "genpkg(): pkgname missing" );
|
|
my $skelfile = '/usr/share/sl/Makefile.skel';
|
|
my $slreadme = "This is the directory where the manifest, slinfo,\n"
|
|
. "and files.tar.gz files will be created. It is also\n"
|
|
. "where the usher file should be placed if it is\n"
|
|
. "required by the package. Any other files that need\n"
|
|
. "to be included could also be placed here.\n";
|
|
my $patchreadme = "Place any patch files here and preface each with a\n"
|
|
. "number indicating the order of execution. Patch\n"
|
|
. "files are expected to use a .patch extension.\n";
|
|
|
|
mkdir( $pkgname, 0755 ) ||
|
|
SL->error( int( $! ), "mkdir: $pkgname: $!" );
|
|
mkdir( "$pkgname/SL", 0755 ) || SL->error( int( $! ), $! );
|
|
mkdir( "$pkgname/SRC", 0755 ) || SL->error( int( $! ), $! );
|
|
mkdir( "$pkgname/SRC/patches", 0755 ) || SL->error( int( $! ), $! );
|
|
|
|
open( SKEL, "<$skelfile" ) || SL->error( int( $! ), $! );
|
|
open( MAKEFILE, ">$pkgname/Makefile" ) || SL->error( int( $! ), $! );
|
|
|
|
while ( <SKEL> ) {
|
|
print MAKEFILE $_;
|
|
}
|
|
|
|
close( MAKEFILE );
|
|
close( SKEL );
|
|
|
|
open( README, ">$pkgname/SL/README" ) || SL->error( int( $! ), $! );
|
|
print README $slreadme;
|
|
close( README );
|
|
|
|
open( README, ">$pkgname/SRC/patches/README" )
|
|
|| SL->error( int( $! ), $! );
|
|
print README $patchreadme;
|
|
close( README );
|
|
}
|
|
|
|
sub grubmkconfig {
|
|
my $cmd = 'grub-mkconfig -o /boot/grub/grub.cfg';
|
|
my $stat;
|
|
my $pid;
|
|
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
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'
|
|
. " $cmd'";
|
|
}
|
|
else {
|
|
chroot( $SL::sl->{'target'} );
|
|
chdir( '/' );
|
|
}
|
|
|
|
exec( $cmd ) || exit( 1 );
|
|
}
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "Failed to run mkinitramfs" );
|
|
}
|
|
}
|
|
|
|
sub httpget {
|
|
my $class = shift;
|
|
my $url = shift;
|
|
my $dest = shift;
|
|
my $mode = shift;
|
|
my $opts = shift;
|
|
( my $host = $url ) =~ s/^https?:\/\/|\/.*//g;
|
|
( my $file = $url ) =~ s/.*$host//;
|
|
( my $filename = $url ) =~ s/.*\///;
|
|
my %httpget = (
|
|
'status' => 0,
|
|
'stdout' => '',
|
|
'stderr' => '',
|
|
'length' => 0,
|
|
'type' => '',
|
|
'dflag' => 0,
|
|
'pct' => 0
|
|
);
|
|
my $sock = IO::Socket::INET->new(
|
|
PeerAddr => $host,
|
|
PeerPort => 'http(80)',
|
|
Proto => 'tcp'
|
|
) || SL->error( int( $! ), "IO::Socket::Inet->new(): $!" );
|
|
my $bytes = 0;
|
|
my @wheel = qw( - \ | / );
|
|
my $p = 0;
|
|
|
|
local $| = 1;
|
|
|
|
$sock->send( "GET $file HTTP/1.0\r\n" );
|
|
$sock->send( "Host: $host\r\n" );
|
|
$sock->send( "\r\n" );
|
|
|
|
if ( ! $mode ) {
|
|
$mode = '0644';
|
|
}
|
|
|
|
if ( $dest ) {
|
|
sysopen( DEST, $dest, O_RDWR|O_TRUNC|O_CREAT, $mode ) ||
|
|
SL->error( int( $! ), "sysopen(): $dest: $!" );
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
print "\e[?25l";
|
|
}
|
|
}
|
|
|
|
while ( <$sock> ) {
|
|
if ( $dest ) {
|
|
$bytes += length( $_ );
|
|
}
|
|
|
|
if ( ! $httpget{'dflag'} ) {
|
|
if ( ! $httpget{'status'}
|
|
&& $_ =~ /^HTTP\S+\s(\d+)/ ) {
|
|
$httpget{'status'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'date'}
|
|
&& $_ =~ /^Date:\s+(.*)/ ) {
|
|
$httpget{'date'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'server'}
|
|
&& $_ =~ /^Server:\s+(.*)/ ) {
|
|
$httpget{'server'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'lastmod'}
|
|
&& $_ =~ /^Last-Modified:\s+(.*)/ ) {
|
|
$httpget{'lastmod'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'etag'}
|
|
&& $_ =~ /^ETag:\s+(.*)/ ) {
|
|
$httpget{'etag'} = $1;
|
|
}
|
|
elsif ( ! $httpget{'length'}
|
|
&& $_ =~ /Content-Length:\s+(\d+)/ ) {
|
|
$httpget{'length'} = $1;
|
|
|
|
}
|
|
elsif ( ! $httpget{'type'}
|
|
&& $_ =~ /Content-Type:\s+(\S+)/ ) {
|
|
$httpget{'type'} = $1;
|
|
}
|
|
elsif( $_ eq "\r\n" ) {
|
|
$httpget{'dflag'}++;
|
|
}
|
|
}
|
|
elsif ( $dest ) {
|
|
print DEST $_;
|
|
}
|
|
else {
|
|
$httpget{'stdout'} .= $_;
|
|
}
|
|
|
|
if ( $dest && $httpget{'length'} &&
|
|
$bytes < $httpget{'length'} ) {
|
|
if ( $bytes ) {
|
|
$httpget{'pct'} = int( $bytes /
|
|
$httpget{'length'} * 100 );
|
|
}
|
|
|
|
if ( ! $opts->{'dialog'} ) {
|
|
printf( "%-50.50s [%-20s] %s\r",
|
|
" $wheel[$p] Downloading $filename",
|
|
'*' x int( $httpget{'pct'} / 5 ),
|
|
"$httpget{'pct'}%" );
|
|
|
|
if ( $p >= $#wheel ) {
|
|
$p = 0;
|
|
}
|
|
else {
|
|
$p++;
|
|
}
|
|
}
|
|
elsif ( $bytes % 1024 == 0 ) {
|
|
print "XXX\n" . int( $httpget{'pct'} )
|
|
. "\n\nDownloading $filename\nXXX\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( $dest ) {
|
|
if ( ! $opts->{'dialog'} ) {
|
|
printf( "%-50.50s [%-20s] %s\e[?25h\n",
|
|
" * Downloaded $filename",
|
|
'*' x 20,
|
|
'100%' );
|
|
}
|
|
|
|
close( DEST );
|
|
}
|
|
|
|
close( $sock );
|
|
chomp( $httpget{'stdout'} );
|
|
|
|
return( $httpget{'stdout'} );
|
|
}
|
|
|
|
sub human {
|
|
my $B = shift;
|
|
my $human;
|
|
|
|
if ( $B > 1099511627776 ) {
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 4 ) ) . 'TB';
|
|
}
|
|
elsif ( $B > 1073741824 ) {
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 3 ) ) . 'GB';
|
|
}
|
|
elsif ( $B > 1048576 ) {
|
|
$human = sprintf( '%.02f', $B / ( 1024 ** 2 ) ) . 'MB';
|
|
}
|
|
else {
|
|
$human = sprintf( '%.02f', $B / 1024 ) . 'KB';
|
|
}
|
|
|
|
return( $human );
|
|
}
|
|
|
|
sub hwdb {
|
|
my $udevadm = '/sbin/udevadm';
|
|
my $cmd = "$udevadm hwdb --update";
|
|
my $pid;
|
|
my $stat;
|
|
|
|
if ( ! -x $udevadm ) {
|
|
return;
|
|
}
|
|
|
|
print "Executing $cmd\n";
|
|
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
if ( $sl->{'target'} ) {
|
|
exec( "$cmd -r $SL::sl->{'target'}" )
|
|
|| exit( 1 );
|
|
}
|
|
else {
|
|
exec( $cmd ) || exit( 1 );
|
|
}
|
|
}
|
|
|
|
if ( $stat ) {
|
|
SL->error( 0, "Failed executing $cmd" );
|
|
}
|
|
}
|
|
|
|
############################################################
|
|
#
|
|
# This just generates the dir directory file for info docs
|
|
#
|
|
############################################################
|
|
|
|
sub installinfo {
|
|
my $infodir = "$SL::sl->{'target'}/usr/share/info";
|
|
my $files = [];
|
|
my $cnt = 0;
|
|
|
|
print "Updating info directory entries\n";
|
|
|
|
print "\e[?25l\r";
|
|
|
|
open( my $fh, ">$infodir/dir" ) || SL->error( 0,
|
|
"installinfo(): $infodir/dir: $!" );
|
|
truncate( $fh, 0 );
|
|
close( $fh );
|
|
|
|
opendir( my $dh, $infodir ) || SL->error( 0, 'install-info failed' );
|
|
|
|
while ( my $file = readdir( $dh ) ) {
|
|
if ( -f "$infodir/$file" && $file =~ /.*info.*/ ) {
|
|
push( @$files, "$infodir/$file" );
|
|
}
|
|
}
|
|
|
|
closedir( $dh );
|
|
|
|
foreach my $file ( sort{ $a cmp $b }( @$files ) ) {
|
|
my $sel;
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
my $pid;
|
|
|
|
$cnt++;
|
|
|
|
print "\e[K$file\r";
|
|
|
|
$sel = IO::Select->new();
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"install-info $file $infodir/dir" );
|
|
} || SL->error( 0, 'install-info failed' );
|
|
|
|
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 ( $? ) {
|
|
SL->error( 0, "install-info: $file: $stderr" );
|
|
}
|
|
}
|
|
|
|
print "\e[K$cnt info files indexed\e[?25h\n";
|
|
}
|
|
|
|
sub ismountpoint {
|
|
my $dir = shift;
|
|
my $statA;
|
|
my $statB;
|
|
|
|
if ( ! -d $dir ) {
|
|
return( 0 );
|
|
}
|
|
|
|
$statA = ( stat( $dir ) )[0];
|
|
$statB = ( stat( "$dir/.." ) )[0];
|
|
|
|
if ( $statA == $statB ) {
|
|
return( 0 );
|
|
}
|
|
else {
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
sub ispkg {
|
|
my $class = shift;
|
|
my $file = shift;
|
|
my $lines = 0;
|
|
my $slinfo = 0;
|
|
my $name = 0;
|
|
my $version = 0;
|
|
my $ispkg = 0;
|
|
|
|
open( FILE, "<$file" ) || SL->error( 1, "open(): $file: $!" );
|
|
|
|
while ( <FILE> ) {
|
|
if ( substr( $_, 0, 7 ) eq 'slinfo/' ) {
|
|
$slinfo++;
|
|
}
|
|
elsif ( substr( $_, 0, 5 ) eq 'name:' ) {
|
|
$name++;
|
|
}
|
|
elsif ( substr( $_, 0, 8 ) eq 'version:' ) {
|
|
$version++;
|
|
}
|
|
|
|
$lines++;
|
|
|
|
if ( $lines >= 12 ) {
|
|
last;
|
|
}
|
|
}
|
|
|
|
close( FILE ) || SL->error( 1, "close(): $file: $!" );
|
|
|
|
if ( $slinfo && $name && $version ) {
|
|
return( 1 );
|
|
}
|
|
|
|
return( 0 );
|
|
}
|
|
|
|
sub kernver {
|
|
return( ( uname() )[2] );
|
|
}
|
|
|
|
sub ldconfig {
|
|
my $ldconfig = '/sbin/ldconfig';
|
|
my $pid;
|
|
my $stat;
|
|
|
|
print "Executing ldconfig\n";
|
|
|
|
if ( -f $ldconfig ) {
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
if ( $sl->{'target'} ) {
|
|
exec( "$ldconfig -r $SL::sl->{'target'}" )
|
|
|| exit( 1 );
|
|
}
|
|
else {
|
|
exec( $ldconfig ) || exit( 1 );
|
|
}
|
|
}
|
|
|
|
if ( $stat ) {
|
|
SL->error( 0, "Failed executing ldconfig" );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub lock {
|
|
open( $sl->{'lockfh'}, '+>', $sl->{'lockfile'} ) ||
|
|
SL->error( int( $! ), "open(): $sl->{'lockfile'}: $!" );
|
|
flock( $sl->{'lockfh'}, LOCK_EX|LOCK_NB ) ||
|
|
SL->error( int( $! ), "flock(): $sl->{'lockfile'}: $!" );
|
|
}
|
|
|
|
sub mkdirp {
|
|
( my $dir = shift ) =~ s/\/*$//;
|
|
my $mode = shift;
|
|
my $parent;
|
|
|
|
if ( -d $dir ) {
|
|
return;
|
|
}
|
|
|
|
if ( $dir =~ /.\/./ ) {
|
|
( $parent = $dir ) =~ s/\/[^\/]+$//;
|
|
|
|
if ( ! -d $parent ) {
|
|
mkdirp( $parent, $mode );
|
|
}
|
|
}
|
|
|
|
if ( $mode ) {
|
|
mkdir( $dir, $mode ) ||
|
|
SL->error( int( $! ), "mkdirp(): $dir: $!" );
|
|
}
|
|
else {
|
|
mkdir( $dir ) || SL->error( int( $! ), "mkdirp(): $dir: $!" );
|
|
}
|
|
}
|
|
|
|
sub mkinitramfs {
|
|
my $list = shift || return;
|
|
my $cmds = [];
|
|
my $stat;
|
|
my $pid;
|
|
|
|
if ( grep( $_ eq 'all', @$list ) ) {
|
|
push( @$cmds, 'mkinitramfs all' );
|
|
}
|
|
else {
|
|
foreach my $kernver ( @$list ) {
|
|
push( @$cmds, "mkinitramfs $kernver" );
|
|
}
|
|
}
|
|
|
|
foreach my $cmd ( @$cmds ) {
|
|
if ( $pid = fork() ) {
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
}
|
|
else {
|
|
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'
|
|
. " $cmd'";
|
|
}
|
|
else {
|
|
chroot( $SL::sl->{'target'} );
|
|
chdir( '/' );
|
|
}
|
|
|
|
exec( $cmd ) || exit( 1 );
|
|
}
|
|
|
|
if ( $stat ) {
|
|
SL->error( $stat, "Failed to run mkinitramfs" );
|
|
}
|
|
}
|
|
}
|
|
|
|
### pullarg() ##############################################
|
|
#
|
|
# This takes a hash ref as an argument. The keys are as
|
|
# follows:
|
|
#
|
|
# * short: The short arg (something like -t or -v)
|
|
# * long: The long arg (--target or --verbose)
|
|
# * arg2: Set to 1 (or other true value if the arg
|
|
# requires a second argument
|
|
# * keepargs: Set to 1 if the args should not be
|
|
# removed from @ARGV
|
|
#
|
|
# pullarg will return either a 1 if the arg is present, or
|
|
# the second argument value if present. It will also remove
|
|
# the args from @ARGV.
|
|
#
|
|
############################################################
|
|
|
|
sub pullarg {
|
|
my ( $class, $argopts ) = @_;
|
|
my $returnval = '';
|
|
|
|
foreach ( my $i = $#ARGV; $i >= 0; $i-- ) {
|
|
if ( $ARGV[$i] =~ /^\-([a-z]{2,})/ ) {
|
|
my @chars;
|
|
|
|
foreach ( split( '', $1 ) ) {
|
|
push( @chars, "-$_" );
|
|
}
|
|
|
|
splice( @ARGV, $i, 1, @chars);
|
|
}
|
|
}
|
|
|
|
for ( my $i = $#ARGV; $i >= 0; $i-- ) {
|
|
if ( $argopts->{'short'} && $ARGV[$i] eq $argopts->{'short'} ||
|
|
$ARGV[$i] eq $argopts->{'long'} ) {
|
|
if ( ! $argopts->{'arg2'} ) {
|
|
$returnval = 1;
|
|
|
|
if ( ! $argopts->{'keepargs'} ) {
|
|
splice( @ARGV, $i, 1 );
|
|
}
|
|
}
|
|
else {
|
|
$returnval = $ARGV[$i+1] || SL->error( 2,
|
|
"$argopts->{'long'}: Missing second"
|
|
. " argument" );
|
|
$returnval =~ s/\/$//;
|
|
|
|
if ( ! $argopts->{'keepargs'} ) {
|
|
splice( @ARGV, $i, 2 );
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return( $returnval );
|
|
}
|
|
|
|
### readconf() #############################################
|
|
#
|
|
# reads INI style files and builds a data structure with the
|
|
# parsed values.
|
|
#
|
|
# The config file can 'include' additional directories.
|
|
# Files in these directories will be parsed and added to
|
|
# the the data structure.
|
|
#
|
|
# Files ending in .conf will be parsed into the root of the
|
|
# data structure while .spt (Snaplinux package template)
|
|
# files will be stored in 'templates'
|
|
#
|
|
############################################################
|
|
|
|
sub readconf {
|
|
my $conffile = shift || $sl->{'conffile'};
|
|
my $data = shift || {};
|
|
my $section = '';
|
|
my $line = 0;
|
|
my $type;
|
|
|
|
open( my $fh, "<", $conffile ) || SL->error( int( $! ),
|
|
"open(): $conffile: $!\n" );
|
|
|
|
while ( <$fh> ) {
|
|
chomp( $_ );
|
|
|
|
if ( $_ =~ /^\s*#/ || $_ =~ /^$/ ) {
|
|
next;
|
|
}
|
|
elsif ( $_ =~ /\s*include\s+(.*)$/ ) {
|
|
foreach my $dir ( split( ' ', $1 ) ) {
|
|
opendir( my $dh, $dir ) ||
|
|
SL->error( int( $! ),
|
|
"opendir(): $dir: $!" );
|
|
|
|
while ( my $file = readdir( $dh ) ) {
|
|
if ( -f "$dir/$file" ) {
|
|
|
|
readconf( "$dir/$file", $data );
|
|
}
|
|
}
|
|
|
|
closedir( $dh ) || SL->error( int( $! ),
|
|
"closedir(): $dir: $!" );
|
|
}
|
|
}
|
|
elsif ( $_ =~ /\s*\[(\S+)\]\s*/ ) {
|
|
$section = $1;
|
|
|
|
if ( $section eq 'sources' && ! $data->{$section} ) {
|
|
$data->{$section} = [];
|
|
}
|
|
}
|
|
elsif ( $section eq 'sources' ) {
|
|
push( @{$data->{$section}}, $_ );
|
|
}
|
|
elsif ( $_ =~ /(\S+)\s*=\s*(.*)$/ ) {
|
|
$data->{$section}{$1} = $2;
|
|
}
|
|
}
|
|
|
|
close( $fh );
|
|
|
|
return( $data );
|
|
}
|
|
|
|
### setup() ################################################
|
|
#
|
|
# This should be called if the files and directories
|
|
# needed by the Snaplinux package system need to be created.
|
|
# is found not to be present. This includes the directories
|
|
# in /var/lib/sl, /etc/sl.conf, and /etc/sl_version
|
|
#
|
|
# Returns 1 if sources were refreshed
|
|
#
|
|
############################################################
|
|
|
|
sub setup {
|
|
if ( $sl->{'target'} && ! -e $sl->{'target'} ) {
|
|
mkdir( $sl->{'target'}, 0755 ) ||
|
|
SL->error( int( $! ), "mkdir: $!" );
|
|
}
|
|
if ( ! -e $sl->{'sldir'} ) {
|
|
mkdirp( $sl->{'sldir'}, 0755 );
|
|
}
|
|
if ( ! -e $sl->{'pkgdir'} ) {
|
|
mkdir( $sl->{'pkgdir'}, 0755 ) || SL->error( int( $! ),
|
|
"mkdir(): $sl->{'pkgdir'}: $!" );
|
|
}
|
|
if ( ! -e $sl->{'statdir'} ) {
|
|
mkdir( $sl->{'statdir'}, 0755 ) || SL->error( int( $! ),
|
|
"mkdir(): $sl->{'statdir'}: $!" );
|
|
}
|
|
if ( ! -e $sl->{'srcdir'} ) {
|
|
my $conf = readconf();
|
|
my $sources = SL::Sources->new( $conf->{'sources'} );
|
|
|
|
mkdir( $sl->{'srcdir'}, 0755 ) || SL->error( int( $! ),
|
|
"mkdir(): $sl->{'srcdir'}: $!" );
|
|
|
|
$sources->refresh();
|
|
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
### sha() ###############################################
|
|
#
|
|
# This sub returns a hex sha hash of a supplied file
|
|
#
|
|
############################################################
|
|
|
|
sub sha {
|
|
my $class = shift;
|
|
my $file = shift;
|
|
my $digest = eval {
|
|
Digest::SHA->new( 1 )->addfile( $file );
|
|
} || SL->error( 1, "sha(): $file: $!\n" );
|
|
|
|
return( $digest->hexdigest );
|
|
}
|
|
|
|
### sha256() ###############################################
|
|
#
|
|
# This sub returns a hex sha256 hash of a supplied file
|
|
#
|
|
############################################################
|
|
|
|
sub sha256 {
|
|
my $class = shift;
|
|
my $file = shift;
|
|
my $digest = eval {
|
|
Digest::SHA->new( 256 )->addfile( $file );
|
|
} || SL->error( 1, "sha256(): $file: $!\n" );
|
|
|
|
return( $digest->hexdigest );
|
|
}
|
|
|
|
sub templates {
|
|
my $conf = shift;
|
|
my $templatedir = $conf->{'slinstall'}{'templatedir'};
|
|
my $unsorted = [];
|
|
my $templates = {};
|
|
|
|
if ( ! -d $templatedir ) {
|
|
SL->error( 0, "templates(): $templatedir: no such file"
|
|
. " or directory" );
|
|
|
|
return();
|
|
}
|
|
|
|
opendir( my $dh, $templatedir ) ||
|
|
SL->error( int( $! ), "templates(): $!" );
|
|
|
|
while ( my $template = readdir( $dh ) ) {
|
|
if ( $template eq '.' || $template eq '..' ) {
|
|
next;
|
|
}
|
|
elsif ( ! -f "$templatedir/$template/packages" ) {
|
|
SL->error( 0, "Template '$template' has"
|
|
. " no packages" );
|
|
|
|
next;
|
|
}
|
|
|
|
$templates->{$template}{'packages'} = [];
|
|
|
|
open( my $fh, "$templatedir/$template/packages" ) ||
|
|
SL->error( int( $! ), "templates(): $!" );
|
|
|
|
while ( readline( $fh ) ) {
|
|
chomp();
|
|
|
|
if ( $_ =~ /^\s*#/ || $_ =~ /^$/ ) {
|
|
next;
|
|
}
|
|
|
|
push( @{$templates->{$template}{'packages'}}, $_ );
|
|
}
|
|
|
|
close( $fh );
|
|
}
|
|
|
|
closedir( $dh );
|
|
|
|
foreach ( sort { $a cmp $b }( @$unsorted ) ) {
|
|
push( @$templates, $_ );
|
|
}
|
|
|
|
return( $templates );
|
|
}
|
|
|
|
sub termsize {
|
|
my $row = 24;
|
|
my $col = 80;
|
|
my $sel = IO::Select->new();
|
|
my $stdout;
|
|
my $stderr;
|
|
my $stat;
|
|
my $pid;
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR,
|
|
"stty size -F /dev/tty" );
|
|
} || return( { row => $row, col => $col } );
|
|
|
|
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 ( $stdout && $stdout =~ /(\d+)\s+(\d+)/ ) {
|
|
$row = $1;
|
|
$col = $2;
|
|
}
|
|
|
|
return( { row => $row, col => $col } );
|
|
}
|
|
|
|
sub trigger {
|
|
if ( $sl->{'ldconfig'} || ref( $sl->{'mkinitramfs'} ) eq 'ARRAY' ||
|
|
$sl->{'grubmkconfig'} || $sl->{'installinfo'} ) {
|
|
print "Processing triggers\n";
|
|
}
|
|
|
|
if ( $sl->{'ldconfig'} ) {
|
|
ldconfig();
|
|
}
|
|
if ( ref( $sl->{'mkinitramfs'} ) eq 'ARRAY' ) {
|
|
mkinitramfs( $sl->{'mkinitramfs'} );
|
|
}
|
|
if ( $sl->{'grubmkconfig'} ) {
|
|
grubmkconfig();
|
|
}
|
|
if ( $sl->{'installinfo'} ) {
|
|
installinfo();
|
|
}
|
|
if ( $sl->{'hwdb'} ) {
|
|
hwdb();
|
|
}
|
|
}
|
|
|
|
sub unlock {
|
|
if ( $sl->{'lockfh'} && fileno( $sl->{'lockfh'} ) ) {
|
|
while ( readline( $sl->{'lockfh'} ) ) {
|
|
print "$_";
|
|
}
|
|
|
|
close( $sl->{'lockfh'} );
|
|
}
|
|
|
|
if ( -f $sl->{'lockfile'} ) {
|
|
unlink( $sl->{'lockfile'} ) ||
|
|
SL->error( int( $! ),
|
|
"unlink(): $sl->{'lockfile'}: $!" );
|
|
}
|
|
}
|
|
|
|
### vercmp() ###############################################
|
|
#
|
|
# This subroutine was basically copied verbatim from the
|
|
# Sort::Versions module. It was modified slightly so that
|
|
# it more closely matched the aesthetics of the rest of
|
|
# the Snaplinux code. The following credits and license
|
|
# information were provided within the documentation of
|
|
# that module:
|
|
#
|
|
# Ed Avis <ed@membled.com> and Matt Johnson
|
|
# <mwj99@doc.ic.ac.uk> for recent releases; the original
|
|
# author is Kenneth J. Albanowski <kjahds@kjahds.com>.
|
|
# Thanks to Hack Kampbjørn and Slaven Rezic for patches
|
|
# and bug reports.
|
|
#
|
|
# Copyright (c) 1996, Kenneth J. Albanowski. All rights
|
|
# reserved. This program is free software; you can
|
|
# redistribute it and/or modify it under the same terms as
|
|
# Perl itself.
|
|
#
|
|
# Return values:
|
|
#
|
|
# -1: A < B
|
|
# 0: match
|
|
# 1: A > B
|
|
#
|
|
############################################################
|
|
|
|
sub vercmp {
|
|
my $class = shift;
|
|
|
|
my @A = ( $_[0] =~ /([-.]|\d+|[^-.\d]+)/g );
|
|
my @B = ( $_[1] =~ /([-.]|\d+|[^-.\d]+)/g );
|
|
my ( $A, $B );
|
|
|
|
while ( @A and @B ) {
|
|
$A = shift @A;
|
|
$B = shift @B;
|
|
|
|
if ( $A eq '-' and $B eq '-' ) {
|
|
next;
|
|
}
|
|
elsif ( $A eq '-' ) {
|
|
return -1;
|
|
}
|
|
elsif ( $B eq '-' ) {
|
|
return 1;
|
|
}
|
|
elsif ( $A eq '.' and $B eq '.' ) {
|
|
next;
|
|
}
|
|
elsif ( $A eq '.' ) {
|
|
return -1;
|
|
}
|
|
elsif ( $B eq '.' ) {
|
|
return 1;
|
|
}
|
|
elsif ( $A =~ /^\d+$/ and $B =~ /^\d+$/ ) {
|
|
if ( $A =~ /^0/ || $B =~ /^0/ ) {
|
|
return $A cmp $B if $A cmp $B;
|
|
}
|
|
else{
|
|
return $A <=> $B if $A <=> $B;
|
|
}
|
|
}
|
|
else {
|
|
$A = uc $A;
|
|
$B = uc $B;
|
|
|
|
return $A cmp $B if $A cmp $B;
|
|
}
|
|
}
|
|
|
|
@A <=> @B;
|
|
}
|
|
|
|
### virtfs() ###############################################
|
|
#
|
|
# Need to try and figure out a solution for user installs
|
|
#
|
|
# The user may not be able to mount the virt filesystems,
|
|
# so perhaps it could do some kind of linking instead?
|
|
#
|
|
# Also remember you might want to move chroot out of usher
|
|
# and into here! We could also try to do fakechroot as well
|
|
#
|
|
############################################################
|
|
|
|
sub virtfs {
|
|
my $command = shift;
|
|
my $virtfs = {
|
|
dev => {
|
|
fs => 'devtmpfs',
|
|
dev => 'none',
|
|
dir => ( $sl->{'target'} || '' ) . '/dev'
|
|
},
|
|
proc => {
|
|
fs => 'proc',
|
|
dev => 'none',
|
|
dir => ( $sl->{'target'} || '' ) . '/proc'
|
|
},
|
|
sys => {
|
|
fs => 'sysfs',
|
|
dev => 'none',
|
|
dir => ( $sl->{'target'} || '' ) .'/sys'
|
|
}
|
|
};
|
|
|
|
####################################################
|
|
#
|
|
# If not root or no target defined we return since
|
|
# only root can mount, and the mount is only needed
|
|
# if we're installing to a target.
|
|
#
|
|
####################################################
|
|
|
|
if ( $> || ! $sl->{'target'} ) {
|
|
return( 0 );
|
|
}
|
|
|
|
foreach my $fs ( sort( keys( %$virtfs ) ) ) {
|
|
my $sel;
|
|
my $cmd;
|
|
my $stdout = '';
|
|
my $stderr = '';
|
|
my $stat = 0;
|
|
my $pid;
|
|
|
|
|
|
if ( ! -d $virtfs->{$fs}{'dir'} ) {
|
|
next;
|
|
}
|
|
|
|
if ( $command eq 'mount' ) {
|
|
if ( ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
next;
|
|
}
|
|
|
|
$cmd = "mount -t $virtfs->{$fs}{'fs'}"
|
|
. " $virtfs->{$fs}{'dev'}"
|
|
. " $virtfs->{$fs}{'dir'}";
|
|
}
|
|
elsif ( $command eq 'umount' ) {
|
|
if ( ! ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
next;
|
|
}
|
|
|
|
$cmd = "umount $virtfs->{$fs}{'dir'}";
|
|
}
|
|
else {
|
|
SL->error( 1, "virtfs(): $command:"
|
|
. " not a valid command" );
|
|
}
|
|
|
|
eval {
|
|
$pid = open3( \*CHLDIN, \*CHLDOUT, \*CHLDERR, $cmd );
|
|
} || SL->error( int( $! ), "open3(): $cmd: $!" );
|
|
|
|
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 );
|
|
|
|
waitpid( $pid, 0 );
|
|
$stat = $? >> 8;
|
|
|
|
if ( $stat ) {
|
|
return( 1 );
|
|
}
|
|
}
|
|
|
|
foreach my $fs ( sort( keys( %$virtfs ) ) ) {
|
|
if ( ! ismountpoint( $virtfs->{$fs}{'dir'} ) ) {
|
|
return( 0 );
|
|
}
|
|
}
|
|
|
|
return( 1 );
|
|
}
|
|
|
|
sub writelog {
|
|
my $msg = shift;
|
|
my $logfile = "$sl->{'target'}/var/log/sl.log";
|
|
|
|
open( my $fh, ">>$logfile" ) || return;
|
|
|
|
print $fh datetime() . " sl[$$]: $msg\n";
|
|
|
|
close( $fh );
|
|
}
|
|
|
|
1;
|