diff --git a/ROOT/etc/sl.d/templates/container/packages b/ROOT/etc/sl.d/templates/container/packages deleted file mode 100644 index 3e37d1f..0000000 --- a/ROOT/etc/sl.d/templates/container/packages +++ /dev/null @@ -1,57 +0,0 @@ -# -# These packages are the bare minimum necessary for a functional system. -# This file is required for snapinstall to function, so don't delete it! -# - -snap-base -dash -texinfo -glibc -coreutils -libacl -libattr -libcap -ncurses -readline -tzdata -perl -binutils -bzip2 -cpio -dhclient -e2fsprogs -ex -findutils -gawk -gdbm -gmp -grep -groff -gzip -iana-etc -iftools -inetutils -iproute2 -kmod -less -libgcc -libpipeline -libstdc++ -libzfs -linux-firmware -man-db -mpfr -net-tools -procps-ng -psmisc -sed -shadow -tar -snap -initscripts -sysklogd -sysvinit -tar -util-linux -xz -zlib diff --git a/ROOT/etc/sl.d/templates/server/packages b/ROOT/etc/sl.d/templates/server/packages deleted file mode 100644 index 1c7d2b1..0000000 --- a/ROOT/etc/sl.d/templates/server/packages +++ /dev/null @@ -1,63 +0,0 @@ -# -# This is a basic server install which includes openssh-server along with -# other packages typically expected on servers -# - -binutils -bzip2 -coreutils -cpio -cron -dash -dhclient -e2fsprogs -eudev -ex -findutils -gawk -gdbm -glibc -gmp -grep -groff -grub -gzip -iana-etc -iftools -inetutils -initscripts -iproute2 -kmod -less -libacl -libattr -libcap -libgcc -libpipeline -libstdc++ -libzfs -linux -man-db -mkinitramfs -mpfr -ncurses -net-tools -openssh-client -openssh-server -perl -procps-ng -psmisc -readline -rsyslog -sed -shadow -snap -snap-base -sysvinit -tar -tar -texinfo -tzdata -util-linux -xz -zlib diff --git a/ROOT/etc/sl.d/templates/server/postinst b/ROOT/etc/sl.d/templates/server/postinst deleted file mode 100644 index 541ce21..0000000 --- a/ROOT/etc/sl.d/templates/server/postinst +++ /dev/null @@ -1,45 +0,0 @@ -#!/bin/sh - -### PLACEHOLDER ### -# This script needs to provide things like network setup perhaps - -# This code should help with setting up the network interfaces -# -#my $dir = '/sys/class/net'; -#my $devs = {}; -# -#opendir( my $dh, $dir ) || die( $! ); -# -#while ( readdir( $dh ) ) { -# my $link = readlink( "$dir/$_" ) || next; -# -# if ( $link =~ /virtual/ ) { -# next; -# } -# -# open( my $fh, "$dir/$_/address" ) || die( $! ); -# $devs->{$_}{'mac'} = <$fh>; -# close( $fh ); -# -# chomp( $devs->{$_}{'mac'} ); -# } -# -#foreach my $dev ( sort( keys( %$devs ) ) ) { -# print "$dev - $devs->{$dev}{'mac'}\n"; -# } - -if [ -n "$HOSTNAME" ]; then - cat > /etc/hostname < { - brief => 'Remove unneeded packages', - help => [ - 'Display this help text', - 'List unneeded packages without removing', - 'An optional target may be specified to remove' - . ' packages in a separate directory/file' - . ' system' - ], - options => [ - '[-h,--help]', - '[-l,--list]', - '[-t,--target TARGET]' - ] - }, - dump => { - brief => 'Extract files from package', - help => [ - 'PKGNAME or FILE is required', - 'Display this help text', - 'Specify a destination directory to override ' - . ' the default of ./PKGNAME-VERSION' - ], - options => [ - '', - '[-h,--help]', - '[-d,--directory DIRECTORY]' - ] - }, - files => { - brief => 'List files in package', - help => [ - 'PKGGNAME or FILE is required. If PKGNAME is used' - . ' it must be an installed package', - 'List all files and directories', - 'Display this help text', - 'An optional target may be specified to query an' - . ' installed package in a separate' - . ' directory/file system', - 'Show full manifest details' - ], - options => [ - '', - '[-a,--all]', - '[-h,--help]', - '[-t,--target TARGET]', - '[-v,--verbose]' - ] - }, - genpkg => { - brief => 'Create package build directory', - help => [ - 'PKGNAME is required. This will create a directory' - . ' of the same name and populate it with a' - . ' basic set of files and directories' - . ' which are required to build a Snaplinux' - . ' package', - 'Display this help text' - ], - options => [ - '', - '[-h,--help]' - ] - }, - help => { - brief => 'Print brief usage information', - help => [ - 'Print details for all commands', - 'Display this help text' - ], - options => [ - '[-a,--all]', - '[-h,--help]' - ] - }, - info => { - brief => 'List package info', - help => [ - 'One or more PKGNAME or FILE is required. If a' - . ' package name is specified it must be' - . ' an installed package', - 'Display this help text', - 'An optional target may be specified to query a' - . ' separate directory/file system' - ], - options => [ - '', - '[-h,--help]', - '[-t,--target TARGET]' - ] - }, - install => { - brief => 'Install package', - help => [ - 'PKGNAME or FILE is required. A version string' - . ' can optionally be provided with the' - . ' PKGNAME as packagename=x.x.x', - 'Display this help text', - 'Install the package without dependencies', - 'An optional target may be specified to install' - . ' the package to a separate directory/file' - . ' system', - 'Proceed without prompting' - ], - options => [ - '', - '[-h,--help]', - '[-n,--nodeps]', - '[-t,--target TARGET]', - '[-y,--yes]' - ] - }, - list => { - brief => 'List installed packages', - help => [ - 'One or more strings can be supplied as filters', - 'Display this help text', - 'An optional target may be specified to query a' - . ' different directory/file system', - 'List full package details' - ], - options => [ - '[STRING]', - '[-h,--help]', - '[-t,--target TARGET]', - '[-v,--verbose]' - ] - }, - provides => { - brief => 'List packages that provide a file', - help => [ - 'STRING is required. All packages will be searched' - . ' and any which have files matching the' - . ' string will be listed', - 'Display this help text', - 'Use search string as regular expression', - 'An optional target may be specified to query a' - . ' different directory/file system', - ], - options => [ - '', - '[-h,--help]', - '[-r,--regex]', - '[-t,--target TARGET]' - ] - }, - purge => { - brief => 'Remove package along with any associated files', - help => [ - 'PKGNAME is required', - 'Display this help text', - 'An optional target may be specified to purge the' - . ' package from a separate directory/file' - . ' system', - 'Proceed without prompting' - ], - options => [ - '', - '[-h,--help]', - '[-t,--target TARGET]', - '[-y,--yes]' - ] - }, - rebuild => { - brief => 'Rebuild package DB', - help => [ - 'Display this help text', - 'An optional target may be specified to repair the' - . ' DB of a separate directory/file system', - 'Proceed without prompting' - ], - options => [ - '[-h,--help]', - '[-t,--target TARGET]', - '[-y,--yes]' - ] - }, - refresh => { - brief => 'Update package list cache for all sources', - help => [ - 'Display this help text', - 'An optional target may be specified to refresh the' - . ' package list of a separate directory/file' - . 'system', - ], - options => [ - '[-h,--help]', - '[-t,--target TARGET]' - ] - }, - reinstall => { - brief => 'Re-install package', - help => [ - 'PKGNAME is required', - 'Display this help text', - 'An optional target may be specified to re-install' - . ' the package on a separate directory/file' - . ' system', - 'Proceed without prompting' - ], - options => [ - '', - '[-h,--help]', - '[-t,--target TARGET]', - '[-y,--yes]' - ] - }, - remove => { - brief => 'Remove a package', - help => [ - 'PKGNAME is required', - 'Display this help text', - 'An optional target may be specified to remove' - . ' the package from a separate' - . ' directory/file system', - 'Proceed without prompting' - ], - options => [ - '', - '[-h,--help]', - '[-t,--target TARGET]', - '[-y,--yes]' - ] - }, - revdep => { - brief => 'List installed packages that depend on ', - help => [ - 'PKGNAME is required', - 'Display this help text', - 'An optional target may be specified to query' - . ' the packages on a separate' - . ' directory/file system', - ], - options => [ - '', - '[-h,--help]', - '[-t,--target TARGET]' - ] - }, - search => { - brief => 'Search repositories for packages', - help => [ - 'STRING is optional. If STRING is not provided all' - . ' repo packages are listed. An optional' - . ' version string may be used', - 'Return all versions from all repos', - 'Display this help text', - 'Specify a list of KEY:VALUE to limit search', - 'Print verbose output' - ], - options => [ - '[STRING[=VER]]', - '[-a,--all]', - '[-h,--help]', - '[-k,--keys KEYS]', - '[-t,--target TARGET]', - '[-v,--verbose]' - ] - }, - source => { - brief => 'Retrieve package source', - help => [ - 'PKGNAME is required. By default the source for the' - . ' currently installed version will be' - . ' retrieved. A version string can optionally' - . ' be provided with the PKGNAME as' - . ' packagename=x.x.x', - 'Display this help text', - 'Retrieve the latest version' - ], - options => [ - '', - '[-h,--help]', - '[-l,--latest]' - ] - }, - upgrade => { - brief => 'Upgrade packages', - help => [ - 'With no arguments all packages are upgraded' - . 'otherwise only the specified package', - 'Display this help text', - 'An optional target may be specified to upgrade' - . ' the package on a separate directory/file' - . ' system', - 'Proceed without prompting' - ], - options => [ - '[PKGNAME]', - '[-h,--help]', - '[-t,--target TARGET]', - '[-y]' - ] - }, - verify => { - brief => 'Verify integrity of installed packages', - help => [ - 'With no arguments all packages are verified' - . ' otherwise only the specified package' - . ' is checked', - 'Display this help text', - 'An optional target may be specified to verify' - . ' the package on a separate directory/file' - . ' system', - 'Print verbose output', - 'Proceed without prompting' - ], - options => [ - '[PKGNAME]', - '[-h,--help]', - '[-t,--target TARGET]', - '[-v,--verbose]', - '[-y,--yes]' - ] - }, - version => { - options => [], - brief => 'Display version information', - help => [] - } - }; - -my $conf = readconf(); -my $command = shift( @ARGV ) || ''; -my $commands = SL::Commands->new( $commandlist ); -my $sources = SL::Sources->new( $conf->{'sources'} ); -my $opts = $commands->parseopts( $command ); - -if ( $opts->{'help'} ) { - $commands->commandhelp( $command ); - } -elsif ( $command eq 'autorm' ) { - my $packages = []; - my $bytes = 0; - my $cnt = 0; - my $termsize = SL->termsize(); - my $virtfs = 0; - - $sources->readpkgs(); - - foreach my $pkgname ( sort( keys( %{$sources->{'status'}} ) ) ) { - my $package = $sources->{'status'}{$pkgname}; - my $revdeps = []; - - if ( $package->{'status'} ne 'Installed dependency' ) { - next; - } - - $package->revdeps( $sources, $revdeps, { noreq => 1 } ); - - if ( grep( $_->{'status'} eq 'Installed', @$revdeps ) ) { - next; - } - - push( @$packages, $package ); - } - - if ( ! @$packages ) { - print "No unneeded packages to remove\n"; - - exit; - } - - foreach my $package ( @$packages ) { - if ( ! $cnt ) { - print "\nThe following packages will be removed"; - - if ( $sl->{'target'} ) { - print " from " . $sl->{'target'}; - } - - print ":\n "; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - $cnt++; - - $bytes += $package->{'bytes'}; - } - - print "\n\n" . human( $bytes ) . " will be recovered."; - - if ( ! $opts->{'yes'} ) { - print " Continue (y/n): "; - - chkyes(); - } - - print "\n"; - - $cnt = 0; - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - if ( $cnt ) { - print "\n"; - } - - $package->remove( $sources ); - - $cnt++; - } - - if ( $virtfs ) { - virtfs( 'umount' ); - } - } -elsif ( $command eq 'dump' ) { - my $packages = []; - my $downloads = []; - my $cnt = 0; - $sources->readpkgs(); - - if ( ! @ARGV ) { - SL->error( -2, "Failed to specify a package name or file" ); - } - - foreach my $arg ( @ARGV ) { - my $package; - - if ( -f $arg && SL->ispkg( $arg ) ) { - $package = SL::Package->new( $arg ); - } - else { - $package = ( $sources->search( - { name => $arg } ) )->[-0]; - } - - if ( ! $package ) { - SL->error( -1, "$arg: No such package found" ); - } - - if ( $package->{'path'} =~ /https*:\/\// ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! -f "$sl->{'pkgdir'}/$filename" ) { - push( @$downloads, $package ); - } - else { - $package->{'path'} = - "$sl->{'pkgdir'}/$filename"; - } - } - - push( @$packages, $package ); - } - - if ( @$downloads ) { - print "Downloading packages\n"; - - foreach my $package ( @$downloads ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! -f "$sl->{'pkgdir'}/$filename" ) { - SL->httpget( $package->{'path'}, - "$sl->{'pkgdir'}/$filename", 0644 ); - } - - $package->{'path'} = "$sl->{'pkgdir'}/$filename"; - - if ( SL->sha256( $package->{'path'} ) ne - $package->{'sha256'} ) { - SL->error( 1, "$filename: " - . "sha256 does not match" ); - } - } - - print "\n"; - } - - foreach my $package( @$packages ) { - if ( $cnt ) { - print "\n"; - } - - $package->dump( $opts ); - - $cnt++; - } - } -elsif ( $command eq 'files' ) { - my $packages = []; - - if ( ! @ARGV ) { - $commands->commandhelp( $command ); - - SL->error( -1, "Failed to provide package" ); - } - - foreach my $arg ( @ARGV ) { - my $package = SL::Package->new( $arg ); - - if ( -f $arg || $package->installed() ) { - $package->files( $opts ); - - push( @$packages, $package ); - } - else { - print "$arg is not installed\n"; - } - } - - foreach my $package ( @$packages ) { - foreach my $file ( sort( keys( %{$package->{'files'}} ) ) ) { - my $sha = $package->{'files'}{$file}{'sha'}; - my $perms = $package->{'files'}{$file}{'perms'}; - - if ( $opts->{'verbose'} ) { - print "$sha\t$perms\t$file\n"; - } - else { - print "$file\n"; - } - } - } - } -elsif ( $command eq 'genpkg' ) { - if ( ! @ARGV ) { - $commands->commandhelp( $command ); - - SL->error( -1, "Failed to provide package name" ); - } - - foreach my $arg ( @ARGV ) { - genpkg( $arg ); - } - } -elsif ( $command eq 'help' ) { - $commands->help( $opts ); - } -elsif ( $command eq 'info' ) { - my $cnt = 0; - - if ( ! @ARGV ) { - $commands->commandhelp( $command ); - SL->error( -1, "Failed to provide package" ); - } - - foreach my $arg ( @ARGV ) { - my $package = SL::Package->new( $arg ); - - if ( $cnt ) { - print "\n"; - } - - $package->printself(); - - $cnt++; - } - } -elsif ( $command eq 'install' ) { - my @attribs = qw( source repo ); - my $string = "@ARGV"; - my $packages = []; - my $downloads = []; - my $bytes = 0; - my $virtfs = 0; - my $ldconfig = 0; - - if ( setup() ) { - print "\n"; - } - - foreach my $attrib ( @attribs ) { - if ( $string =~ /$attrib\s*:\s*(\S+)/ ) { - $opts->{$attrib} = $1; - - $string =~ s/$attrib\s*:\s*(\S+)? //; - } - } - - $sources->readpkgs(); - - #################################################### - # - # This replaces source packages with any package - # files supplied on the command line. - # - # This allows the user to override the source - # with local packages. - # - #################################################### - - foreach my $arg ( split( /\s+/, $string ) ) { - if ( -f $arg && SL->ispkg( $arg ) ) { - my $package = SL::Package->new( $arg ); - $sources->{'pkgs'}{$package->{'name'}} = []; - push( @{$sources->{'pkgs'}{$package->{'name'}}}, - $package ); - } - } - - #################################################### - # - # Need to have sl-base, coreutils, and dash at - # the very least. Here we're doing them in reverse - # order so that if sl-base is missing it'll - # be installed first! - # - #################################################### - - if ( ! installed( 'dash' ) ) { - $string =~ 's/(^|\s+)dash(\s+|$)//g'; - $string = "dash $string"; - } - if ( ! installed( 'coreutils' ) ) { - $string =~ 's/(^|\s+)coreutils(\s+|$)//g'; - $string = "coreutils $string"; - } - if ( ! installed( 'sl-base' ) ) { - $string =~ 's/(^|\s+)sl-base(\s+|$)//g'; - $string = "sl-base $string"; - } - - foreach my $arg ( split( /\s+/, $string ) ) { - my $package; - - if ( -f $arg && SL->ispkg( $arg ) ) { - $package = SL::Package->new( $arg ); - } - else { - my ( $name, $version ) = - split( /(((<|>)=?|=)(.*))/, $arg ); - $opts->{'name'} = $name; - $opts->{'version'} = $version; - - #################################### - # - # We do this to retrieve the package - # itself rather than the array which - # contains it - # - #################################### - - $package = ( $sources->search( $opts ) )->[0]; - } - - if ( ! $package ) { - writelog( "$arg: Invalid package" ); - SL->error( 1, "$arg: Invalid package" ); - } - - if ( ! $opts->{'nodeps'} ) { - print "Resolving dependencies for" - . " $package->{'name'}\n"; - - $package->depends( $sources, $packages ); - } - else { - writelog( "Ignoring dependencies for" - . " $package->{'name'}" ); - print "Ignoring dependencies for $package->{'name'}\n"; - } - - if ( ! grep( $_->{'name'} eq $package->{'name'}, - @$packages ) ) { - push( @$packages, $package ); - } - } - - foreach my $package ( @$packages ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( -f $package->{'path'} ) { - next; - } - elsif ( $package->{'path'} =~ /^http/ && - ! -f "$sl->{'pkgdir'}/$filename" ) { - push( @$downloads, $package ); - } - else { - $package->{'path'} = - "$sl->{'pkgdir'}/$filename"; - } - } - - if ( @$downloads ) { - print "\nDownloading packages\n"; - - foreach my $package ( @$downloads ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! -f "$sl->{'pkgdir'}/$filename" ) { - writelog( "Downloading $package->{'path'}" ); - SL->httpget( $package->{'path'}, - "$sl->{'pkgdir'}/$filename", 0644 ); - } - - $package->{'path'} = "$sl->{'pkgdir'}/$filename"; - - if ( SL->sha256( $package->{'path'} ) ne - $package->{'sha256'} ) { - SL->error( 1, "$filename: " - . "sha256 does not match" ); - } - } - } - - for ( my $i = 0; $i <= $#$packages; $i++ ) { - my $package = $packages->[$i]; - my $oldpkg = $sources->{'status'}{$package->{'name'}}; - my $oldbytes; - my $chk; - - $bytes += $package->{'bytes'}; - - if ( ! $oldpkg || ! $oldpkg->installed() ) { - writelog( "Installing $package->{'name'}" - . " $package->{'version'}" ); - - if ( $package->{'status'} ne 'installing dependency' ) { - $package->{'status'} = 'installing'; - } - - next; - } - - $chk = SL->vercmp( $oldpkg->{'version'}, - $package->{'version'} ); - - if ( $chk == -1 ) { - writelog( "Upgrading $package->{'name'} from" - . " $oldpkg->{'version'} to" - . " $package->{'version'}" ); - - $package->{'status'} = 'upgrading'; - $bytes -= $oldpkg->{'bytes'}; - } - elsif ( $chk == 0 ) { - writelog( "Package $package->{'name'}=" - . "$package->{'version'}" - . " is already installed" ); - print "Package $package->{'name'}=" - . "$package->{'version'}" - . " is already installed\n"; - - splice( @$packages, $i, 1 ); - - $i--; - - next; - } - elsif ( $chk == 1 && $opts->{'version'} ) { - writelog( "Downgrading $package->{'name'} from" - . " $oldpkg->{'version'} to" - . " $package->{'version'}" ); - - $package->{'status'} = 'downgrading'; - $bytes -= $oldpkg->{'bytes'}; - } - elsif ( $chk == 1 ) { - writelog( "The latest version of $oldpkg->{'name'}" - . " is already installed" ); - print "The latest version of $oldpkg->{'name'}" - . " ($oldpkg->{'version'}) is already" - . " installed"; - - splice( @$packages, $i, 1 ); - - $i--; - - next; - } - } - - if ( ! @$packages ) { - print "\nNothing to do\n"; - - exit; - } - - foreach my $status ( qw( installing upgrading downgrading ) ) { - my $termsize = SL->termsize(); - my $cnt = 0; - - foreach my $package ( sort { $a->{'name'} cmp $b->{'name'} } - ( @$packages ) ) { - if ( $package->{'status'} !~ /^$status/ ) { - next; - } - - if ( ! $cnt ) { - print "\nThe following packages will be"; - } - - if ( ! $cnt && substr( $status, 0, 10 ) - eq 'installing' ) { - print " installed:\n "; - } - elsif ( ! $cnt && $status eq 'upgrading' ) { - print " upgraded:\n "; - } - elsif ( ! $cnt && $status eq 'downgrading' ) { - print " downgraded:\n "; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - $cnt++; - } - } - - print "\n"; - - if ( $bytes < 0 ) { - print "\nInstall will recover " . human( -1 * $bytes ) - } - else { - print "\nInstall will require " . human( $bytes ) - } - - if ( ! $opts->{'yes'} ) { - print " Continue? (y/n): "; - - chkyes(); - } - else { - print "\n"; - } - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - $package->conflicts( $sources ); - $package->install( $sources ); - - writelog( "Done installing $package->{'name'}" ); - - print "\n"; - } - - #################################################### - # - # This executes processes such as install-info, - # grub-mkconfig, mkinitramfs, etc if needed. - # - #################################################### - - trigger(); - - if ( $virtfs ) { - virtfs( 'umount' ); - } - } -elsif ( $command eq 'list' ) { - my $cnt = 0; - $sources->readpkgs(); - - foreach my $pkgname ( sort( keys( %{$sources->{'status'}} ) ) ) { - my $package = $sources->{'status'}{$pkgname}; - - if ( @ARGV && ! grep( $package->{'name'} =~ /$_/, @ARGV ) ) { - next; - } - - if ( $opts->{'verbose'} ) { - if ( $cnt ) { - print "\n"; - } - - $package->printself(); - } - else { - $package->printbrief(); - } - - $cnt++; - } - - if ( $cnt <= 0 ) { - if ( @ARGV ) { - print "No installed packages found matching '@ARGV'\n"; - } - else { - print "No installed packages found\n"; - } - } - } -elsif ( $command eq 'provides' ) { - ( my $string = $ARGV[0] ) =~ s/^\/*/\//; - my $len = length( $string ); - - $sources->readpkgs(); - - foreach my $pkgname ( sort( keys( %{$sources->{'status'}} ) ) ) { - my $package = $sources->{'status'}{$pkgname}; - my $cnt = 0; - - if ( ! $package->installed() ) { - next; - } - - $package->files(); - - foreach my $file ( sort{ $a cmp $b }( - keys( %{$package->{'files'}} ) ) ) { - if ( ( $opts->{'regex'} && "/$file" =~ /$string/ ) || - ( substr( "/$file", -$len, $len ) eq $string ) ) { - if ( ! $cnt ) { - print "[$pkgname]\n"; - } - - print " * $sl->{'target'}/$file\n"; - - $cnt++; - } - } - - if ( $cnt ) { - print "\n"; - } - } - } -elsif ( $command eq 'purge' ) { - my $packages = []; - my $revdeps = []; - my $bytes = 0; - my $cnt = 0; - my $termsize = SL->termsize(); - my $virtfs = 0; - - $sources->readpkgs(); - -############################################################ -# -# We're working on PURGE! We're going to need to do a -# $package->remove() on packages that are not yet removed. -# We're going to need to $package->remove() on any packages -# that depend on this package. Similar to the remove -# command, but a separate array will be needed for the -# packages to be removed because they depend on this one. -# Those will be removed first, then this package -# removed (if not yet removed), then finally purge this -# package! -# -# IF THE PACKAGE IS ALREADY REMOVED JUST IGNORE DEPS? -# -# Also need to make sure to only report the amount of -# space to be recovered if the package is being removed. -# Perhaps this output should be handled by the remove() -# sub instead? -# -############################################################ - - foreach my $arg ( @ARGV ) { - my $package = SL::Package->new( $arg ); - - if ( substr( $package->{'status'}, 0, 1 ) eq 'N' ) { - writelog( "Package $package->{'name'} is not present" ); - print "Package $package->{'name'} is not present\n"; - - next; - } - if ( ! $opts->{'nodeps'} && - substr( $package->{'status'}, 0, 1 ) ne 'R' ) { - print "Resolving reverse dependencies for" - . " $package->{'name'}\n"; - - $package->revdeps( $sources, $packages, - { noreq => 1 } ); - } - elsif( substr( $package->{'status'}, 0, 1 ) ne 'R' ) { - print "Ignoring reverse dependencies for" - . " $package->{'name'}\n"; - } - - if ( ! grep( $_->{'name'} eq $package->{'name'}, - @$packages ) ) { - push( @$packages, $package ); - } - } - - foreach my $package ( @$packages ) { - if ( ! $cnt ) { - print "\nThe following packages will be purged"; - - if ( $sl->{'target'} ) { - print " from $sl->{'target'}"; - } - - print ":\n "; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - $cnt++; - - if ( substr( $package->{'status'}, 0, 1 ) ne 'R' ) { - $bytes += $package->{'bytes'}; - } - } - - print "\n\n" . human( $bytes ) . " will be recovered." - . " Continue? (y/n): "; - - if ( ! $opts->{'yes'} ) { - chkyes(); - } - - print "\n"; - - $cnt = 0; - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - if ( $cnt ) { - print "\n"; - } - - $package->files(); - - $package->remove( $sources ); - writelog( "Purged $package->{'name'}-$package->{'version'}" ); - - $package->purge(); - - $cnt++; - } - - trigger(); - - if ( $virtfs ) { - virtfs( 'umount' ); - } - } -elsif ( $command eq 'rebuild' ) { - print "Not yet implemented\n"; - - exit( -1 ); - } -elsif ( $command eq 'refresh' ) { - if ( ! setup() ) { - $sources->refresh(); - } - } -elsif ( $command eq 'reinstall' ) { - my $termsize = SL->termsize(); - my $packages = []; - my $virtfs = 0; - my $cnt = 0; - - setup(); - - $sources->readpkgs(); - - foreach my $pkgname ( @ARGV ) { - my $package; - - if ( -f $pkgname ) { - $package = SL::Package->new( $pkgname ); - } - else { - if ( ! $sources->{'status'}{$pkgname} ) { - SL->error( -1, "$pkgname not installed" ); - } - - $package = $sources->{'status'}{$pkgname}; - $package = ( $sources->search( { - name => $package->{'name'}, - version => $package->{'version'}, - } ) )->[0]; - } - - if ( $package->{'path'} =~ /https*:\/\// ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! -f "$sl->{'pkgdir'}/$filename" ) { - SL->httpget( $package->{'path'}, - "$sl->{'pkgdir'}/$filename", 0644 ); - } - - $package->{'path'} = "$sl->{'pkgdir'}/$filename"; - - if ( SL->sha256( $package->{'path'} ) ne - $package->{'sha256'} ) { - SL->error( 1, "$filename: " - . "sha256 does not match" ); - } - } - - $package->files( $opts ); - - if ( ! grep( $_->{'name'} eq $package->{'name'}, - @$packages ) ) { - push( @$packages, $package ); - } - } - - foreach my $package ( sort { $a->{'name'} cmp $b->{'name'} } - ( @$packages ) ) { - if ( ! $cnt ) { - print "The following packages will be" - . " reinstalled:\n "; - - $cnt++; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - } - - print "\n"; - - if ( ! $opts->{'yes'} ) { - print "\nContinue? (y/n): "; - - chkyes(); - } - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - print "\n"; - - $package->files(); - $package->install( $sources ); - - writelog( "Re-installed $package->{'name'}" - . "-$package->{'version'}" ); - } - - print "\n"; - - trigger(); - - virtfs( 'umount' ); - } -elsif ( $command eq 'remove' ) { - my $packages = []; - my $bytes = 0; - my $cnt = 0; - my $termsize = SL->termsize(); - my $virtfs = 0; - - $sources->readpkgs(); - - foreach my $arg ( @ARGV ) { - my $package = SL::Package->new( $arg ); - - if ( $package->{'status'} =~ /^(R|N)/ ) { - writelog( "Package $package->{'name'}" - . " is not installed" ); - print "Package $package->{'name'} is not installed\n"; - - next; - } - if ( ! $package ) { - SL->error( 1, "$arg: No such package found" ); - } - - if ( ! $opts->{'nodeps'} ) { - print "Resolving reverse dependencies for" - . " $package->{'name'}\n"; - - $package->revdeps( $sources, $packages, - { noreq => 1 } ); - } - else { - print "Ignoring reverse dependencies for" - . " $package->{'name'}\n"; - } - - if ( ! grep( $_->{'name'} eq $package->{'name'}, - @$packages ) ) { - push( @$packages, $package ); - } - } - - foreach my $package ( sort { $a->{'name'} cmp $b->{'name'} } - ( @$packages ) ) { - if ( ! $cnt ) { - print "\nThe following packages will be removed"; - - if ( $sl->{'target'} ) { - print " from $sl->{'target'}"; - } - - print ":\n "; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - $cnt++; - - $bytes += $package->{'bytes'}; - } - - if ( ! @$packages ) { - print "\nNothing to do\n"; - - exit; - } - - print "\n\n" . human( $bytes ) . " will be recovered." - . " Continue? (y/n): "; - - if ( ! $opts->{'yes'} ) { - chkyes(); - } - - print "\n"; - - $cnt = 0; - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - if ( $cnt ) { - print "\n"; - } - - $package->files(); - $package->remove( $sources ); - - writelog( "Removed package $package->{'name'}" - . " $package->{'version'}" ); - - $cnt++; - } - - trigger(); - - if ( $virtfs ) { - virtfs( 'umount' ); - } - } -elsif ( $command eq 'revdep' ) { - my $revdeps = []; - - $sources->readpkgs(); - - foreach my $arg ( @ARGV ) { - my $package = SL::Package->new( $arg ); - - $package->revdeps( $sources, $revdeps, { noreq => 1 } ); - } - - foreach ( sort { $a->{'name'} cmp $b->{'name'} } ( @$revdeps ) ) { - print "$_->{'name'}\n"; - } - - if ( ! @$revdeps ) { - print "No reverse dependencies found\n"; - } - } -elsif ( $command eq 'search' ) { - my $packages = []; - my $cnt = 0; - $sources->readpkgs(); - - if ( ! @ARGV ) { - push( @ARGV, '.*' ); - } - - foreach ( @ARGV ) { - $opts->{'search'} = $_; - - foreach my $package ( @{$sources->search( $opts )} ) { - if ( $opts->{'all'} || ! grep( $_->{'name'} eq - $package->{'name'}, @$packages ) ) { - push( @$packages, $package ); - } - } - } - - foreach my $package ( sort{ $a->{'name'} cmp $b->{'name'} }( - @$packages ) ) { - if ( $cnt && $opts->{'verbose'} ) { - print "\n"; - } - - if ( $opts->{'verbose'} ) { - $package->printself(); - } - else { - $package->printbrief(); - } - - $cnt++; - } - - if ( ! $cnt ) { - print "No matching packages found\n"; - } - } -elsif ( $command eq 'source' ) { - $sources->readpkgs(); - - foreach my $arg ( @ARGV ) { - my $package;# = SL::Package->new( $arg ); - - if ( $sources->{'installed'}{$arg} && ! $opts->{'latest'} ) { - $package = $sources->{'installed'}{$arg}; - } - else { - my ( $name, $version ) = - split( /(((<|>)=?|=)(.*))/, $arg ); - $opts->{'name'} = $name; - $opts->{'version'} = $version; - $package = ( $sources->search( $opts ) )->[0]; - } - - $package->source(); - } - } -elsif ( $command eq 'upgrade' ) { - my $packages = []; - my $downloads = []; - my $termsize = SL->termsize(); - my $bytes = 0; - my $cnt = 0; - my $virtfs = 0; - $sources->readpkgs(); - - if ( ! @ARGV ) { - foreach my $pkgname ( keys( %{$sources->{'installed'}} ) ) { - my $package = $sources->{'installed'}{$pkgname}; - - if ( ! $sources->{'installed'}{$pkgname} ) { - print "Package '$pkgname' not installed\n"; - - next; - } - else { - $package = $sources->{'installed'}{$pkgname}; - } - - if ( $sources->{'pkgs'}{$pkgname} && SL->vercmp( - $sources->{'pkgs'}{$pkgname}[-1]{'version'}, - $package->{'version'} ) == 1 ) { - push( @$packages, - $sources->{'pkgs'}{$pkgname}[-1] ); - } - else { - if ( $sl->{'debug'} ) { - print "No upgrade available for" - . " $pkgname\n"; - } - } - } - } - else { - foreach my $pkgname ( @ARGV ) { - my $package; - - if ( ! $sources->{'installed'}{$pkgname} ) { - print "Package '$pkgname' not installed\n"; - - next; - } - else { - $package = $sources->{'installed'}{$pkgname}; - } - - if ( $sources->{'pkgs'}{$pkgname} && SL->vercmp( - $sources->{'pkgs'}{$pkgname}[-1]{'version'}, - $package->{'version'} ) == 1 ) { - push( @$packages, - $sources->{'pkgs'}{$pkgname}[-1] ); - } - else { - print "No upgrade available for $pkgname\n"; - } - } - } - - if ( ! @$packages ) { - print "No packages require upgrade\n"; - - exit; - } - - foreach my $package ( @$packages ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! $opts->{'nodeps'} ) { - print "Resolving dependencies for" - . " $package->{'name'}\n"; - - $package->depends( $sources, $packages ); - } - else { - print "Ignoring dependencies for $package->{'name'}\n"; - } - - if ( -f $package->{'path'} ) { - next; - } - elsif ( $package->{'path'} =~ /^http/ && - ! -f "$sl->{'pkgdir'}/$filename" ) { - push( @$downloads, $package ); - } - else { - $package->{'path'} = - "$sl->{'pkgdir'}/$filename"; - } - } - - if ( @$downloads ) { - print "\nDownloading packages\n"; - - foreach my $package ( @$downloads ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( ! -f "$sl->{'pkgdir'}/$filename" ) { - SL->httpget( $package->{'path'}, - "$sl->{'pkgdir'}/$filename", 0644 ); - } - - $package->{'path'} = "$sl->{'pkgdir'}/$filename"; - - if ( SL->sha256( $package->{'path'} ) ne - $package->{'sha256'} ) { - SL->error( 1, "$filename: " - . "sha256 does not match" ); - } - } - } - - foreach my $package ( sort { $a->{'name'} cmp $b->{'name'} } - ( @$packages ) ) { - my $oldpkg = $sources->{'installed'}{$package->{'name'}}; - $bytes += $package->{'bytes'}; - - if ( $oldpkg ) { - $bytes -= $oldpkg->{'bytes'}; - - writelog( "Upgrading $oldpkg->{'name'}" - . "-$oldpkg->{'version'} to" - . " $package->{'name'}-$package->{'version'}" ); - } - - if ( ! $cnt ) { - print "\nThe following packages will be" - . " upgraded:\n "; - } - - if ( $termsize->{'col'} - ( length( - $package->{'name'} ) + 3 ) <= 0 ) { - print "\n "; - - $termsize = SL->termsize(); - } - - print "$package->{'name'} "; - - $termsize->{'col'} -= length( $package->{'name'} ) + 1; - $cnt++; - } - - if ( $bytes < 0 ) { - print "\n\nUpgrade will recover " . human( -1 * $bytes ); - } - else { - print "\n\nUpgrade will require " . human( $bytes ); - } - - if ( ! $opts->{'yes'} ) { - print ". Continue? (y/n): "; - - chkyes(); - } - else { - print "\n"; - } - - foreach my $package ( @$packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - - print "\n"; - - $package->conflicts( $sources ); - $package->install( $sources ); - - writelog( "Finished installing $package->{'name'}" - . "-$package->{'version'}" ); - } - - trigger(); - - if ( $virtfs ) { - virtfs( 'umount' ); - } - } -elsif ( $command eq 'verify' ) { - my $packages = []; - my $failedcnt = 0; - $sources->readpkgs(); - - if ( @ARGV ) { - foreach my $arg ( sort{ $a cmp $b }( @ARGV ) ) { - my $package = $sources->{'status'}{$arg} || - SL->error( 1, "$arg: not installed" ); - - push( @$packages, $package ); - } - } - else { - foreach my $pkgname ( sort{ $a cmp $b } - keys( %{$sources->{'status'}} ) ) { - my $package = $sources->{'status'}{$pkgname}; - - push( @$packages, $package ); - } - } - - foreach my $package ( @$packages ) { - my $result = $package->verify( $opts ); - - if ( ! @{$result->{'failed'}} ) { - writelog( "$package->{'name'}-$package->{'version'}" - . " passed verification" ); - print "$package->{'name'}: OK\n"; - } - else { - writelog( "$package->{'name'}-$package->{'version'}" - . " failed verification" ); - print "$package->{'name'}: " . @{$result->{'failed'}} - . " files failed verification\n"; - - foreach ( sort{ $a cmp $b } - ( @{$result->{'failed'}} ) ) { - $failedcnt++; - - print " * $_\n"; - } - } - } - - if ( $failedcnt ) { - exit( 1 ); - } - } -elsif ( $command eq 'version' ) { - print "$sl->{'version'}\n"; - } -elsif ( $command ) { - SL->error( 0, "'$command': Invalid command" ); - $commands->help(); - exit( 2 ); - } diff --git a/ROOT/usr/bin/slinstall b/ROOT/usr/bin/slinstall deleted file mode 100755 index 87cb058..0000000 --- a/ROOT/usr/bin/slinstall +++ /dev/null @@ -1,195 +0,0 @@ -#!/usr/bin/perl - -use Data::Dumper; - -use strict; -use warnings; - -use Snap; - -setup(); - -my $conf = readconf(); -my $templates = templates( $conf ); -my $template = $ARGV[0] || Snap->error( 1, 'Failed to supply template' ); -my $sources = Snap::Sources->new( $conf->{'sources'} ); -my @basepkgs = qw( snap-base coreutils dash ); -my @packages = (); -my $rootfs; -my $preinst; -my $rootpw; -my $postinst; -my $pid; -my $stat; -my $virtfs; -my $dialog; - -if ( ! $snap->{'target'} ) { - Snap->error( -1, 'A target must be specified with -t' ); - } - -if ( ! $templates->{$template} ) { - Snap->error( -1, "$template: Invalid template" ); - } - -$rootfs = "$conf->{'snapinstall'}{'templatedir'}/$template/rootfs"; -$preinst = "$conf->{'snapinstall'}{'templatedir'}" - . "/$template/preinst"; -$postinst = "$conf->{'snapinstall'}{'templatedir'}" - . "/$template/postinst"; - -if ( -f $preinst ) { - pipe( my $reader, my $writer ) || - Snap->error( int( $! ), "pipe(): $!" ); - - if ( $pid = fork() ) { - close( $writer ); - } - else { - close( $reader ); - open( STDERR, '>&', $writer ); - exec( $preinst ) || die( $! ); - - exit; - } - - waitpid( $pid, 0 ); - $stat = $? >> 8; - - while ( readline( $reader ) ) { - if ( $_ =~ /^([a-zA-Z]+)=\s*(.*)$/ ) { - $ENV{$1} = $2; - } - } - - close( $reader ); - } - -$sources->readpkgs(); - -foreach my $pkgname ( @basepkgs ) { - my $package = $sources->latest( $pkgname ); - - $package->depends( $sources, \@packages ); - - if ( ! grep( $_ eq $package->{'name'}, @packages ) ) { - push( @packages, $package ); - } - } - -foreach my $pkgname ( @{$templates->{$template}{'packages'}} ) { - my $package = $sources->latest( $pkgname ) || - Snap->error( 1, "$pkgname: Unable to find package" ); - - if ( grep( $_->{'name'} eq $pkgname, @packages ) ) { - next; - } - - $package->depends( $sources, \@packages ); - - if ( ! grep( $_ eq $package->{'name'}, @packages ) ) { - push( @packages, $package ); - } - } - -open( $dialog, "|dialog --title ' Downloading Packages ' --gauge '' 8 70 0" ); -select( $dialog ); - -foreach my $package ( @packages ) { - if ( $package->{'path'} =~ /https*:\/\// ) { - ( my $filename = $package->{'path'} ) =~ s/.*\///; - - if ( -f $snap->{'pkgdir'} . "/$filename" ) { - $package->{'path'} = $snap->{'pkgdir'} . "/$filename"; - } - elsif ( -f "/var/lib/snap/packages/$filename" ) { - $package->{'path'} = "/var/lib/snap/packages/$filename"; - } - else { - Snap->httpget( $package->{'path'}, - "$snap->{'pkgdir'}/$filename", 0644, - { dialog => 1 } ); - - $package->{'path'} = "$snap->{'pkgdir'}/$filename"; - } - } - } - -select( STDOUT ); -close( $dialog ); - -if ( -d $rootfs && ! Snap->dirempty( $rootfs ) ) { - if ( $pid = fork() ) { - waitpid( $pid, 0 ); - $stat = $? >> 8; - } - else { -# print "\nCopying rootfs files\n"; -# exec( "cp -va '$rootfs'/* $snap->{'target'}" ); - exec( "cp -a '$rootfs'/* $snap->{'target'}" ); - } - - if ( $stat ) { - Snap->error( $stat, "Failed to copy rootfs" ); - } - } - -open( $dialog, "|dialog --title ' Installing Packages ' --gauge '' 8 70 0" ); -select( $dialog ); - -foreach my $package ( @packages ) { - if ( ! $virtfs ) { - $virtfs = virtfs( 'mount' ); - } - -# print "\n"; - - $package->install( $sources, { dialog => 1 } ); - } - -select( STDOUT ); -close( $dialog ); - -print "\033[2J"; -print "\033[0;0H"; - -trigger(); - -if ( -f $postinst ) { - my $tmpscript = "/var/lib/snap/postinst"; - - open( my $fh, '<', $postinst ) || Snap->error( int( $! ), - "Failed to open $postinst" ); - open( my $wh, '>', "$snap->{'target'}/$tmpscript" ) || - Snap->error( int( $! ), "Failed to open $tmpscript" ); - chmod( 0755, "$snap->{'target'}/$tmpscript" ); - - while ( <$fh> ) { - print $wh $_; - } - - close( $wh ); - close( $fh ); - - if ( $pid = fork() ) { - waitpid( $pid, 0 ); - $stat = $? >> 8; - } - else { - if ( $> ) { - exec( "fakeroot fakechroot /usr/sbin/chroot " - . "$snap->{'target'} $tmpscript" ); - } - else { - exec ( "chroot $snap->{'target'} $tmpscript" ); - } - } - - if ( $stat ) { - Snap->error( $stat, "Failed to execute $tmpscript" ); - } - } - -if ( $virtfs ) { - virtfs( 'umount' ); - } diff --git a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL.pm b/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL.pm deleted file mode 100644 index 2b09c20..0000000 --- a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL.pm +++ /dev/null @@ -1,1388 +0,0 @@ -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 = ; - 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 ( ) { - 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 ( ) { - 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 and Matt Johnson -# for recent releases; the original -# author is Kenneth J. Albanowski . -# 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; diff --git a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm b/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm deleted file mode 100644 index 84a77ef..0000000 --- a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm +++ /dev/null @@ -1,159 +0,0 @@ -package SL::Commands; - -use strict; -use warnings; - -use parent 'SL'; - -sub new { - my( $class, $commands ) = @_; - - return( bless( $commands, $class ) ); - } - -sub commandhelp { - my $self = shift; - my $command = shift; - my $optcount = 0; - - if ( ! $self->{$command} ) { - SL->error( 2, "help(): Invalid command '$command'" ); - } - - my $options = $self->{$command}{'options'}; - my $help = $self->{$command}{'help'}; - - print "$0 $command"; - - foreach ( @{$self->{$command}{'options'}} ) { - if ( $_ =~ /^(<|\[[A-Z])/ ) { - print " $_"; - } - elsif ( substr( $_, 0, 1 ) eq '[' ) { - $optcount++; - } - } - - if ( $optcount ) { - print ' [OPTIONS]'; - } - - print "\n\n$self->{$command}{'brief'}\n"; - - for ( my $i = 0; $i <= $#{$options}; $i++ ) { - my $charcnt = 0; - printf( "\n %-32s", $options->[$i] ); - - foreach ( split( ' ', $help->[$i] ) ) { - $charcnt += length( $_ ) + 1; - - if ( $charcnt >= 34 ) { - $charcnt = 0; - - print "\n" . ( ' ' x 34 ) . "$_ "; - } - else { - print "$_ "; - } - } - - print "\n"; - } - } - -sub help { - my ( $self, $opts ) = @_; - my $cnt = 0; - - print "Usage: $0 \n\n" - . "sl is the Snaplinux package management utility\n\n" - . "COMMANDS\n\n"; - - if ( $opts->{'all'} ) { - foreach my $command ( sort( keys( %$self ) ) ) { - if ( $cnt ) { - print "\n"; - } - - $self->commandhelp( $command ); - - $cnt++; - } - } - else { - foreach my $command ( sort( keys( %$self ) ) ) { - print " $command \t\t\t$self->{$command}{'brief'}\n" - } - } - - print "\nTo view more information for commands run:\n" - . "sl -h|--help\n"; - } - -sub parseopts { - my ( $self, $command ) = @_; - my $opts = {}; - - if ( ! $command ) { - SL->error( 0, "parseopts(): Missing COMMAND" ); - $self->help(); - exit( 2 ); - } - elsif ( ! $self->{$command} ) { - SL->error( 0, "parseopts(): '$command': Invalid COMMAND" ); - $self->help(); - exit( 2 ); - } - - foreach ( my $i = $#ARGV; $i >= 0; $i-- ) { - if ( $ARGV[$i] =~ /^\-([a-z]{2,})/ ) { - my @chars = split( '', $1 ); - - splice( @ARGV, $i, 1 ); - - foreach ( @chars ) { - push( @ARGV, "-$_" ); - - $i = $#ARGV; - } - } - - if ( substr( $ARGV[$i], 0, 1 ) eq '-' && - ! grep( $_ =~ /(\[$ARGV[$i],|\[\-[a-z],$ARGV[$i]( |\]))/, - @{$self->{$command}{'options'}} ) ) { - SL->error( 2, "$ARGV[$i]: invalid argument" ); - } - } - - foreach ( @{$self->{$command}{'options'}} ) { - my( $short, $long, $arg2 ) = ''; - my $tmpopts = {}; - - if ( $_ =~ /^\[(\-[a-z]),(\-\-([a-z]+))( (\S+)\]|\])/ ) { - $short = $1 || SL->error( 1, "Malformed short arg" - . " definition" ); - $long = $2 || SL->error( 1, "Malformed long arg" - . " definition" ); - $arg2 = $5 || ''; - - $tmpopts = SL->pullarg( { - short => $short, - long => $long, - arg2 => $arg2 - } ); - - if ( ref( $tmpopts ) ) { - foreach my $key ( %$tmpopts ) { - $opts->{$key} = $tmpopts->{$key}; - } - } - else { - $opts->{$3} = $tmpopts; - } - } - } - - return( $opts ); - } - -1; diff --git a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm b/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm deleted file mode 100644 index 8c35303..0000000 --- a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm +++ /dev/null @@ -1,2039 +0,0 @@ -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 ( ) { - 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 ( ) { - 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//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; diff --git a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm b/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm deleted file mode 100644 index aa4c8cb..0000000 --- a/ROOT/usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm +++ /dev/null @@ -1,382 +0,0 @@ -package SL::Sources; - -use Data::Dumper; - -use strict; -use warnings; - -use Compress::Zlib; - -use parent 'SL'; - -sub new { - my $class = shift; - my $srcconf = shift; - my $sources = {}; - - foreach my $source ( @$srcconf ) { - if ( $source =~ /^(\S+)\s*=\s*(\S+?)\/*\s+(\S.*)$/ ) { - $sources->{'config'}{$1}{'url'} = "$2/" - . $SL::sl->{'slver'}; - $sources->{'config'}{$1}{'order'} = - keys( %{$sources->{'config'}} ); - - foreach ( split( /\s+/, $3 ) ) { - $sources->{'config'}{$1}{'repos'}{$_} = {}; - } - } - else { - SL->error( int( $! ), "SL::Sources->new():" - . " Invalid source format: $source" ); - } - } - - return( bless( $sources, $class ) ); - } - -### latest() ############################################### -# -# This *should* be a pretty much guaranteed method of -# retrieving the latest version of a package -# -############################################################ - -sub latest { - my ( $self, $pkgname ) = @_; - my $package; - - foreach ( sort { SL->vercmp( $a->{'version'}, - $b->{'version'} ) } @{$self->{'pkgs'}{$pkgname}} ) { - $package = $_; - } - - return( $package ); - } - -sub readpkgs { - my $self = shift; - $self->{'status'} = {}; - - opendir( DIR, $SL::sl->{'statdir'} ) || - SL->error( 1, "opendir(): $SL::sl->{'statdir'}: $!" ); - - foreach my $pkgname ( readdir( DIR ) ) { - my $slinfo = "$SL::sl->{'statdir'}/$pkgname/slinfo"; - my $package; - - if ( $pkgname =~ /^\.{1,2}$/ || ! -f $slinfo ) { - next; - } - - $package = SL::Package->new( $pkgname ); - - $self->{'status'}{$pkgname} = $package; - } - - close( DIR ); - - foreach my $source ( sort { $self->{'config'}{$a}{'order'} <=> - $self->{'config'}{$b}{'order'} } ( keys( %{$self->{'config'}} ) ) ) { - my $repos = $self->{'config'}{$source}{'repos'}; - - foreach my $repo ( keys( %$repos ) ) { - my $repopath = "$self->{'config'}{$source}{'url'}" - . "/$repo"; - my $file = "$SL::sl->{'srcdir'}/$source/" - . "$repo-packages.gz"; - my $gz = gzopen( $file, 'r' ) || - SL->error( int( $! ), "gzopen: $file: $!" ); - my $buff; - my $pkg = {}; - - while ( $gz->gzreadline( $buff ) ) { - if ( $pkg->{'name'} && - ! $self->{'pkgs'}{$pkg->{'name'}} ) { - $self->{'pkgs'}{$pkg->{'name'}} = []; - } - - if ( $buff =~ /^name:\s*(.*)$/ ) { - $pkg = {}; - $pkg->{'name'} = $1; - } - elsif ( $buff =~ /^(\S+):\s+(.*)$/ ) { - $pkg->{$1} = $2; - } - elsif ( $buff =~ /^$/ && $pkg->{'name'} ) { - $pkg->{'source'} = $source; - $pkg->{'path'} = $repopath - . "/$pkg->{'path'}"; - - push( @{$self->{'pkgs'}{$pkg->{'name'}}} - ,SL::Package->new( $pkg ) ); - - $pkg = {}; - } - elsif ( $buff =~ /^$/ ) { - next; - } - else { - SL->error( -1, "readpkgs():" - . "$file: malformed package" - . " list" ); - } - } - - $gz->gzclose(); - } - } - - return( 1 ); - } - -sub refresh { - my $self = shift; - my $cnt; - - foreach my $srcname ( sort { $self->{'config'}{$a}{'order'} <=> - $self->{'config'}{$b}{'order'} }( keys( %{$self->{'config'}} ) ) ) { - my $source = $self->{'config'}{$srcname}; - my $srcdir = "$SL::sl->{'srcdir'}/$srcname"; - - if ( ! -d $srcdir ) { - mkdir( $srcdir, 0755 ) || SL->error( int( $! ), - "mkdir(): $srcdir: $!" ); - } - - if ( $cnt ) { - print "\n"; - } - - print "Refreshing $srcname\n\n"; - - foreach my $repo ( sort( keys( %{$source->{'repos'}} ) ) ) { - my $remotepkgs = "$source->{'url'}/" - . "/$repo-packages.gz"; - my $remotesha256 = "$source->{'url'}/" - . "/$repo-packages.gz.sha256"; - my $localpkgs = "$srcdir/$repo-packages.gz"; - my $shaget = SL->httpget( $remotesha256, 0, 0644 ); - - SL->httpget( $remotepkgs, $localpkgs, 0644 ); - - if ( SL->sha256( $localpkgs ) ne $shaget ) { - SL->error( -1, "sha256(): incorrect SHA256" - . " calculated for $localpkgs!" ); - } - } - - $cnt++; - } - } - -### search() ############################################### -# -# This searches the packages from all sources and returns -# an array reference with all matching packages. Should -# be generally accepting of regex type stuff -# -# It seems to me to be a bit kludgy, I'd like to make it -# more elegant, but it works for now... -# -# If $opts->{'all'} isn't set (as in with arg -a/--all) and -# there is an exact match with a package name in the search -# string the most recent version of the package is returned. -# -############################################################ - -sub search { - my $self = shift; - my $opts = shift; - my $packages = []; - my $cnt; - - if ( ! $opts->{'all'} && ! $opts->{'keys'} && $opts->{'search'} && - $self->{'pkgs'}{$opts->{'search'}} ) { - return( [ $self->{'pkgs'}{$opts->{'search'}}[-1] ] ); - } - - if ( $opts->{'keys'} ) { - foreach ( split( /,| /, $opts->{'keys'} ) ) { - if ( $_ =~ /^(\S+):(\S+)$/ ) { - if ( ! grep( $_ eq $1, - &SL::Package::FIELDS ) ) { - SL->error( -1, "search(): $1:" - . " Invalid key\n" ); - } - - $opts->{$1} = $2; - } - } - } - - if ( $opts->{'search'} && $opts->{'search'} =~ - /^([a-zA-Z0-9]+)([<>=]+\S+)/ ) { - $opts->{'name'} = $1; - $opts->{'version'} = $2; - } - - foreach my $pkgname ( sort( keys( %{$self->{'pkgs'}} ) ) ) { - my $package; - - if ( $opts->{'name'} && $pkgname ne $opts->{'name'} ) { - next; - } - - foreach ( sort { SL->vercmp( $a->{'version'}, - $b->{'version'} ) } ( @{$self->{'pkgs'}{$pkgname}} ) ) { - if ( $opts->{'version'} && $opts->{'version'} =~ - /^((<|>)=?|=)\s*(.*)/ ) { - my $op = $1; - my $ver = $3; - my $chk = SL->vercmp( $_->{'version'}, $ver ); - - if ( $op eq '<' && $chk != -1 ) { - next; - } - if ( $op eq '<=' && $chk > 0 ) { - next; - } - if ( $op eq '>' && $chk != 1 ) { - next; - } - if ( $op eq '>=' && $chk < 0 ) { - next; - } - if ( $op eq '=' && $chk != 0 ) { - next; - } - } - elsif ( $opts->{'version'} && $_->{'version'} ne - $opts->{'version'} ) { - next; - } - elsif ( $opts->{'depends'} && $_->{'depends'} !~ - /$opts->{'depends'}/ ) { - next; - } - elsif ( $opts->{'source'} && $_->{'source'} ne - $opts->{'source'} ) { - next; - } - elsif ( $opts->{'repo'} && $_->{'repo'} ne - $opts->{'repo'} ) { - next; - } - elsif ( $opts->{'search'} && ( $_->{'name'} !~ - /$opts->{'search'}/ && $_->{'description'} !~ - /$opts->{'search'}/ ) ) { - next; - } - - if ( $opts->{'all'} ) { - push( @$packages, $_ ); - } - elsif ( ! $package || SL->vercmp( $_->{'version'}, - $package->{'version'} ) ) { - $package = $_; - } - } - - if ( $package ) { - push( @$packages, $package ); - } - } - - return( $packages ); - } - -1; - -=head1 NAME - -SL::Sources - Interface for Snaplinux package sources - -=head1 DESCRIPTION - -This module is not intended to be used directly, rather it is included with the parent SL.pm module. It is separated into its own module only to logically separate the code. - -SL::Sources includes all functions for retrieving, parsing, and searching through package lists. The structure of package objects is defined in SL::Package. - -=head1 METHODS - -=head2 new - - $sources = SL::Sources->new( $arrayref ) - -If $arrayref contains a list of valid sources the $sources object will be built. The $arrayref is intended to be populated with values parsed from /etc/sl.conf. The syntax for sources is as follows: - - [sources] - source1 = http://packages.snaplinux.org core dev util - -Each item listed under the [sources] section is added to $sources->{'config'}. The following describes the structure: - - $sources => { - config => { - source1 => { - url => 'http://packages.snaplinux.org/0.1', - order => 1, - repos => { - dev => {}, - core => {}, - util => {} - -=head2 readpkgs - - $sources->readpkgs() - -Parses all source/repo files and builds a list of packages which is available in $sources->{'pkgs'}. Also reads all installed and removed packages and adds them to $sources->{'status'}. The list is built with the following structure: - - $sources => { - pkgs => { - => [ - SL::Package->{'version'} => 1 - SL::Package->{'version'} => 2 - ] - } - installed => { - => SL::Package - -=head2 search - - $sources->search( $searchterms ) - -This will search all sources and repos in the $sources object for the search terms and either print the output, or if { quiet => 1 } is supplied as an arg it will return the highest version of the matched package. The quiet option is only intended for internal routines rather than for queries intended to display output on the command line. - -Other available options that can be set (using key => value pairs): - -=over 4 - -=item name - -This will only return packages where the name matches exactly - -=item version - -The operators <, <=, >, >=, = can all be used to retrieve the desired package version. The operator should preface the version string. - -=item depends - -The supplied string will be used as a patter to match dependencies in packages. - -=item source - -Return only packages available from the specified source. - -=item repo - -Return only packages from the specified repo - -=item string - -The supplied string will be used to match against either the package name, or the package description. - -=back - -=head2 refresh - - $sources->refresh() - -This will download all package information for the repos defined in $sources->{'config'}. The data will be stored in /var/lib/sl/sources/ - -=cut - diff --git a/ROOT/usr/share/sl/Makefile.skel b/ROOT/usr/share/sl/Makefile.skel deleted file mode 100644 index 1049c34..0000000 --- a/ROOT/usr/share/sl/Makefile.skel +++ /dev/null @@ -1,136 +0,0 @@ -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 as -# published by the Free Software Foundation here: -# (http://www.gnu.org/licenses/gpl-2.0.html) -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. - -# Some, but not all of variables are required. The following list -# describes the required variables: -# -# * URL: The main website of the upstream project -# * REPO: The location of the package on the source pacakge -# server. This might be one of core, main, dev, or -# perhaps others. -# * BRIEF: Short description, should be 50 chars or less -# * SLVER: This is the package version. When a package is -# changed, but no changes are made to the source code -# this value should be increased. This would include -# things like usher being modified, changes to default -# configuration files, file permissions, etc. -# * ARCHIVE: The default commands that set this variable should -# work in most cases, but in some cases it may need -# to be modified. This variable should contain the -# path to the source of the package (./SRC/filename) -# * TYPE: This is probably not really needed due to the -# ability of gnu tar to figure it out on its own. -# Should probably be removed at some point. -# * SRCDIR: This is the name of the source directory after the -# package source is extracted. The default command -# should in most cases set this automatically. -# * PATCHDIR: This directory should be ./SRC/patches and is -# required, whether or not patches are used. -# * VERSION: This should be set automatically based on the -# version string in the source directory and SLVER. -# The default command here should work in many cases, -# but certain packages may need to use a different -# method. -# -# Variables that aren't required: -# -# * ARCH: This should be populated for packages which contain -# compiled binaries. If it is not populated the ARCH -# will be set to 'noarch'. -# * DEPENDS: If any other packages are required for this package -# to function then they need to be listed here, -# preferably in alphabetical order. -# * BUILDDEPS: Any package beyond packages from the core repo -# need to be listed here. The idea is that we -# can automate building and testing packages -# from clean core systems. The core repo is -# intended to include only the base minimum -# packages which provide a functional system. -# * SRCPKG: By default this is populated automatically with -# the name of the package (current directory). If -# the source package is used to generate multiple -# packages then this variable should contain the -# name of the git repo that tracks the source. -# * DESC: This is to be used to provide a longer description -# of the package. - -ARCH = -DEPENDS = -BUILDDEPS = -SRCPKG = -URL = -REPO = -BRIEF = -DESC = -SLVER = - -ARCHIVE := $(PWD)/SRC/$(shell ls SRC|egrep '(bz2|gz|tar|xz)$$'|tail -1) -TYPE := $(shell file -ib $(ARCHIVE)|cut -d';' -f1|tr -d '\n') -SRCDIR := $(shell tar -tf $(ARCHIVE)|head -1|sed 's/\/.*//') -PATCHDIR := $(PWD)/SRC/patches -VERSION := $(shell echo $(SRCDIR)|egrep -o '\-[0-9].*'|sed 's/^-//')-$(SLVER) - -include /usr/share/sl/Makefile.snaplinux - -$(SRCDIR)/configure: $(ARCHIVE) - @if [ '$(TYPE)' == 'application/x-bzip2' ]; then \ - tar -jxf $(ARCHIVE); \ - elif [ '$(TYPE)' == 'application/x-gzip' ]; then \ - tar -zxf $(ARCHIVE); \ - elif [ '$(TYPE)' == 'application/x-tar' ]; then \ - tar -xf $(ARCHIVE); \ - elif [ '$(TYPE)' == 'application/x-xz' ]; then \ - tar -xf $(ARCHIVE); \ - else \ - echo 'Unable to determine archive type'; \ - exit 1; \ - fi - @touch $(SRCDIR)/configure - -$(SRCDIR)/config.log: $(SRCDIR)/configure - @cd $(SRCDIR) && \ - for patch in `find $(PATCHDIR) -name \*.patch|sort`; do \ - patch --verbose -Np1 -i $$patch; \ - done - @cd $(SRCDIR); \ - ./configure \ - --prefix=/usr \ - --build=x86_64-snap-linux-gnu \ - --host=x86_64-snap-linux-gnu \ - --target=x86_64-snap-linux-gnu - -# binfile should be replaced with a file generated by the -# make process. It won't really break anything if not -# set to a valid file, but the source make process will -# be re-executed even if it isn't necessary - -$(SRCDIR)/binfile: $(SRCDIR)/config.log - @cd $(SRCDIR) && make - -$(ROOT): $(SRCDIR)/binfile - @if [ -d $(ROOT) ]; then \ - touch $(ROOT); \ - else \ - mkdir -v $(ROOT); \ - fi - - @cd $(SRCDIR) && make install DESTDIR=$(ROOT) - -test: $(ROOT) - @cd $(SRCDIR); \ - make check - -clean: - @rm -rvf $(ROOT) \ - $(SLINFO) \ - $(MANIFEST) \ - $(FILES) \ - $(SRCDIR) - diff --git a/ROOT/usr/share/sl/Makefile.snaplinux b/ROOT/usr/share/sl/Makefile.snaplinux deleted file mode 100644 index acfb578..0000000 --- a/ROOT/usr/share/sl/Makefile.snaplinux +++ /dev/null @@ -1,180 +0,0 @@ -# This file is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License version 2 as -# published by the Free Software Foundation here: -# (http://www.gnu.org/licenses/gpl-2.0.html) -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. - -export SHELL := /bin/bash - -PWD := $(shell pwd) -SLDIR = $(PWD)/SL -ROOT = $(PWD)/ROOT - -# This will set PACKAGE to the name of the current working directory -# if the package itself has not provided a package name - -ifndef PACKAGE -PACKAGE := $(shell echo $(PWD)|sed 's/.*\///') -endif - -# If VERSION is not set then we must fail - -ifndef VERSION -$(error VERSION is not set) -endif - -# This defines the name of the package file unless -# it is already specified in the package Makefile - -ifndef PKGFILE -PKGFILE := $(PACKAGE)-$(VERSION).slp -endif - -# If ARCH is not set we will assume noarch - -ifndef ARCH -ARCH := noarch -endif - -# SRCPKG defines the git repo name from which the package -# is built. In many cases it should be the same as the -# package name, but in cases where multiple packages are -# built from the same source this is especially relevant. - -ifndef SRCPKG -SRCPKG := $(PACKAGE) -endif - -# URL is required - this should point to the upstream project - -ifndef URL -$(error URL is not set) -endif - -# REPO is required. This value is used to determine the -# location of the package on the package source server - -ifndef REPO -$(error REPO is not set) -endif - -SLINFO = $(SLDIR)/slinfo -MANIFEST = $(SLDIR)/manifest -USHER = $(SLDIR)/usher -FILES = $(SLDIR)/files.tar.gz - -# BRIEF is required. - -ifndef BRIEF -$(error BRIEF is not set) -endif - -$(PKGFILE): $(SLINFO) $(FILES) - @if [ -f $(PKGFILE) ]; then \ - rm -v $(PKGFILE); \ - fi - - @ar cvr $(PKGFILE) $(SLINFO) $(MANIFEST); \ - if [ -f $(USHER) ]; then \ - chmod +x $(USHER); \ - ar cvr $(PKGFILE) $(USHER); \ - fi; \ - ar cvr $(PKGFILE) $(FILES) - - @echo "Successfully built $(PKGFILE)" - -$(SLINFO): $(MANIFEST) - @>$(SLINFO) - $(eval BYTES := $(shell gzip -l $(FILES)|tail -1|awk '{print $$2}')) - $(eval SHA256MAN := $(shell sha256sum $(MANIFEST)|awk '{print $$1}')) - - @fields=( \ - "name: $(PACKAGE)" \ - "version: $(VERSION)" \ - "arch: $(ARCH)" \ - "depends: $(DEPENDS)" \ - "builddeps: $(BUILDDEPS)" \ - "srcpkg: $(SRCPKG)" \ - "bytes: $(BYTES)" \ - "url: $(URL)" \ - "repo: $(REPO)" \ - "sha256man: $(SHA256MAN)" \ - "brief: $(BRIEF)" \ - "description: $(DESC)" \ - ) && \ - for field in "$${fields[@]}"; do \ - printf "$$field\n"; \ - done > $(SLINFO) - -$(MANIFEST): $(FILES) - @>$(MANIFEST) - - @rootfiles=`cd $(ROOT) && find ! -path .|sed 's/^\.\///'|sort -r` && \ - while read -r file; do \ - info=`ls -ld "$(ROOT)/$$file"`; \ - perm=`echo $$info|awk '{print $$1}'`; \ - type=`echo $$perm|head -c1`; \ - sha='________________________________________'; \ - if [ $$type = 'c' ]; then \ - size=0; \ - fi; \ - if [ -f "$(ROOT)/$$file" ]; then \ - sha=`sha1sum "$(ROOT)/$$file"|awk '{print $$1}'`; \ - fi; \ - printf "$$sha\t$$perm\t$$file\n" >> $(MANIFEST); \ - done <<< "$$rootfiles" - -$(FILES): $(ROOT) -# Remove any perllocal.pod to avoid conflicts -# Should try to properly fix this some time... - @find $(ROOT) -name perllocal.pod -exec rm {} \; - - @if [ -d $(ROOT)/usr/share/man ]; then \ - find $(ROOT)/usr/share/man -type f -not -name \*.gz| \ - while read -r file; do \ - gzip $$file; \ - done; \ - find $(ROOT)/usr/share/man -type l| \ - while read -r file; do \ - target=`readlink $$file`; \ - path=`dirname $$file`; \ - full="$$path/$$target"; \ - if [ ! -f $$full ] && [ -f $$full.gz ]; then \ - ln -sf $$target.gz $$file; \ - fi; \ - done; \ - fi - - @if [ -d $(ROOT)/usr/share/info ]; then \ - find $(ROOT)/usr/share/info -name '*.info' -o \ - -name '*.info-[0-9]*'|while read -r file; do \ - gzip $$file; \ - done; \ - if [ -f $(ROOT)/usr/share/info/dir ]; then \ - rm -v $(ROOT)/usr/share/info/dir; \ - fi; \ - fi - - @find $(ROOT) -type f | while read -r file; do \ - type=`file -i $$file|sed 's/.*: //'`; \ - case $$type in \ - *'/x-executable; charset=binary') \ - echo "--strip-unneeded $$file"; \ - strip --strip-unneeded $$file \ - ;; \ - *'/x-object; charset=binary') \ - echo "--strip-debug $$file"; \ - strip --strip-debug $$file \ - ;; \ - *'/x-sharedlib; charset=binary') \ - echo "--strip-debug $$file"; \ - strip --strip-debug $$file \ - ;; \ - esac; \ - done - @cd $(ROOT) && tar cvzf $(FILES) * - diff --git a/SL/files.tar.gz b/SL/files.tar.gz deleted file mode 100644 index 43cb9b2..0000000 Binary files a/SL/files.tar.gz and /dev/null differ diff --git a/SL/manifest b/SL/manifest deleted file mode 100644 index f7ab404..0000000 --- a/SL/manifest +++ /dev/null @@ -1,27 +0,0 @@ -6c7fd33ea7498d8fceb4fae8c5253d00ca12a2ca -rw-r--r-- usr/share/sl/Makefile.snaplinux -f280e4828f64bc9b6166f90573ef6bf6c2a0a79f -rw-r--r-- usr/share/sl/Makefile.skel -________________________________________ drwxr-xr-x usr/share/sl -________________________________________ drwxr-xr-x usr/share -983e13980dab92c1a643cc371f9fc8c4b89d2241 -rw-r--r-- usr/lib/perl5/vendor_perl/5.24.0/SL/Sources.pm -094aeef2123f70de7628b6c21a48eb277586e910 -rw-r--r-- usr/lib/perl5/vendor_perl/5.24.0/SL/Package.pm -d7dfae002a00995eb75cbd53076c3dfed9545a39 -rw-r--r-- usr/lib/perl5/vendor_perl/5.24.0/SL/Commands.pm -e9ff59a2e73d49bb4b72fc802707f1125342aba7 -rw-r--r-- usr/lib/perl5/vendor_perl/5.24.0/SL.pm -________________________________________ drwxr-xr-x usr/lib/perl5/vendor_perl/5.24.0/SL -________________________________________ drwxr-xr-x usr/lib/perl5/vendor_perl/5.24.0 -________________________________________ drwxr-xr-x usr/lib/perl5/vendor_perl -________________________________________ drwxr-xr-x usr/lib/perl5 -________________________________________ drwxr-xr-x usr/lib -935d38bc282b82ff603bf9587539fc8c80b2c4ff -rwxr-xr-x usr/bin/slinstall -e652e3c122196a53a8c274ddf874665f4c772a93 -rwxr-xr-x usr/bin/sl -________________________________________ drwxr-xr-x usr/bin -________________________________________ drwxr-xr-x usr -________________________________________ drwxr-xr-x etc/sl.d/templates/server/rootfs -cf93b606a51e1987fc183670a99a5a2e3a4455bd -rw-r--r-- etc/sl.d/templates/server/postinst -22f8fffa7742fe7a8967d6bd5715428d27b27ee3 -rw-r--r-- etc/sl.d/templates/server/packages -________________________________________ drwxr-xr-x etc/sl.d/templates/server -________________________________________ drwxr-xr-x etc/sl.d/templates/container/rootfs -e2e641ddea8abeaadecc3c23bdcc07c9b6c6ed2d -rw-r--r-- etc/sl.d/templates/container/packages -________________________________________ drwxr-xr-x etc/sl.d/templates/container -________________________________________ drwxr-xr-x etc/sl.d/templates -________________________________________ drwxr-xr-x etc/sl.d -________________________________________ drwxr-xr-x etc diff --git a/SL/slinfo b/SL/slinfo deleted file mode 100644 index d3507ea..0000000 --- a/SL/slinfo +++ /dev/null @@ -1,12 +0,0 @@ -name: sl -version: 0.15-0 -arch: x86_64 -depends: binutils,coreutils,gzip,perl>=5.20.0,tar -builddeps: -srcpkg: sl -bytes: 163840 -url: http://snaplinux.org -repo: core -sha256man: 987dccaedf78807ea98f4c19e9f36ce2a7d56899d405579083504eb32ea04375 -brief: The Snaplinux package management system -description: The Snaplinux package management system diff --git a/SRC/sl/SL.pm b/SRC/sl/SL.pm index 2b09c20..4cdf274 100644 --- a/SRC/sl/SL.pm +++ b/SRC/sl/SL.pm @@ -40,7 +40,7 @@ our @EXPORT = qw( $sl ); -our $VERSION = '0.15'; +our $VERSION = '0.16'; ############################################################ # diff --git a/SRC/sl/sl b/SRC/sl/sl index 0295663..05c8b1e 100755 --- a/SRC/sl/sl +++ b/SRC/sl/sl @@ -633,7 +633,7 @@ elsif ( $command eq 'install' ) { $string = "coreutils $string"; } if ( ! installed( 'sl-base' ) ) { - $string =~ 's/(^|\s+)sl-base(\s+|$)//g'; + $string =~ s/(^|\s*)sl-base(\s*|$)//g; $string = "sl-base $string"; }