diff options
Diffstat (limited to 'SBO-Lib/lib')
| -rw-r--r-- | SBO-Lib/lib/SBO/App.pm | 26 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/App/Remove.pm | 224 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/App/Snap.pm | 95 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib.pm | 99 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Build.pm | 772 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Cryptography.pm | 213 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Download.pm | 299 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Info.pm | 234 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Pkgs.pm | 198 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Readme.pm | 220 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Repo.pm | 485 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Tree.pm | 161 | ||||
| -rw-r--r-- | SBO-Lib/lib/SBO/Lib/Util.pm | 566 | ||||
| -rw-r--r-- | SBO-Lib/lib/Sort/Versions.pm | 162 |
14 files changed, 0 insertions, 3754 deletions
diff --git a/SBO-Lib/lib/SBO/App.pm b/SBO-Lib/lib/SBO/App.pm deleted file mode 100644 index d8de5c6..0000000 --- a/SBO-Lib/lib/SBO/App.pm +++ /dev/null @@ -1,26 +0,0 @@ -package SBO::App; - -# vim: ts=2:et -# -# authors: Luke Williams <xocel@iquidus.org> -# Jacob Pipkin <j@dawnrazor.net> -# Andreas Guldstrand <andreas.guldstrand@gmail.com> -# maintainer: Slack Coder <slackcoder@server.ky> - -use 5.16.0; -use strict; -use warnings FATAL => 'all'; -use File::Basename; - -our $VERSION = '2.8.0'; - -sub new { - my $class = shift; - - my $self = $class->_parse_opts(@_); - $self->{fname} = basename( (caller(0))[1] ); - - return bless $self, $class; -} - -1; diff --git a/SBO-Lib/lib/SBO/App/Remove.pm b/SBO-Lib/lib/SBO/App/Remove.pm deleted file mode 100644 index 7b0d27f..0000000 --- a/SBO-Lib/lib/SBO/App/Remove.pm +++ /dev/null @@ -1,224 +0,0 @@ -package SBO::App::Remove; - -# vim: ts=2:et -# -# authors: Luke Williams <xocel@iquidus.org> -# Jacob Pipkin <j@dawnrazor.net> -# Andreas Guldstrand <andreas.guldstrand@gmail.com> -# maintainer: Slack Coder <slackcoder@server.ky> - -use 5.16.0; -use strict; -use warnings FATAL => 'all'; -use SBO::Lib qw/ _ERR_USAGE get_inst_names get_installed_packages get_sbo_location get_build_queue merge_queues get_requires get_readme_contents prompt show_version in /; -use Getopt::Long qw(GetOptionsFromArray :config bundling); - -use parent 'SBO::App'; - -our $VERSION = '2.8.0'; - -sub _parse_opts { - my $class = shift; - my @ARGS = @_; - - my ($help, $vers, $non_int, $alwaysask); - - GetOptionsFromArray( - \@ARGS, - 'help|h' => \$help, - 'version|v' => \$vers, - 'nointeractive' => \$non_int, - 'alwaysask|a' => \$alwaysask, - ); - - return { help => $help, vers => $vers, non_int => $non_int, alwaysask => $alwaysask, args => \@ARGS, }; -} - -sub run { - my $self = shift; - - if ($self->{help}) { $self->show_usage(); return 0; } - if ($self->{vers}) { $self->show_version(); return 0; } - if (!@{ $self->{args} }) { $self->show_usage(); return 1; } - - unless ($< == 0) { - warn "This script requires root privileges.\n"; - exit _ERR_USAGE; - } - - # current workflow: - # * get names of all installed SBo packages - # * compare commandline args to SBo packages as well as installed SBo packages - # * add reverse deps to list if they're not a dep of something else (which is not also already on the list) - # * confirm removal of each package on the list - # - while taking into account the options passed in such as $non_int, and $alwaysask - # - also offering to display README if %README% is passed - # * remove the confirmed packages - - my @args = @{ $self->{args} }; - - my @installed = @{ get_installed_packages('SBO') }; - my $installed = +{ map {; $_->{name}, $_->{pkg} } @installed }; - - @args = grep { check_sbo($_, $installed) } @args; - exit 1 unless @args; - my %sbos = map { $_ => 1 } @args; - - my @remove = get_full_queue($installed, @args); - - my @confirmed; - - if ($self->{non_int}) { - @confirmed = @remove; - } else { - my $required_by = get_reverse_reqs($installed); - for my $remove (@remove) { - # if $remove was on the commandline, mark it as not needed, - # otherwise check if it is needed by something else. - my @required_by = get_required_by($remove->{name}, [map { $_->{name} } @confirmed], $required_by); - my $needed = $sbos{$remove->{name}} ? 0 : @required_by; - - next if $needed and not $self->{alwaysask}; - - push @confirmed, $remove if confirm($remove, $needed ? @required_by : ()); - } - } - - if (@confirmed) { - $self->remove(@confirmed); - } else { - say "Nothing to remove."; - } - - return 0; -} - -sub show_usage { - my $self = shift; - my $fname = $self->{fname}; - - print <<"EOF"; -Usage: $fname [options] sbo - -Options (defaults shown first where applicable): - -h|--help: - this screen. - -v|--version: - version information. - -a|--alwaysask: - always ask to remove, even if required by other packages on system. - -Note: optional dependencies need to be removed separately. - -EOF - return 1; -} - -sub check_sbo { - my ($sbo, $installed) = @_; - - if (not get_sbo_location($sbo)) { - say "Unable to locate $sbo in the SlackBuilds.org tree."; - return 0; - } - - if (not exists $installed->{$sbo}) { - say "$sbo is not installed from SlackBuilds.org."; - return 0; - } - - return 1; -} - -sub get_full_queue { - my ($installed, @sbos) = @_; - - my $remove_queue = []; - my %warnings; - for my $sbo (@sbos) { - my $queue = get_build_queue([$sbo], \%warnings); - @$queue = reverse @$queue; - $remove_queue = merge_queues($remove_queue, $queue); - } - - return map {; +{ - name => $_, - pkg => $installed->{$_}, - defined $warnings{$_} ? (warning => $warnings{$_}) : () - } } - grep { exists $installed->{$_} } - @$remove_queue; -} - -sub get_reverse_reqs { - my $installed = shift; - my %required_by; - - for my $inst (keys %$installed) { - for my $req (@{ get_requires($inst) }) { - $required_by{$req}{$inst} = 1 if exists $installed->{$req}; - } - } - - return \%required_by; -} - -sub get_required_by { - my ($sbo, $confirmed, $required_by) = @_; - my @dep_of; - - if ( $required_by->{$sbo} ) { - for my $req_by (keys %{$required_by->{$sbo}}) { - push @dep_of, $req_by unless in($req_by => @$confirmed); - } - } - return @dep_of; -} - -sub confirm { - my ($remove, @required_by) = @_; - - if (@required_by) { - say sprintf "%s : required by %s", $remove->{name}, join ' ', @required_by; - } else { - say $remove->{name}; - } - - if ($remove->{warning}) { - say "It is recommended that you view the README before continuing."; - if (prompt("Display README now?", default => 'yes')) { - my $readme = get_readme_contents(get_sbo_location($remove->{name})); - if (not defined $readme) { - warn "Unable to open README for $remove->{name}.\n"; - } else { - print "\n" . $readme; - } - } - } - - if (prompt("Remove $remove->{name}?", default => @required_by ? 'no' : 'yes')) { - say " * Added to remove queue\n"; - return 1; - } - say " * Ignoring\n"; - return 0; -} - -sub remove { - my $self = shift; - my $non_int = $self->{non_int}; - my @confirmed = @_; - - say sprintf "Removing %d package(s)", scalar @confirmed; - say join " ", map { $_->{name} } @confirmed; - - if (!$non_int and !prompt("\nAre you sure you want to continue?", default => 'no')) { - return say 'Exiting.'; - } - - system("/sbin/removepkg", $_->{pkg}) for @confirmed; - - say "All operations have completed successfully."; -} - -1; diff --git a/SBO-Lib/lib/SBO/App/Snap.pm b/SBO-Lib/lib/SBO/App/Snap.pm deleted file mode 100644 index 64487d7..0000000 --- a/SBO-Lib/lib/SBO/App/Snap.pm +++ /dev/null @@ -1,95 +0,0 @@ -package SBO::App::Snap; - -# vim: ts=2:et -# -# sbosnap -# script to pull down / update a local copy of the slackbuilds.org tree. -# -# authors: Jacob Pipkin <j@dawnrazor.net> -# Luke Williams <xocel@iquidus.org> -# Andreas Guldstrand <andreas.guldstrand@gmail.com> -# maintainer: Slack Coder <slackcoder@server.ky> - -use 5.16.0; -use strict; -use warnings FATAL => 'all'; -use SBO::Lib qw/ _ERR_USAGE fetch_tree import_gpg_key update_tree %config show_version /; -use Getopt::Long qw/ GetOptionsFromArray /; - -use parent 'SBO::App'; - -our $VERSION = '2.8.0'; - -sub _parse_opts { - my $class = shift; - my @ARGS = @_; - - my ($help, $vers); - - GetOptionsFromArray( - \@ARGS, - 'help|h' => \$help, - 'version|v' => \$vers, - ); - - return { help => $help, vers => $vers, args => \@ARGS, }; -} - -sub show_usage { - my $self = shift; - my $fname = $self->{fname}; - print <<"EOF"; -Usage: $fname [options|command] - -Options: - -h|--help: - this screen. - -v|--version: - version information. - -Commands: - fetch: initialize a local copy of the slackbuilds.org tree. - import-key [path or url]: import GPG for verifying the slackbuilds.org tree. Defaults to the key shipped with sbotools2. - update: update an existing local copy of the slackbuilds.org tree. - (generally, you may prefer "sbocheck" over "$fname update") - -EOF - return 1; -} - -sub run { - my $self = shift; - my @args = @{ $self->{args} }; - - if ($self->{help}) { $self->show_usage(); return 0 } - if ($self->{vers}) { $self->show_version(); return 0 } - - unless ($< == 0) { - warn "This script requires root privileges.\n"; - exit _ERR_USAGE; - } - - # check for a command and, if found, execute it - $args[0] //= ''; - - if ($args[0] eq 'fetch') { - fetch_tree(); - } elsif ($args[0] eq 'import-key') { - my $key_path_or_url = "/usr/doc/sbotools2-$VERSION/slackbuilds-devel\@slackbuilds.org.asc"; - if ($args[1]) { - $key_path_or_url = $args[1]; - } - my $key_id = $config{'GPG_KEY'}; - - import_gpg_key($key_path_or_url, $key_id); - } elsif ($args[0] eq 'update') { - update_tree(); - } else { - $self->show_usage(); - return 1; - } - - return 0; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib.pm b/SBO-Lib/lib/SBO/Lib.pm deleted file mode 100644 index b249dc6..0000000 --- a/SBO-Lib/lib/SBO/Lib.pm +++ /dev/null @@ -1,99 +0,0 @@ -#!/usr/bin/env perl -# -# vim: set ts=4:noet -# -# Lib.pm -# shared functions for the sbo_ scripts. -# -use 5.16.0; -use strict; -use warnings FATAL => 'all'; - -package SBO::Lib; -our $VERSION = '2.8.0'; - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib - Library for working with SlackBuilds.org. - -=head1 SYNOPSIS - - use SBO::Lib qw/ :all /; - -=head1 DESCRIPTION - -SBO::Lib is the entry point for all the related modules, and is simply re- -exporting all of their exports. - -=head1 SEE ALSO - -=over - -=item L<SBO::Lib::Cryptography> - -=item L<SBO::Lib::Util> - -=item L<SBO::Lib::Info> - -=item L<SBO::Lib::Repo> - -=item L<SBO::Lib::Tree> - -=item L<SBO::Lib::Pkgs> - -=item L<SBO::Lib::Build> - -=item L<SBO::Lib::Readme> - -=item L<SBO::Lib::Download> - -=back - -=cut - -use SBO::Lib::Cryptography qw/ :all /; -use SBO::Lib::Util qw/ :all /; -use SBO::Lib::Info qw/ :all /; -use SBO::Lib::Repo qw/ :all /; -use SBO::Lib::Tree qw/ :all /; -use SBO::Lib::Pkgs qw/ :all /; -use SBO::Lib::Build qw/:all /; -use SBO::Lib::Readme qw/ :all /; -use SBO::Lib::Download qw/ :all /; - -use Exporter 'import'; - -our @EXPORT_OK = ( - @SBO::Lib::Cryptography::EXPORT_OK, - @SBO::Lib::Util::EXPORT_OK, - @SBO::Lib::Info::EXPORT_OK, - @SBO::Lib::Repo::EXPORT_OK, - @SBO::Lib::Tree::EXPORT_OK, - @SBO::Lib::Pkgs::EXPORT_OK, - @SBO::Lib::Build::EXPORT_OK, - @SBO::Lib::Readme::EXPORT_OK, - @SBO::Lib::Download::EXPORT_OK, -); - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, - cryptography => \@SBO::Lib::Cryptography::EXPORT_OK, - util => \@SBO::Lib::Util::EXPORT_OK, - info => \@SBO::Lib::Info::EXPORT_OK, - repo => \@SBO::Lib::Repo::EXPORT_OK, - tree => \@SBO::Lib::Tree::EXPORT_OK, - pkgs => \@SBO::Lib::Pkgs::EXPORT_OK, - build => \@SBO::Lib::Build::EXPORT_OK, - readme => \@SBO::Lib::Readme::EXPORT_OK, - download => \@SBO::Lib::Download::EXPORT_OK, - const => $SBO::Lib::Util::EXPORT_TAGS{const}, - config => $SBO::Lib::Util::EXPORT_TAGS{config}, -); - -'ok'; - -__END__ diff --git a/SBO-Lib/lib/SBO/Lib/Build.pm b/SBO-Lib/lib/SBO/Lib/Build.pm deleted file mode 100644 index 4a86e4d..0000000 --- a/SBO-Lib/lib/SBO/Lib/Build.pm +++ /dev/null @@ -1,772 +0,0 @@ -package SBO::Lib::Build; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ :const prompt script_error get_sbo_from_loc get_arch check_multilib uniq %config in /; -use SBO::Lib::Tree qw/ get_sbo_location /; -use SBO::Lib::Info qw/ get_sbo_version check_x32 get_requires /; -use SBO::Lib::Download qw/ get_sbo_downloads get_dl_fns get_filename_from_link check_distfiles /; - -use Exporter 'import'; -use Fcntl qw(F_SETFD F_GETFD); -use File::Copy; # copy() and move() -use File::Path qw/ make_path remove_tree /; -use File::Temp qw/ tempdir tempfile /; -use Tie::File; -use Cwd; - -our @EXPORT_OK = qw{ - do_convertpkg - do_slackbuild - do_upgradepkg - get_build_queue - get_dc_regex - get_pkg_name - get_src_dir - get_tmp_extfn - make_clean - make_distclean - merge_queues - perform_sbo - process_sbos - revert_slackbuild - rewrite_slackbuild - run_tee - - $tmpd - $env_tmp -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Build - Routines for building slackware packages from SlackBuilds.org. - -=head1 SYNOPSIS - - use SBO::Lib::Build qw/ perform_sbo /; - - my ($foo, $bar, $exit) = perform_sbo(LOCATION => $location, ARCH => 'x86_64'); - -=head1 VARIABLES - -=head2 $env_tmp - -This will reflect the C<$TMP> from the environment, being C<undef> if it is not -set. - -=head2 $tmpd - -Will be the same as C<$TMP> if it is set, otherwise it will be C</tmp/SBo>. - -=cut - -# get $TMP from the env, if defined - we use two variables here because there -# are times when we need to know if the environment variable is set, and other -# times where it doesn't matter. -our $env_tmp = $ENV{TMP}; -our $tmpd = $env_tmp ? $env_tmp : '/tmp/SBo'; -make_path($tmpd) unless -d $tmpd; - -=head1 SUBROUTINES - -=cut - -=head2 do_convertpkg - - my ($name32, $exit) = do_convertpkg($name64); - -C<do_convertpkg()> runs C<convertpkg> on the package in C<$name64>. - -It returns two values. If the second value is true, the first will contain an -error message. Otherwise it will contain the name of the converted package. - -=cut - -# run convertpkg on a package to turn it into a -compat32 thing -sub do_convertpkg { - script_error('do_convertpkg requires an argument.') unless @_ == 1; - my $pkg = shift; - my $c32tmpd = $env_tmp // '/tmp'; - - my ($out, $ret) = run_tee("/bin/bash -c '/usr/sbin/convertpkg-compat32 -i $pkg -d $c32tmpd'"); - - if ($ret != 0) { - return "convertpkg-compt32 returned non-zero exit status\n", - _ERR_CONVERTPKG; - } - unlink $pkg; - return get_pkg_name($out); -} - -=head2 do_slackbuild - - my ($ver, $pkg, $src, $exit) = do_slackbuild(LOCATION => $location); - -C<do_slackbuild()> will make some checks and set up the C<perform_sbo()> call, -if needed run C<do_convertpkg()>, and return the results. - -It will return a list of four values. If the fourth one is a true value, the -first one will be an error message. Otherwise the first will be the version, -the second will be the package, and the third will be an array reference to the -source directories created by the build. - -=cut - -# "public interface", sort of thing. -sub do_slackbuild { - my %args = ( - OPTS => 0, - JOBS => 0, - LOCATION => '', - COMPAT32 => 0, - @_ - ); - $args{LOCATION} or script_error('do_slackbuild requires LOCATION.'); - my $location = $args{LOCATION}; - my $sbo = get_sbo_from_loc($location); - my $arch = get_arch(); - my $multilib = check_multilib(); - my $version = get_sbo_version($location); - my $x32; - # ensure x32 stuff is set correctly, or that we're setup for it - if ($args{COMPAT32}) { - unless ($multilib) { - return "compat32 requires multilib.\n", (undef) x 2, - _ERR_NOMULTILIB; - } - unless (-f '/usr/sbin/convertpkg-compat32') { - return "compat32 requires /usr/sbin/convertpkg-compat32.\n", - (undef) x 2, _ERR_NOCONVERTPKG; - } - } else { - if ($arch eq 'x86_64') { - $x32 = check_x32 $args{LOCATION}; - if ($x32 && ! $multilib) { - my $warn = - "$sbo is 32-bit which requires multilib on x86_64.\n"; - return $warn, (undef) x 2, _ERR_NOMULTILIB; - } - } - } - # setup and run the .SlackBuild itself - my ($pkg, $src, $exit) = perform_sbo( - OPTS => $args{OPTS}, - JOBS => $args{JOBS}, - LOCATION => $location, - ARCH => $arch, - C32 => $args{COMPAT32}, - X32 => $x32, - ); - return $pkg, (undef) x 2, $exit if $exit; - if ($args{COMPAT32}) { - ($pkg, $exit) = do_convertpkg($pkg); - return $pkg, (undef) x 2, $exit if $exit; - } - return $version, $pkg, $src; -} - -=head2 do_upgradepkg - - do_upgradepkg($pkg); - -C<do_upgradepkg()> runs C<upgradepkg> on C<$pkg>. - -There is no useful return value. - -=cut - -# run upgradepkg for a created package -sub do_upgradepkg { - script_error('do_upgradepkg requires an argument.') unless @_ == 1; - system('/sbin/upgradepkg', '--reinstall', '--install-new', shift); - return 1; -} - -=head2 get_build_queue - - my @queue = @{ get_build_queue($sbo, my $warnings) }; - -C<get_build_queue()> gets the prerequisites for C<$sbo>, and updates the -C<$warnings> hash reference with any C<%README%> encountered. It returns the -prerequisites and the C<$sbo> in the order in which they need to be built. - -=cut - -sub get_build_queue { - script_error('get_build_queue requires two arguments.') unless @_ == 2; - return [ _build_queue(@_) ]; -} - -=head2 get_dc_regex - - my ($rx, $initial) = get_dc_regex($line); - -C<get_dc_regex()> when given a line that is an untar or similar command, creates -a regular expression which should match the filename. This is returned, together -with the C<$initial> character which will start the filename match. - -=cut - -# given a line that looks like it's decompressing something, try to return a -# valid filename regex -sub get_dc_regex { - my $line = shift; - # get rid of initial 'tar x'whatever stuff - $line =~ s/^.*(?<![a-z])(tar|p7zip|unzip|ar|rpm2cpio|sh)\s+[^\s]+\s+//; - # need to know preceeding character - should be safe to assume it's either - # a slash or a space - my $initial = $line =~ qr|/| ? '/' : ' '; - # get rid of initial path info - $line =~ s|^\$[^/]+/||; - # convert any instances of command substitution to [^-]+ - $line =~ s/\$\([^)]+\)/[^-]+/g; - # convert any bash variables to [^-]+ - $line =~ s/\$(\{|)[A-Za-z0-9_]+(}|)/[^-]+/g; - # get rid of anything excess at the end - $line =~ s/\s+.*$//; - # fix .?z* at the end - $line =~ s/\.\?z\*/\.[a-z]z.*/; - # return what's left as a regex - my $regex = qr/$initial$line/; - return $regex, $initial; -} - -=head2 get_pkg_name - - my $name = get_pkg_name($str); - -C<get_pkg_name()> searches C<$str> for text matching the output of C<makepkg> -where it outputs the filename of the package it made, and returns it. - -=cut - -# pull the created package name from the temp file we tee'd to -sub get_pkg_name { - my $str = shift; - - my ($out) = $str =~ m/^Slackware\s+package\s+([^\s]+)\s+created\.$/m; - - return $out; -} - -=head2 get_src_dir - - my @dirs = @{ get_src_dir(@orig_dirs) }; - -C<get_src_dir()> returns a list of the directories under C</tmp/SBo> or C<$TMP> -that aren't in @orig_dirs. - -=cut - -sub get_src_dir { - my @ls = @_; - my @src_dirs; - # scripts use either $TMP or /tmp/SBo - if (opendir(my $tsbo_dh, $tmpd)) { - FIRST: while (my $ls = readdir $tsbo_dh) { - next FIRST if in($ls => qw/ . .. /, qr/^package-/, @ls); - next FIRST unless -d "$tmpd/$ls"; - - push @src_dirs, $ls; - } - close $tsbo_dh; - } - return \@src_dirs; -} - -=head2 get_tmp_extfn - - my ($ret, $exit) = get_tmp_extfn($fh); - -C<get_tmp_extfn()> gets the filename in the form of C</dev/fd/X> for the C<$fh> -passed in, setting flags on it that make it usable from other processes without -messing things up. - -It returns the filename if successful, otherwise it returns C<undef>. - -=cut - -# return a filename from a temp fh for use externally -sub get_tmp_extfn { - script_error('get_tmp_extfn requires an argument.') unless @_ == 1; - my $fh = shift; - unless (fcntl($fh, F_SETFD, 0)) { return undef; } - return '/dev/fd/'. fileno $fh; -} - -=head2 make_clean - - make_clean(SBO => $sbo, SRC => $src, VERSION => $ver); - -C<make_clean()> removes source directories, package directories, and compat32 -directories that are left over from a slackbuild run. - -It has no useful return value. - -=cut - -# remove work directories (source and packaging dirs under /tmp/SBo or $TMP and /tmp or $OUTPUT) -sub make_clean { - my %args = ( - SBO => '', - SRC => '', - VERSION => '', - @_ - ); - unless ($args{SBO} && $args{SRC} && $args{VERSION}) { - script_error('make_clean requires three arguments.'); - } - my $src = $args{SRC}; - say "Cleaning for $args{SBO}-$args{VERSION}..."; - for my $dir (@$src) { - remove_tree("$tmpd/$dir") if -d "$tmpd/$dir"; - } - - my $output = $ENV{OUTPUT} // '/tmp'; - remove_tree("$output/package-$args{SBO}") if - -d "$output/package-$args{SBO}"; - - if ($args{SBO} =~ /^(.+)-compat32$/) { - my $pkg_name = $1; - remove_tree("/tmp/package-$args{SBO}") if - not defined $env_tmp and - -d "/tmp/package-$args{SBO}"; - remove_tree("$tmpd/package-$pkg_name") if - -d "$tmpd/package-$pkg_name"; - } - return 1; -} - -=head2 make_distclean - - make_distclean(SRC => $src, VERSION => $ver, LOCATION => $loc); - -C<make_distclean()> does everything C<make_clean()> does, but in addition it -also removes distribution files, such as the downloaded source tarballs. - -It has no useful return value. - -=cut - -# remove distfiles -sub make_distclean { - my %args = ( - SRC => '', - VERSION => '', - LOCATION => '', - @_ - ); - unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { - script_error('make_distclean requires four arguments.'); - } - my $sbo = get_sbo_from_loc($args{LOCATION}); - make_clean(SBO => $sbo, SRC => $args{SRC}, VERSION => $args{VERSION}); - say "Distcleaning for $sbo-$args{VERSION}..."; - # remove any distfiles for this particular SBo. - my $downloads = get_sbo_downloads(LOCATION => $args{LOCATION}); - for my $key (keys %$downloads) { - my $filename = get_filename_from_link($key); - unlink $filename if -f $filename; - } - return 1; -} - -=head2 merge_queues - - my @merged = @{ merge_queues([@queue1], [@queue2]) }; - -C<merge_queues> takes two array references and merges them with C<@queue1> in -front, and then anything in C<@queue2> that wasn't already in C<@queue1>. This -is then returned as an array reference. - -=cut - -sub merge_queues { - # Usage: merge_queues(\@queue_a, \@queue_b); - # Results in queue_b being merged into queue_a (without duplicates) - script_error('merge_queues requires two arguments.') unless @_ == 2; - - return [ uniq @{$_[0]}, @{$_[1]} ]; -} - -=head2 perform_sbo - - my ($pkg, $src, $exit) = perform_sbo(LOCATION => $location, ARCH => $arch); - -C<perform_sbo()> preps and runs a .SlackBuild. It returns a list of three -values, and if the third one is a true value, the first one will be an error -message. Otherwise the first one will be the package name that was built, and -the second one will be an array reference containing the source directories -that were created. - -=cut - -# prep and run .SlackBuild -sub perform_sbo { - my %args = ( - OPTS => 0, - JOBS => 0, - LOCATION => '', - ARCH => '', - C32 => 0, - X32 => 0, - @_ - ); - unless ($args{LOCATION} && $args{ARCH}) { - script_error('perform_sbo requires LOCATION and ARCH.'); - } - - my $location = $args{LOCATION}; - my $sbo = get_sbo_from_loc($location); - - # we need to get a listing of /tmp/SBo, or $TMP, if we can, before we run - # the SlackBuild so that we can compare to a listing taken afterward. - my @src_ls; - if (opendir(my $tsbo_dh, $tmpd)) { - @src_ls = grep { ! in( $_ => qw/ . .. /) } readdir $tsbo_dh; - } - - my ($cmd, %changes); - # set any changes we need to make to the .SlackBuild, setup the command - - $cmd = ''; - - if ($args{ARCH} eq 'x86_64' and ($args{C32} || $args{X32})) { - if ($args{C32}) { - $changes{libdirsuffix} = ''; - } elsif ($args{X32}) { - $changes{arch_out} = 'i486'; - } - $cmd .= '. /etc/profile.d/32dev.sh &&'; - } - if ($args{JOBS} and $args{JOBS} ne 'FALSE') { - $changes{jobs} = 1; - } - $cmd .= " $args{OPTS}" if $args{OPTS}; - $cmd .= " MAKEOPTS=\"-j$args{JOBS}\"" if $changes{jobs}; - - # set TMP/OUTPUT if set in the environment - $cmd .= " TMP=$env_tmp" if $env_tmp; - $cmd .= " OUTPUT=$ENV{OUTPUT}" if defined $ENV{OUTPUT}; - $cmd .= " /bin/bash $location/$sbo.SlackBuild"; - - # attempt to rewrite the slackbuild, or exit if we can't - my ($fail, $exit) = rewrite_slackbuild( - SBO => $sbo, - SLACKBUILD => "$location/$sbo.SlackBuild", - CHANGES => \%changes, - C32 => $args{C32}, - ); - return $fail, undef, $exit if $exit; - - # run the slackbuild, grab its exit status, revert our changes - my $cwd = getcwd(); - chdir $location; - my ($out, $ret) = run_tee($cmd); - chdir $cwd; - - revert_slackbuild("$location/$sbo.SlackBuild"); - # return error now if the slackbuild didn't exit 0 - return "$sbo.SlackBuild return non-zero\n", undef, _ERR_BUILD if $ret != 0; - my $pkg = get_pkg_name($out); - return "$sbo.SlackBuild didn't create a package\n", undef, _ERR_BUILD if not defined $pkg; - my $src = get_src_dir(@src_ls); - return $pkg, $src; -} - -=head2 process_sbos - - my ($failures, $exit) = process_sbos(TODO => [@queue]); - -C<process_sbos()> processes the C<@queue> of slackbuilds and returns a list of -two values containing any failed builds in an array ref in the first value, and -the exit status in the second. - -=cut - -# do the things with the provided sbos - whether upgrades or new installs. -sub process_sbos { - my %args = ( - TODO => '', - CMDS => '', - OPTS => '', - JOBS => 'FALSE', - LOCATIONS => '', - NOINSTALL => 0, - NOCLEAN => 'FALSE', - DISTCLEAN => 'FALSE', - NON_INT => 0, - @_ - ); - my $todo = $args{TODO}; - my $cmds = $args{CMDS}; - my $opts = $args{OPTS}; - my $locs = $args{LOCATIONS}; - my $jobs = $args{JOBS} =~ /^\d+$/ ? $args{JOBS} : 0; - @$todo >= 1 or script_error('process_sbos requires TODO.'); - my (@failures, @symlinks, $err); - FIRST: for my $sbo (@$todo) { - my $compat32 = $sbo =~ /-compat32$/ ? 1 : 0; - my ($temp_syms, $exit) = check_distfiles( - LOCATION => $$locs{$sbo}, COMPAT32 => $compat32 - ); - # if $exit is defined, prompt to proceed or return with last $exit - if ($exit) { - $err = $exit; - my $fail = $temp_syms; - push @failures, {$sbo => $fail}; - # return now if we're not interactive - return \@failures, $exit if $args{NON_INT}; - say "Unable to download/verify source file(s) for $sbo:"; - say " $fail"; - if (prompt('Do you want to proceed?' , default => 'no')) { - next FIRST; - } else { - unlink for @symlinks; - return \@failures, $exit; - } - } else { - push @symlinks, @$temp_syms; - } - } - my $count = 0; - FIRST: for my $sbo (@$todo) { - $count++; - my $options = $$opts{$sbo} // 0; - my $cmds = $$cmds{$sbo} // []; - for my $cmd (@$cmds) { - system($cmd) == 0 or warn "\"$cmd\" exited non-zero\n"; - } - # switch compat32 on if upgrading/installing a -compat32 - # else make sure compat32 is off - my $compat32 = $sbo =~ /-compat32$/ ? 1 : 0; - my ($version, $pkg, $src, $exit) = do_slackbuild( - OPTS => $options, - JOBS => $jobs, - LOCATION => $$locs{$sbo}, - COMPAT32 => $compat32, - ); - if ($exit) { - my $fail = $version; - push @failures, {$sbo => $fail}; - # return now if we're not interactive - return \@failures, $exit if $args{NON_INT}; - # or if this is the last $sbo - return \@failures, $exit if $count == @$todo; - say "Failure encountered while building $sbo:"; - say " $fail"; - if (prompt('Do you want to proceed?', default => 'no')) { - next FIRST; - } else { - unlink for @symlinks; - return \@failures, $exit; - } - } - - do_upgradepkg($pkg) unless $args{NOINSTALL}; - - unless ($args{DISTCLEAN}) { - make_clean(SBO => $sbo, SRC => $src, VERSION => $version) - unless $args{NOCLEAN}; - } else { - make_distclean( - SBO => $sbo, - SRC => $src, - VERSION => $version, - LOCATION => $$locs{$sbo}, - ); - } - # move package to $config{PKG_DIR} if defined - unless ($config{PKG_DIR} eq 'FALSE') { - my $dir = $config{PKG_DIR}; - unless (-d $dir) { - mkdir($dir) or warn "Unable to create $dir\n"; - } - if (-d $dir) { - move($pkg, $dir), say "$pkg stored in $dir"; - } else { - warn "$pkg left in $tmpd\n"; - } - } elsif ($args{DISTCLEAN}) { - unlink $pkg; - } - } - unlink for @symlinks; - return \@failures, $err; -} - -=head2 revert_slackbuild - - revert_slackbuild($path); - -C<revert_slackbuild()> moves back a slackbuild that was rewritten by -C<rewrite_slackbuild()>. - -There is no useful return value. - -=cut - -# move a backed-up .SlackBuild file back into place -sub revert_slackbuild { - script_error('revert_slackbuild requires an argument') unless @_ == 1; - my $slackbuild = shift; - if (-f "$slackbuild.orig") { - unlink $slackbuild if -f $slackbuild; - rename "$slackbuild.orig", $slackbuild; - } - return 1; -} - -=head2 rewrite_slackbuild - - my ($ret, $exit) = rewrite_slackbuild(SLACKBUILD => $path); - -C<rewrite_slackbuild()> when given a path and some changes to make, will move -and copy the C<$path> and rewrite the copy with the needed changes. - -It returns a list of two values. The second value is the exit status, and if it -is true, the first value will be an error message. - -=cut - -# make a backup of the existent SlackBuild, and rewrite the original as needed -sub rewrite_slackbuild { - my %args = ( - SBO => '', - SLACKBUILD => '', - CHANGES => {}, - C32 => 0, - @_ - ); - $args{SLACKBUILD} or script_error('rewrite_slackbuild requires SLACKBUILD.'); - my $slackbuild = $args{SLACKBUILD}; - my $changes = $args{CHANGES}; - - # $status will be undefined if either the rename or the copy fails, otherwise it will be 1 - my $status = eval { - rename($slackbuild, "$slackbuild.orig") or die "not ok"; - copy("$slackbuild.orig", $slackbuild) or die "not ok"; - 1; - }; - if (not $status) { - rename "$slackbuild.orig", $slackbuild if not -f $slackbuild; - return "Unable to backup $slackbuild to $slackbuild.orig\n", - _ERR_OPENFH; - } - - my $libdir_regex = qr/^\s*LIBDIRSUFFIX="64"\s*$/; - my $arch_regex = qr/\$VERSION-\$ARCH-\$BUILD/; - my $dc_regex = qr/(?<![a-z])(tar|p7zip|unzip|ar|rpm2cpio|sh)\s+/; - my $make_regex = qr/^\s*make\s*$/; - # tie the slackbuild, because this is the easiest way to handle this. - tie my @sb_file, 'Tie::File', $slackbuild; - # if we're dealing with a compat32, we need to change the tar line(s) so - # that the 32-bit source is untarred - if ($args{C32}) { - my $location = get_sbo_location($args{SBO}); - my $downloads = get_sbo_downloads( - LOCATION => $location, - 32 => 1, - ); - my $fns = get_dl_fns([keys %$downloads]); - for my $line (@sb_file) { - if ($line =~ $dc_regex) { - my ($regex, $initial) = get_dc_regex($line); - for my $fn (@$fns) { - $fn = "$initial$fn"; - $line =~ s/$regex/$fn/ if $fn =~ $regex; - } - } - } - } - for my $line (@sb_file) { - # then check for and apply any other %$changes - if (exists $$changes{libdirsuffix}) { - $line =~ s/64/$$changes{libdirsuffix}/ if $line =~ $libdir_regex; - } - if (exists $$changes{arch_out}) { - $line =~ s/\$ARCH/$$changes{arch_out}/ if $line =~ $arch_regex; - } - if (exists $changes->{jobs}) { - $line =~ s/make/make \$MAKEOPTS/ if $line =~ $make_regex; - } - } - untie @sb_file; - return 1; -} - -=head2 run_tee - - my ($output, $exit) = run_tee($cmd); - -C<run_tee()> runs the C<$cmd >under C<tee(1)> to allow both displaying its -output and returning it as a string. It returns a list of the output and the -exit status (C<$?> in bash). If it can't even run the bash interpreter, the -output will be C<undef> and the exit status will hold a true value. - -=cut - -sub run_tee { - my $cmd = shift; - - my $tempdir = tempdir(CLEANUP => 1, DIR => $tmpd); - - my $out_fh = tempfile(DIR => $tempdir); - my $out_fn = get_tmp_extfn($out_fh); - return undef, _ERR_F_SETFD if not defined $out_fn; - - my $exit_fh = tempfile(DIR => $tempdir); - my $exit_fn = get_tmp_extfn($exit_fh); - return undef, _ERR_F_SETFD if not defined $exit_fn; - - $cmd = sprintf '( %s; echo $? > %s ) | tee %s', $cmd, $exit_fn, $out_fn; - - my $ret = system('/bin/bash', '-c', $cmd); - - return undef, $ret if $ret; - - seek $exit_fh, 0, 0; - chomp($ret = readline $exit_fh); - - seek $out_fh, 0, 0; - my $out = do { local $/; readline $out_fh; }; - - return $out, $ret; -} - -sub _build_queue { - my ($sbos, $warnings) = @_; - my @queue = @$sbos; - my @result; - - while (my $sbo = shift @queue) { - next if $sbo eq "%README%"; - my $reqs = get_requires($sbo); - if (defined $reqs) { - push @result, _build_queue($reqs, $warnings); - foreach my $req (@$reqs) { - $warnings->{$sbo}="%README%" if $req eq "%README%"; - } - } - else { - $warnings->{$sbo} = "nonexistent"; - } - push @result, $sbo; - } - - return uniq @result; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Cryptography.pm b/SBO-Lib/lib/SBO/Lib/Cryptography.pm deleted file mode 100644 index 7d77332..0000000 --- a/SBO-Lib/lib/SBO/Lib/Cryptography.pm +++ /dev/null @@ -1,213 +0,0 @@ -package SBO::Lib::Cryptography; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use Cwd; -use File::Temp "tempdir"; -use IPC::Open3; - -use Exporter 'import'; - -# Minimal definitions of some GPG raw output messages. -use constant { - BADSIG => 'bad signature', - EXPSIG => 'signature expired', - EXPKEYSIG => 'signed by expired key', - ERRSIG => 'signature verification not possible', - GOODSIG => 'good signature', - REVKEYSIG => 'good signature by revoked public key', - NO_PUBKEY => 'public key unavailable', - VALIDSIG => 'valid signature', - # An unknown message type. - UNKNOWN => 'unknown', -}; - -our @EXPORT_OK = qw{ - import_gpg_key - parse_gpg_output - verify_gpg_signed_file - - BADSIG - EXPSIG - EXPKEYSIG - ERRSIG - GOODSIG - REVKEYSIG - NO_PUBKEY - VALIDSIG - UNKNOWN -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=cut - -# Messages on Signature status which should only turn up once. -our %is_signature_status = ( - &BADSIG => 1, - &ERRSIG => 1, - &EXPSIG => 1, - &EXPKEYSIG => 1, - &GOODSIG => 1, - &REVKEYSIG => 1, -); - -=head2 - - parse_gpg_output(@output, $key_id); - -=cut - -sub parse_gpg_output { - my $output = shift; - my $key_id = shift; - - - my $line; - my $status = ''; - - foreach $line (@$output) { - my $msg = parse_gpg_line($line, $key_id); - - if (exists($is_signature_status{$msg})) { - # Only one signature expected. - if ($status ne '') { - return UNKNOWN; - } - - $status = $msg; - } - - if ($msg eq NO_PUBKEY) { - return NO_PUBKEY; - } elsif ($msg eq VALIDSIG) { - # VALIDSIG contains the full hex key ID to be certain it is signed by the - # right key. information can be found in 'DETAILS' in the gnupg2 - # documentation folder. - return $status; - } - } - - return UNKNOWN; -} - -sub parse_gpg_line { - my $line = shift; - my $key_id = shift; - - if ($line =~ /^\[GNUPG\:] BADSIG/) { - return BADSIG; - } elsif ($line =~ /^\[GNUPG\:] EXPSIG/) { - return EXPSIG; - } elsif ($line =~ /^\[GNUPG\:] EXPKEYSIG/) { - return EXPKEYSIG; - } elsif ($line =~ /^\[GNUPG\:] ERRSIG/) { - return ERRSIG; - } elsif ($line =~ /^\[GNUPG\:] GOODSIG/) { - return GOODSIG; - } elsif ($line =~ /^\[GNUPG\:] REVKEYSIG/) { - return REVKEYSIG; - } elsif ($line =~ /^\[GNUPG\:] NO_PUBKEY/) { - return NO_PUBKEY; - } elsif ($line =~ /^\[GNUPG\:] VALIDSIG $key_id/) { - return VALIDSIG; - } else { - return UNKNOWN; - } -} - -=head2 import_gpg_key - - import_gpg_key($key); - -C<import_gpg_key()> will import the key into the systems keychain. An error will -be reported if the configured key fingerprint does not match the imported one. - -=cut - -sub import_gpg_key { - script_error('import_gpg_key requires two arguments.') unless @_ == 2; - - my $key = shift; - my $key_id = shift; - - my $key_source; - if ($key =~ m!^http://! || $key =~ m!^https://!) { - open3(undef, $key_source, ">&STDERR", "wget", $key, "-O", "-") || die("could not download key from $key"); - } else { - open($key_source, "<", $key) || die("could not read '$key': $!"); - } - - my $old = $ENV{'GNUPGHOME'}; - - $ENV{'GNUPGHOME'} = tempdir(CLEANUP => 1); - - my $gpg_cmd; - open3($gpg_cmd, undef, undef, "gpg", "--batch", "--yes", "--import", "-") || die("could not import key: $!\n"); - - while (my $line = <$key_source>) { - print($gpg_cmd $line); - } - - close($gpg_cmd); - close($key_source); - - sleep(1); - - if (system(">/dev/null gpg --list-keys $key_id")) { - die("GPG key '$key_id' not found. Confirm the correct key is configured or is being imported.\n"); - } - - my $gpg_export; - open($gpg_export, "-|", "gpg", "--export", $key_id) || die("could not export key: $!\n"); - - $ENV{'GNUPGHOME'} = $old; - - my $gpg_import; - open3($gpg_import, ">&STDOUT", ">&STDOUT", "gpg", "--batch", "--yes", "--import", "-") || die("could not import key: $!\n"); - - while (my $line = <$gpg_export>) { - print($gpg_import $line); - } - - close($gpg_export); - close($gpg_import); - - sleep(1); - - print("key imported\n"); -} - -=head2 verify_gpg_signed_file - - verify_gpg_signed_file($file_path, $key_id); - -C<verify_gpg_signed_file()> verifies the C<file_path> is signed by C<key_id>. - -=cut - -sub verify_gpg_signed_file { - script_error('verify_gpg_signed_file requires two arguments.') unless @_ == 2; - - my $file_path = shift; - my $key_id = shift; - - my @output; - open3(undef, my $std_out, undef, "gpg", "--status-fd=1", "--verify", $file_path) or die("dead"); - while (my $line = <$std_out>) { - push(@output, $line); - } - close($std_out); - - return parse_gpg_output(\@output, $key_id); -} diff --git a/SBO-Lib/lib/SBO/Lib/Download.pm b/SBO-Lib/lib/SBO/Lib/Download.pm deleted file mode 100644 index e574580..0000000 --- a/SBO-Lib/lib/SBO/Lib/Download.pm +++ /dev/null @@ -1,299 +0,0 @@ -package SBO::Lib::Download; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ :const script_error get_sbo_from_loc open_read get_arch /; -use SBO::Lib::Repo qw/ $distfiles /; -use SBO::Lib::Info qw/ get_download_info /; - -use Digest::MD5; -use Exporter 'import'; - -our @EXPORT_OK = qw{ - check_distfiles - compute_md5sum - create_symlinks - get_distfile - get_dl_fns - get_filename_from_link - get_sbo_downloads - get_symlink_from_filename - verify_distfile -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Download - Routines for downloading slackbuild sources. - -=head1 SYNOPSIS - - use SBO::Lib::Download qw/ check_distfiles /; - - my ($ret, $exit) = check_distfiles(LOCATION => $loc); - -=head2 SUBROUTINES - -=cut - -=head2 check_distfiles - - my ($ret, $exit) = check_distfiles(LOCATION => $loc); - -C<check_distfiles()> gets the list of downloads from C<$loc>, and checks to see -if any of them are already downloaded. If so, it verifies that they're correct, -otherwise it downloads them, verifies they're correct, and calls -C<create_symlinks> on them. - -It returns a list of two values. If the second value is true, the first value -will contain an error message. Otherwise it will contain an array reference of -symlinks as returned by C<create_symlinks>. - -=cut - -# for the given location, pull list of downloads and check to see if any exist; -# if so, verify they md5 correctly and if not, download them and check the new -# download's md5sum, then create required symlinks for them. -sub check_distfiles { - my %args = ( - LOCATION => '', - COMPAT32 => 0, - @_ - ); - $args{LOCATION} or script_error('check_distfiles requires LOCATION.'); - - my $location = $args{LOCATION}; - my $sbo = get_sbo_from_loc($location); - my $downloads = get_sbo_downloads( - LOCATION => $location, - 32 => $args{COMPAT32} - ); - # return an error if we're unable to get download info - unless (keys %$downloads > 0) { - return "Unable to get download info from $location/$sbo.info\n", - _ERR_NOINFO; - } - for my $link (keys %$downloads) { - my $md5 = $downloads->{$link}; - unless (verify_distfile($link, $md5)) { - my ($fail, $exit) = get_distfile($link, $md5); - return $fail, $exit if $exit; - } - } - my $symlinks = create_symlinks($args{LOCATION}, $downloads); - return $symlinks; -} - -=head2 compute_md5sum - - my $md5sum = compute_md5sum($file); - -C<compute_md5sum()> computes the md5sum of the file in C<$file>, and returns it. - -=cut - -# for a given file, compute its md5sum -sub compute_md5sum { - script_error('compute_md5sum requires a file argument.') unless -f $_[0]; - my ($fh, $exit) = open_read(shift); - my $md5 = Digest::MD5->new; - $md5->addfile($fh); - my $md5sum = $md5->hexdigest; - close $fh; - return $md5sum; -} - -=head2 create_symlinks - - my @symlinks = @{ create_symlinks($location, {%downloads}); - -C<create_symlinks()> creates symlinks for the C<%downloads> in C<$location>, -and returns an array reference of the symlinks created. - -=cut - -# given a location and a list of download links, assemble a list of symlinks, -# and create them. -sub create_symlinks { - script_error('create_symlinks requires two arguments.') unless @_ == 2; - my ($location, $downloads) = @_; - my @symlinks; - for my $link (keys %$downloads) { - my $filename = get_filename_from_link($link); - my $symlink = get_symlink_from_filename($filename, $location); - push @symlinks, $symlink; - symlink $filename, $symlink; - } - return \@symlinks; -} - -=head2 get_distfile - - my ($msg, $err) = get_distfile($link, $md5); - -C<get_distfile()> downloads the C<$link>, and compares the downloaded file's -md5sum to the one in C<$md5>. It returns a list of two values, and if the -second value is true, the first one will have an error message. - -=cut - -# for a given distfile, attempt to retrieve it and, if successful, check its -# md5sum against that in the sbo's .info file -sub get_distfile { - script_error('get_distfile requires two arguments') unless @_ == 2; - my ($link, $info_md5) = @_; - my $filename = get_filename_from_link($link); - mkdir $distfiles unless -d $distfiles; - chdir $distfiles; - unlink $filename if -f $filename; - my $fail = {}; - - # if wget $link && verify, return - # else wget sbosrcarch && verify - if (system('wget', '--no-check-certificate', '--tries=5', $link) != 0) { - $fail->{msg} = "Unable to wget $link.\n"; - $fail->{err} = _ERR_DOWNLOAD; - } - return 1 if not %$fail and verify_distfile(@_); - if (not %$fail) { - $fail->{msg} = "md5sum failure for $filename.\n"; - $fail->{err} = _ERR_MD5SUM; - } - - # since the download from the original link either didn't download or - # didn't verify, try to get it from sbosrcarch instead - unlink $filename if -f $filename; - my $sbosrcarch = sprintf( - "ftp://slackware.uk/sbosrcarch/by-md5/%s/%s/%s/%s", - substr($info_md5, 0, 1), substr($info_md5, 1, 1), $info_md5, _get_fname($link)); - - return 1 if - system('wget', '--no-check-certificate', '--tries=5', $sbosrcarch) == 0 and - verify_distfile(@_); - - return $fail->{msg}, $fail->{err}; -} - -=head2 get_dl_fns - - my @filenames = @{ get_dl_fns([@links]) }; - -C<get_dl_fns()> returns the filename parts of the C<@links> in an array -reference. - -=cut - -# given a list of downloads, return just the filenames -sub get_dl_fns { - my $fns = shift; - my $return; - push @$return, ($_ =~ qr|/([^/]+)$|)[0] for @$fns; - return $return; -} - -=head2 get_filename_from_link - - my $path = get_filename_from_link($link); - -C<get_filename_from_link> returns the full path to the file downloaded from -C<$link>. - -=cut - -sub get_filename_from_link { - script_error('get_filename_from_link requires an argument') unless @_ == 1; - my $filename = _get_fname(shift); - return undef unless defined $filename; - return "$distfiles/$filename"; -} - -=head2 get_sbo_downloads - - my %downloads = %{ get_sbo_downloads(LOCATION => $loc) }; - -C<get_sbo_downloads()> gets the download links and md5sums for the slackbuild -in $loc, and returns them in a hash reference. - -=cut - -# TODO: should probably combine this with get_download_info -sub get_sbo_downloads { - my %args = ( - LOCATION => '', - 32 => 0, - @_ - ); - $args{LOCATION} or script_error('get_sbo_downloads requires LOCATION.'); - my $location = $args{LOCATION}; - -d $location or script_error('get_sbo_downloads given a non-directory.'); - my $arch = get_arch(); - my $dl_info; - if ($arch eq 'x86_64') { - $dl_info = get_download_info(LOCATION => $location) unless $args{32}; - } - unless (keys %$dl_info > 0) { - $dl_info = get_download_info(LOCATION => $location, X64 => 0); - } - return $dl_info; -} - -=head2 get_symlink_from_filename - - my $symlink = get_symlink_from_filename($path, $loc); - -C<get_symlink_from_filename()> returns the path of the symlink in C<$loc> for -the C<$path>. - -=cut - -# for a given distfile, figure out what the full path to its symlink will be -sub get_symlink_from_filename { - script_error('get_symlink_from_filename requires two arguments') unless @_ == 2; - script_error('get_symlink_from_filename first argument is not a file') unless -f $_[0]; - my ($filename, $location) = @_; - return "$location/". ($filename =~ qr#/([^/]+)$#)[0]; -} - -=head2 verify_distfile - - my $bool = verify_distfile($link, $md5); - -C<verify_distfile()> verifies that the file downloaded from C<$link> matches -the C<$md5> md5sum, and returns a true value if it does, and a false value -otherwise. - -=cut - -# for a given distfile, see whether or not it exists, and if so, if its md5sum -# matches the sbo's .info file -sub verify_distfile { - script_error('verify_distfile requires two arguments.') unless @_ == 2; - my ($link, $info_md5) = @_; - my $filename = get_filename_from_link($link); - return() unless -f $filename; - my $md5sum = compute_md5sum($filename); - return $info_md5 eq $md5sum ? 1 : 0; -} - -# given a link, grab the filename from it and prepend $distfiles -sub _get_fname { - my $fn = shift; - my $regex = qr#/([^/]+)$#; - my ($filename) = $fn =~ $regex; - $filename =~ s/%2B/+/g if $filename; - return $filename; - -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Info.pm b/SBO-Lib/lib/SBO/Lib/Info.pm deleted file mode 100644 index bf47aec..0000000 --- a/SBO-Lib/lib/SBO/Lib/Info.pm +++ /dev/null @@ -1,234 +0,0 @@ -package SBO::Lib::Info; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ get_arch get_sbo_from_loc open_read script_error slurp usage_error /; -use SBO::Lib::Tree qw/ get_orig_location get_sbo_location is_local /; - -use Exporter 'import'; - -our @EXPORT_OK = qw{ - check_x32 - get_download_info - get_from_info - get_orig_version - get_requires - get_sbo_version - parse_info -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Info - Utilities to get data from SBo .info files. - -=head1 SYNOPSIS - - use SBO::Lib::Info qw/ get_reqs /; - - my @reqs = @{ get_requires($sbo) }; - -=head1 SUBROUTINES - -=cut - -=head2 check_x32 - - my $bool = check_x32($location); - -C<check_x32()> checks if the SBo in C<$location> considers 64bit builds -C<UNTESTED> or C<UNSUPPORTED>, and if so returns a true value. Otherwise it -returns a false value. - -=cut - -# determine whether or not a given sbo is 32-bit only -sub check_x32 { - script_error('check_x32 requires an argument.') unless @_ == 1; - my $dl = get_from_info(LOCATION => shift, GET => 'DOWNLOAD_x86_64'); - return $$dl[0] =~ /UN(SUPPOR|TES)TED/ ? 1 : undef; -} - -=head2 get_download_info - - my $downloads = get_download_info(LOCATION => $location, X64 => $x64); - my $downloads = get_download_info(LOCATION => $location); - -C<get_download_info()> takes a C<$location> to read a .info file in, and -C<$x64> which is a flag to determine if the x64 link should be used or not. - -If the C<$x64> flag is not given, it defaults to a true value. - -It returns a hashref where each key is a download link, and the corresponding -value is the md5sum it should have. - -=cut - -# get downloads and md5sums from an sbo's .info file, first -# checking for x86_64-specific info if we are told to -sub get_download_info { - my %args = ( - LOCATION => 0, - X64 => 1, - @_ - ); - $args{LOCATION} or script_error('get_download_info requires LOCATION.'); - my ($get, $downs, $exit, $md5s, %return); - $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); - $downs = get_from_info(LOCATION => $args{LOCATION}, GET => $get); - # did we get nothing back, or UNSUPPORTED/UNTESTED? - if ($args{X64}) { - if (! $$downs[0] || $$downs[0] =~ qr/^UN(SUPPOR|TES)TED$/) { - $args{X64} = 0; - $downs = get_from_info(LOCATION => $args{LOCATION}, - GET => 'DOWNLOAD'); - } - } - # if we still don't have any links, something is really wrong. - return() unless $$downs[0]; - # grab the md5s and build a hash - $get = $args{X64} ? 'MD5SUM_x86_64' : 'MD5SUM'; - $md5s = get_from_info(LOCATION => $args{LOCATION}, GET => $get); - return() unless $$md5s[0]; - $return{$$downs[$_]} = $$md5s[$_] for (keys @$downs); - return \%return; -} - -=head2 get_from_info - - my $data = get_from_info(LOCATION => $location, GET => $key); - -C<get_from_info()> retrieves the information under C<$key> from the .info file -in C<$location>. - -=cut - -# pull piece(s) of data, GET, from the $sbo.info file under LOCATION. -sub get_from_info { - my %args = ( - LOCATION => '', - GET => '', - @_ - ); - unless ($args{LOCATION} && $args{GET}) { - script_error('get_from_info requires LOCATION and GET.'); - } - state $store = {LOCATION => ['']}; - my $sbo = get_sbo_from_loc($args{LOCATION}); - return $store->{$args{GET}} if $store->{LOCATION}[0] eq $args{LOCATION}; - - # if we're here, we haven't read in the .info file yet. - my $contents = slurp("$args{LOCATION}/$sbo.info"); - usage_error("get_from_info: could not read $args{LOCATION}/$sbo.info.") unless - defined $contents; - - my %parse = parse_info($contents); - script_error("error when parsing $sbo.info file.") unless %parse; - - $store = {}; - $store->{LOCATION} = [$args{LOCATION}]; - foreach my $k (keys %parse) { $store->{$k} = $parse{$k}; } - - # allow local overrides to get away with not having quite all the fields - if (is_local($sbo)) { - for my $key (qw/DOWNLOAD_x86_64 MD5SUM_x86_64 REQUIRES/) { - $store->{$key} //= ['']; # if they don't exist, treat them as empty - } - } - return $store->{$args{GET}}; -} - -=head2 get_orig_version - - my $ver = get_orig_version($sbo); - -C<get_orig_version()> returns the version in the SlackBuilds.org tree for the -given C<$sbo>. - -=cut - -sub get_orig_version { - script_error('get_orig_version requires an argument.') unless @_ == 1; - my $sbo = shift; - - my $location = get_orig_location($sbo); - - return $location if not defined $location; - - return get_sbo_version($location); -} - -=head2 get_requires - - my $reqs = get_requires($sbo); - -C<get_requires()> returns the requirements for a given C<$sbo>. - -=cut - -# wrapper to pull the list of requirements for a given sbo -sub get_requires { - my $location = get_sbo_location(shift); - return undef unless $location; - my $info = get_from_info(LOCATION => $location, GET => 'REQUIRES'); - return $info; -} - -=head2 get_sbo_version - - my $ver = get_sbo_version($location); - -C<get_sbo_version()> returns the version found in the .info file in -C<$location>. - -=cut - -# find the version in the tree for a given sbo (provided a location) -sub get_sbo_version { - script_error('get_sbo_version requires an argument.') unless @_ == 1; - my $version = get_from_info(LOCATION => shift, GET => 'VERSION'); - return $version->[0]; -} - -=head2 parse_info - - my %parse = parse_info($str); - -C<parse_info()> parses the contents of an .info file from C<$str> and returns -a key-value list of it. - -=cut - -sub parse_info { - script_error('parse_info requires an argument.') unless @_ == 1; - my $info_str = shift; - my $pos = 0; - my %ret; - - while ($info_str =~ /\G([A-Za-z0-9_]+)="([^"]*)"\s*(?:\n|\z)/g) { - my ($key, $val) = ($1, $2); - $val =~ s/\\[ \t]*$/ /mg; - my @val = split " ", $val; - @val = '' unless @val; - $ret{$key} = \@val; - $pos = pos($info_str); - } - - return if $pos != length($info_str); - - return %ret; - -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Pkgs.pm b/SBO-Lib/lib/SBO/Lib/Pkgs.pm deleted file mode 100644 index 9e9e029..0000000 --- a/SBO-Lib/lib/SBO/Lib/Pkgs.pm +++ /dev/null @@ -1,198 +0,0 @@ -package SBO::Lib::Pkgs; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ %config script_error open_read version_cmp /; -use SBO::Lib::Tree qw/ get_sbo_location get_sbo_locations is_local /; -use SBO::Lib::Info qw/ get_orig_version get_sbo_version /; - -use Exporter 'import'; - -our @EXPORT_OK = qw{ - get_available_updates - get_inst_names - get_installed_cpans - get_installed_packages - get_local_outdated_versions -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Pkgs - Routines for interacting with the Slackware package database. - -=head1 SYNOPSIS - - use SBO::Lib::Pkgs qw/ get_installed_packages /; - - my @installed_sbos = get_installed_packages('SBO'); - -=head1 SUBROUTINES - -=cut - -my $pkg_db = '/var/log/packages'; - -=head2 get_available_updates - - my @updates = @{ get_available_updates() }; - -C<get_available_updates()> compares the installed versions in -C</var/log/packages> that are tagged as SBo with the version available from -the SlackBuilds.org or C<LOCAL_OVERRIDES> repository, and returns an array -reference to an array of hash references which specify package names, and -installed and available versions. - -=cut - -# for each installed sbo, find out whether or not the version in the tree is -# newer, and compile an array of hashes containing those which are -sub get_available_updates { - my @updates; - my $pkg_list = get_installed_packages('SBO'); - - for my $pkg (@$pkg_list) { - my $location = get_sbo_location($pkg->{name}); - next unless $location; - - my $version = get_sbo_version($location); - if (version_cmp($version, $pkg->{version}) != 0) { - push @updates, { name => $pkg->{name}, installed => $pkg->{version}, update => $version }; - } - } - - return \@updates; -} - -=head2 get_inst_names - - my @names = get_inst_names(get_available_updates()); - -C<get_inst_names()> returns a list of package names from an array reference -such as the one returned by C<get_available_updates()>. - -=cut - -# for a ref to an array of hashes of installed packages, return an array ref -# consisting of just their names -sub get_inst_names { - script_error('get_inst_names requires an argument.') unless @_ == 1; - my $inst = shift; - my @installed; - push @installed, $$_{name} for @$inst; - return \@installed; -} - -=head2 get_installed_cpans - - my @cpans = @{ get_installed_cpans() }; - -C<get_installed_cpans()> returns an array reference to a list of the perl -modules installed from the CPAN rather than from packages on SlackBuilds.org. - -=cut - -# return a list of perl modules installed via the CPAN -sub get_installed_cpans { - my @contents; - for my $file (grep { -f $_ } map { "$_/perllocal.pod" } @INC) { - my ($fh, $exit) = open_read($file); - next if $exit; - push @contents, grep {/Module/} <$fh>; - close $fh; - } - my $mod_regex = qr/C<Module>\s+L<([^\|]+)/; - my (@mods, @vers); - for my $line (@contents) { - push @mods, ($line =~ $mod_regex)[0]; - } - return \@mods; -} - -=head2 get_installed_packages - - my @packages = @{ get_installed_packages($type) }; - -C<get_installed_packages()> returns an array reference to a list of packages in -C</var/log/packages> that match the specified C<$type>. The available types are -C<STD> for non-SBo packages, C<SBO> for SBo packages, and C<ALL> for both. - -The returned array reference will hold a list of hash references representing -both names, versions, and full installed package name of the returned packages. - -=cut - -# pull an array of hashes, each hash containing the name and version of a -# package currently installed. Gets filtered using STD, SBO or ALL. -sub get_installed_packages { - script_error('get_installed_packages requires an argument.') unless @_ == 1; - my $filter = shift; - - # Valid types: STD, SBO - my (@pkgs, %types); - foreach my $pkg (glob("$pkg_db/*")) { - $pkg =~ s!^\Q$pkg_db/\E!!; - my ($name, $version, $build) = $pkg =~ m#^([^/]+)-([^-]+)-[^-]+-([^-]+)$# - or next; - push @pkgs, { name => $name, version => $version, build => $build, pkg => $pkg }; - $types{$name} = 'STD'; - } - - # If we want all packages, let's just return them all - return [ map { +{ name => $_->{name}, version => $_->{version}, pkg => $_->{pkg} } } @pkgs ] - if $filter eq 'ALL'; - - # Otherwise, mark the SBO ones and filter - my @sbos = map { $_->{name} } grep { $_->{build} =~ m/_SBo(|compat32)$/ } - @pkgs; - if (@sbos) { - my %locations = get_sbo_locations(map { s/-compat32//gr } @sbos); - foreach my $sbo (@sbos) { $types{$sbo} = 'SBO' - if $locations{ $sbo =~ s/-compat32//gr }; } - } - return [ map { +{ name => $_->{name}, version => $_->{version}, pkg => $_->{pkg} } } - grep { $types{$_->{name}} eq $filter } @pkgs ]; -} - -=head2 get_local_outdated_versions - - my @outdated = get_local_outdated_versions(); - -C<get_local_outdated_versions()> checks the installed SBo packages and returns -a list of the ones for which the C<LOCAL_OVERRIDES> version is different to the -the version on SlackBuilds.org. - -=cut - -sub get_local_outdated_versions { - my @outdated; - - my $local = $config{LOCAL_OVERRIDES}; - unless ( $local eq 'FALSE' ) { - my $pkglist = get_installed_packages('SBO'); - my @local = grep { is_local($_->{name}) } @$pkglist; - - foreach my $sbo (@local) { - my $orig = get_orig_version($sbo->{name}); - next if not defined $orig; - next if not version_cmp($orig, $sbo->{version}); - - push @outdated, { %$sbo, orig => $orig }; - } - } - - return @outdated; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Readme.pm b/SBO-Lib/lib/SBO/Lib/Readme.pm deleted file mode 100644 index 1022c4a..0000000 --- a/SBO-Lib/lib/SBO/Lib/Readme.pm +++ /dev/null @@ -1,220 +0,0 @@ -package SBO::Lib::Readme; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ prompt script_error slurp open_read _ERR_OPENFH usage_error /; -use SBO::Lib::Tree qw/ is_local /; - -use Exporter 'import'; - -our @EXPORT_OK = qw{ - ask_opts - ask_other_readmes - ask_user_group - get_opts - get_readme_contents - get_user_group - user_prompt -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Readme - Routines for interacting with a typical SBo README file. - -=head1 SYNOPSIS - - use SBO::Lib::Readme qw/ get_readme_contents /; - - print get_readme_contents($sbo); - -=head1 SUBROUTINES - -=cut - -=head2 ask_opts - - my $opts = ask_opts($sbo, $readme); - -C<ask_opts()> displays the C<$readme> and asks if we should set any of the -options it defines. If the user indicates that we should, we prompt them for -the options to set and then returns them as a string. If the user didn't supply -any options or indicated that we shouldn't, it returns C<undef>. - -=cut - -# provide an opportunity to set options -sub ask_opts { - # TODO: check number of args - script_error('ask_opts requires an argument') unless @_; - my ($sbo, $readme) = @_; - say "\n". $readme; - if (prompt("\nIt looks like $sbo has options; would you like to set any when the slackbuild is run?", default => 'no')) { - my $ask = sub { - chomp(my $opts = prompt("\nPlease supply any options here, or enter to skip: ")); - return $opts; - }; - my $kv_regex = qr/[A-Z0-9]+=[^\s]+(|\s([A-Z]+=[^\s]+){0,})/; - my $opts = $ask->(); - return() unless $opts; - while ($opts !~ $kv_regex) { - warn "Invalid input received.\n"; - $opts = $ask->(); - return() unless $opts; - } - return $opts; - } - return(); -} - -=head2 ask_other_readmes - - ask_other_readmes($sbo, $location); - -C<ask_other_readmes()> checks if there are other readmes for the C<$sbo> in -C<$location>, and if so, asks the user if they should be displayed, and then -displays them if the user didn't decline. - -=cut - -sub ask_other_readmes { - my ($sbo, $location) = @_; - my @readmes = sort grep { ! m!/README$! } glob "$location/README*"; - - return unless @readmes; - - return unless prompt("\nIt looks like $sbo has additional README files. Would you like to see those too?", default => 'yes'); - - for my $fn (@readmes) { - my ($display_fn) = $fn =~ m!/(README.*)$!; - say "\n$display_fn:"; - say slurp $fn; - } -} - -=head2 ask_user_group - - my $bool = ask_user_group($cmds, $readme); - -C<ask_user_group()> displays the C<$readme> and commands found in C<$cmds>, and -asks the user if we should automatically run the C<useradd>/C</groupadd> -commands found. If the user indicates that we should, it returns the C<$cmds>, -otherwise it returns C<undef>. - -=cut - -# offer to run any user/group add commands -sub ask_user_group { - script_error('ask_user_group requires two arguments') unless @_ == 2; - my ($cmds, $readme) = @_; - say "\n". $readme; - print "\nIt looks like this slackbuild requires the following"; - say ' command(s) to be run first:'; - say " # $_" for @$cmds; - return prompt('Shall I run them prior to building?', default => 'yes') ? $cmds : undef; -} - -=head2 get_opts - - my $bool = get_opts($readme); - -C<get_opts()> checks if the C<$readme> has any options defined, and if so -returns a true value. Otherwise it returns a false value. - -=cut - -# see if the README mentions any options -sub get_opts { - script_error('get_opts requires an argument') unless @_ == 1; - my $readme = shift; - return $readme =~ /[A-Z0-9]+=[^\s]/ ? 1 : undef; -} - -=head2 get_readme_contents - - my $contents = get_readme_contents($location); - -C<get_readme_contents()> will open the README file in C<$location> and return -its contents. On error, it will return C<undef>. - -=cut - -sub get_readme_contents { - script_error('get_readme_contents requires an argument.') unless @_ == 1; - return undef unless defined $_[0]; - my $readme = slurp(shift . '/README'); - return $readme; -} - -=head2 get_user_group - - my @cmds = @{ get_user_group($readme) }; - -C<get_user_group()> searches through the C<$readme> for C<useradd> and -C<groupadd> commands, and returns them in an array reference. - -=cut - -# look for any (user|group)add commands in the README -sub get_user_group { - script_error('get_user_group requires an argument') unless @_ == 1; - my $readme = shift; - my @cmds = $readme =~ /^\s*#*\s*(useradd.*?|groupadd.*?)(?<!\\)\n/msg; - return \@cmds; -} - -=head2 user_prompt - - my ($cmds, $opts, $exit) = user_prompt($sbo, $location); - -C<user_prompt()> checks for options and commands, to see if we should run them, -and asks if we should proceed with the C<$sbo> in question. - -It returns a list of three values, and if the third one is a true value, the -first indicates an error message. Otherwise, the first value will either be an -C<'N'>, C<undef>, or an array reference. If it's C<'N'>, the user indicated -that we should B<not> build this C<$sbo>. Otherwise it indicates if we should -run any C<useradd>/C<groupadd> commands, or if it's C<undef>, that we -shouldn't. The second return value indicates the options we should specify if -we build this C<$sbo>. - -B<Note>: This should really be changed. - -=cut - -# for a given sbo, check for cmds/opts, prompt the user as appropriate -sub user_prompt { - script_error('user_prompt requires two arguments.') unless @_ == 2; - my ($sbo, $location) = @_; - if (not defined $location) { usage_error("Unable to locate $sbo in the SlackBuilds.org tree."); } - my $readme = get_readme_contents($location); - return "Could not open README for $sbo.", undef, _ERR_OPENFH if not defined $readme; - if (is_local($sbo)) { print "\nFound $sbo in local overrides.\n"; } - # check for user/group add commands, offer to run any found - my $user_group = get_user_group($readme); - my $cmds; - $cmds = ask_user_group($user_group, $readme) if $$user_group[0]; - # check for options mentioned in the README - my $opts = 0; - $opts = ask_opts($sbo, $readme) if get_opts($readme); - print "\n". $readme unless $opts; - ask_other_readmes($sbo, $location); - # we have to return something substantial if the user says no so that we - # can check the value of $cmds on the calling side. we should be able to - # assume that 'N' will never be a valid command to run. - return 'N' unless prompt("\nProceed with $sbo?", default => 'yes'); - return $cmds, $opts; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Repo.pm b/SBO-Lib/lib/SBO/Lib/Repo.pm deleted file mode 100644 index 7d770c8..0000000 --- a/SBO-Lib/lib/SBO/Lib/Repo.pm +++ /dev/null @@ -1,485 +0,0 @@ -package SBO::Lib::Repo; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ %config prompt usage_error get_slack_version get_slack_version_key get_slack_version_url script_error open_fh open_read in _ERR_DOWNLOAD /; -use SBO::Lib::Cryptography qw/ GOODSIG NO_PUBKEY parse_gpg_output verify_gpg_signed_file /; - -use Cwd; -use File::Copy; -use File::Find; -use File::Temp "tempdir"; -use File::Path qw/ make_path remove_tree /; -use IPC::Open3; -use Sort::Versions; -use Symbol "gensym"; - -use Exporter 'import'; - -our @EXPORT_OK = qw{ - check_git_remote - check_repo - chk_slackbuilds_txt - fetch_tree - generate_slackbuilds_txt - git_sbo_tree - migrate_repo - pull_sbo_tree - rsync_sbo_tree - slackbuilds_or_fetch - update_tree - - $distfiles - $repo_path - $slackbuilds_txt -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Repo - Routines for downloading and updating the SBo repo. - -=head1 SYNOPSIS - - use SBO::Lib::Repo qw/ fetch_tree /; - - fetch_tree(); - -=head1 VARIABLES - -=head2 $distfiles - -By default $distfiles is set to C</usr/sbo/distfiles>, and it is where all the -downloaded sources are kept. - -The location depends on the C<SBO_HOME> config setting. - -=head2 $repo_path - -By default $repo_path is set to C</usr/sbo/repo>, and it is where the -SlackBuilds.org tree is kept. - -The location depends on the C<SBO_HOME> config setting. - -=cut - -# some stuff we'll need later -our $distfiles = "$config{SBO_HOME}/distfiles"; -our $repo_path = "$config{SBO_HOME}/repo"; -our $slackbuilds_txt = "$repo_path/SLACKBUILDS.TXT"; - -=head1 SUBROUTINES - -=cut - -=head2 check_git_remote - - my $bool = check_git_remote($path, $url); - -C<check_git_remote()> will check if the repository at C<$path> is a git -repository and if so, it will check if it defined an C<origin> remote that -matches the C<$url>. If so, it will return a true value. Otherwise it will -return a false value. - -=cut - -sub check_git_remote { - script_error('check_git_remote requires two arguments.') unless @_ == 2; - my ($path, $url) = @_; - return 0 unless -f "$path/.git/config"; - my ($fh, $exit) = open_read("$path/.git/config"); - return 0 if $exit; - - while (my $line = readline($fh)) { - chomp $line; - if ($line eq '[remote "origin"]') { - REMOTE: while (my $remote = readline($fh)) { - last REMOTE if $remote =~ /^\[/; - return 1 if $remote =~ /^\s*url\s*=\s*\Q$url\E$/; - return 0 if $remote =~ /^\s*url\s*=/; - } - } - } - return 0; -} - -=head2 check_repo - - my $bool = check_repo(); - -C<check_repo()> checks if the path in C<$repo_path> exists and is an empty -directory, and returns a true value if so. - -If it exists but isn't empty, it will exit with a usage error. - -If it doesn't exist, it will attempt to create it and return a true value. If -it fails to create it, it will exit with a usage error. - -=cut - -sub check_repo { - if (-d $repo_path) { - _race::cond '$repo_path could be deleted after -d check'; - opendir(my $repo_handle, $repo_path); - FIRST: while (my $dir = readdir $repo_handle) { - next FIRST if in($dir => qw/ . .. /); - usage_error("$repo_path exists and is not empty. Exiting.\n"); - } - } else { - eval { make_path($repo_path) } - or usage_error("Unable to create $repo_path.\n"); - } - return 1; -} - -=head2 chk_slackbuilds_txt - - my $bool = chk_slackbuilds_txt(); - -C<chk_slackbuilds_txt()> checks if the file C<SLACKBUILDS.TXT> exists in the -correct location, and returns a true value if it does, and a false value -otherwise. - -Before the check is made, it attempts to call C<migrate_repo()> so it doesn't -give a false negative if the repository hasn't been migrated to its sbotools -2.0 location yet. - -=cut - -# does the SLACKBUILDS.TXT file exist in the sbo tree? -sub chk_slackbuilds_txt { - if (-f "$config{SBO_HOME}/SLACKBUILDS.TXT") { migrate_repo(); } - return -f $slackbuilds_txt ? 1 : undef; -} - -=head2 fetch_tree - - fetch_tree(); - -C<fetch_tree()> will make sure the C<$repo_path> exists and is empty, and then -fetch the SlackBuilds.org repository tree there. - -If the C<$repo_path> is not empty, it will exit with a usage error. - -=cut - -sub fetch_tree { - check_repo(); - say 'Pulling SlackBuilds tree...'; - pull_sbo_tree(), return 1; -} - -=head2 generate_slackbuilds_txt - - my $bool = generate_slackbuilds_txt(); - -C<generate_slackbuilds_txt()> will generate a minimal C<SLACKBUILDS.TXT> for a -repository that doesn't come with one. If it fails, it will return a false -value. Otherwise it will return a true value. - -=cut - -sub generate_slackbuilds_txt { - my ($fh, $exit) = open_fh($slackbuilds_txt, '>'); - return 0 if $exit; - - opendir(my $dh, $repo_path) or return 0; - my @categories = - grep { -d "$repo_path/$_" } - grep { $_ !~ /^\./ } - readdir($dh); - close $dh; - - for my $cat (@categories) { - opendir(my $cat_dh, "$repo_path/$cat") or return 0; - while (my $package = readdir($cat_dh)) { - next if in($package => qw/ . .. /); - next unless -f "$repo_path/$cat/$package/$package.info"; - print { $fh } "SLACKBUILD NAME: $package\n"; - print { $fh } "SLACKBUILD LOCATION: ./$cat/$package\n"; - } - close $cat_dh; - } - close $fh; - return 1; -} - -sub latest_git_tag { - my $version = shift; - my $tag = ''; - - open(my $std_out, "git tag |") or die("dead"); - while (my $line = <$std_out>) { - if ($line =~ /^$version-/) { - $tag = $line; - } - } - close($std_out); - - chomp($tag); - - return $tag; -} - -=head2 git_sbo_tree - - my $bool = git_sbo_tree($url, $key_id); - -C<git_sbo_tree()> will C<git clone> the repository specified by C<$url> to the -C<$repo_path> if the C<$url> repository isn't already there. If it is, it will -run C<git fetch && git reset --hard origin>. - -If any command fails, it will return a false value. Otherwise it will return a -true value. - -=cut - -sub git_sbo_tree { - script_error('git_sbo_tree requires two arguments.') unless @_ == 2; - my $url = shift; - my $key_id = shift; - - my $cwd = getcwd(); - - if ((! -d "$repo_path/.git") || ! check_git_remote($repo_path, $url)) { - chdir $config{SBO_HOME} or return 0; - - remove_tree($repo_path) if -d $repo_path; - if (system(qw/ git clone --no-local /, $url, $repo_path)) { - return 0; - } - } - - _race::cond '$repo_path can be deleted after -d check'; - chdir($repo_path) or return 0; - - return 0 unless system("git fetch") == 0; - - unlink "$repo_path/SLACKBUILDS.TXT"; - - my $git_ref = 'origin'; - my $verify_cmd = 'verify-commit'; - - my $tag = latest_git_tag(get_slack_version()); - if ($tag ne '') { - $git_ref = $tag; - $verify_cmd = 'verify-tag'; - } - - if ($key_id) { - my @output; - - print("Verifying $git_ref..."); - open3(undef, undef, my $std_err = gensym, "git", $verify_cmd, "--raw", "$git_ref"); - while (my $line = <$std_err>) { - push(@output, $line); - } - close($std_err); - - my $res = parse_gpg_output(\@output, $key_id); - if ($res eq GOODSIG) { - print("OK\n"); - } else { - print(STDERR "Repository GPG verification failed: $res."); - if ($res == NO_PUBKEY) { - print(STDERR " Did you import the GPG key?"); - } - print(STDERR "\n"); - - chdir $cwd; - return 0; - } - } - - _race::cond 'git repo could be changed or deleted here'; - return 0 unless system('git', 'reset', '--hard', $git_ref) == 0; - - _race::cond '$cwd could be deleted here'; - return 0 unless chdir $cwd; - - return 1; -} - -=head2 migrate_repo - - migrate_repo(); - -C<migrate_repo()> moves an old sbotools 1.x repository to the location it needs -to be in for sbotools 2.x. This means every directory and file except for the -C<distfiles> directory in (by default) C</usr/sbo/> gets moved to -C</usr/sbo/repo>. - -=cut - -# Move everything in /usr/sbo except distfiles and repo dirs into repo dir -sub migrate_repo { - make_path($repo_path) unless -d $repo_path; - _race::cond '$repo_path can be deleted between being made and being used'; - opendir(my $dh, $config{SBO_HOME}); - foreach my $entry (readdir($dh)) { - next if in($entry => qw/ . .. repo distfiles /); - move("$config{SBO_HOME}/$entry", "$repo_path/$entry"); - } - close $dh; -} - -=head2 pull_sbo_tree - - pull_sbo_tree(); - -C<pull_sbo_tree()> will pull the SlackBuilds.org repository tree from -C<rsync://slackbuilds.org/slackbuilds/$ver/> or whatever the C<REPO> -configuration variable has been set to. - -C<$ver> is the version of Slackware you're running, provided it is supported, -or whatever you've set in the C<SLACKWARE_VERSION> configuration variable. - -=cut - -sub pull_sbo_tree { - my $url = $config{REPO}; - if ($url eq 'FALSE') { - $url = get_slack_version_url(); - } else { - unlink($slackbuilds_txt); - } - - my $key_id = ''; - if ($config{GPG_KEY} ne 'FALSE') { - $key_id = $config{GPG_KEY}; - }; - - my $res = 0; - if ($url =~ m!^rsync://!) { - $res = rsync_sbo_tree($url, $key_id); - } else { - $res = git_sbo_tree($url, $key_id); - } - - if ($res == 0) { - warn "Could not sync from $url.\n"; - if ($url eq 'https://github.com/Ponce/slackbuilds.git' && $key_id ne '') { - warn "This URL is known not to use GPG verification. You likely want to disable with 'sboconfig --gpg-key FALSE'." - } - exit _ERR_DOWNLOAD; - } - - my $wanted = sub { chown 0, 0, $File::Find::name; }; - find($wanted, $repo_path) if -d $repo_path; - if ($res and not chk_slackbuilds_txt()) { - generate_slackbuilds_txt(); - } -} - -=head2 rsync_sbo_tree - - my $bool = rsync_sbo_tree($url, $key_id); - -C<rsync_sbo_tree()> syncs the SlackBuilds.org repository to C<$repo_path> from -the C<$url> provided. - -=cut - -# rsync the sbo tree from slackbuilds.org to $repo_path -sub rsync_sbo_tree { - script_error('rsync_sbo_tree requires two arguments.') unless @_ == 2; - - my $url = shift; - $url .= '/' unless $url =~ m!/$!; # make sure $url ends with / - my $key_id = shift; - - my @info; - # only slackware versions above 14.1 have an rsync that supports --info=progress2 - if (versioncmp(get_slack_version(), '14.1') == 1) { @info = ('--info=progress2'); } - - my @args = ('rsync', @info, '-a', '--delete', $url); - return 0 unless system(@args, $repo_path) == 0; - - my $cwd = getcwd(); - chdir($repo_path); - - if ($key_id) { - if (versioncmp(get_slack_version(), '14.1') == -1) { - print("GPG verification is not present for 14.0 and earlier. You should consider disabling GPG verification.") - } - - print("Verifying CHECKSUMS.md5..."); - my $res = verify_gpg_signed_file('CHECKSUMS.md5.asc', $key_id); - if ($res eq GOODSIG) { - print("OK\n"); - } else { - print(STDERR "Respository CHECKSUMS.md5 GPG verification failed: $res."); - if ($res eq NO_PUBKEY) { - print(STDERR " Did you import the GPG key?"); - } - print(STDERR "\n"); - - chdir($cwd); - return 0; - } - } - - if ( -e "CHECKSUMS.md5" ) { - print("Verifying file integrity using CHECKSUMS.md5..."); - if (system('tail +13 CHECKSUMS.md5 | md5sum -c --quiet -')) { - chdir($cwd); - return 0; - } - print("OK\n"); - } - - return chdir($cwd); -} - -=head2 slackbuilds_or_fetch - - slackbuilds_or_fetch(); - -C<slackbuilds_or_fetch()> will check if there is a C<SLACKBUILDS.TXT> in the -C<$repo_path>, and if not, offer to run C<sbosnap fetch> for you. - -=cut - -# if the SLACKBUILDS.TXT is not in $repo_path, we assume the tree has -# not been populated there; prompt the user to automagickally pull the tree. -sub slackbuilds_or_fetch { - unless (chk_slackbuilds_txt()) { - say 'It looks like you haven\'t run "sbosnap fetch" yet.'; - if (($< == 0) && prompt("Would you like me to do this now?", default => 'yes')) { - fetch_tree(); - } else { - say 'Please run "sbosnap fetch" as root'; - exit 0; - } - } - return 1; -} - -=head2 update_tree - - update_tree(); - -C<update_tree()> will check if there is a C<SLACKBUILDS.TXT> in the -C<$repo_path>, and if not, will run C<fetch_tree()>. Otherwise it will update -the SlackBuilds.org tree. - -=cut - -sub update_tree { - fetch_tree(), return() unless chk_slackbuilds_txt(); - say 'Updating SlackBuilds tree...'; - pull_sbo_tree(), return 1; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Tree.pm b/SBO-Lib/lib/SBO/Lib/Tree.pm deleted file mode 100644 index 4353cf6..0000000 --- a/SBO-Lib/lib/SBO/Lib/Tree.pm +++ /dev/null @@ -1,161 +0,0 @@ -package SBO::Lib::Tree; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use SBO::Lib::Util qw/ script_error open_read idx %config /; -use SBO::Lib::Repo qw/ $repo_path $slackbuilds_txt /; - -use Exporter 'import'; - -our @EXPORT_OK = qw{ - get_orig_location - get_sbo_location - get_sbo_locations - is_local -}; - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Tree - Routines for interacting with a SlackBuilds.org tree. - -=head1 SYNOPSIS - - use SBO::Lib::tree qw/ is_local /; - - my $bool = is_local($sbo); - -=head1 SUBROUTINES - -=cut - -# private variables needed by most subroutines -my $store; -my %local; -my %orig; - -=head2 get_orig_location - - my $loc = get_orig_location($sbo); - -C<get_orig_location()> returns the location in the SlackBuilds.org tree for the -given C<$sbo>. - -=cut - -sub get_orig_location { - script_error('get_orig_location requires an argument.') unless @_ == 1; - my $sbo = shift; - # Make sure we have checked for the slackbuild in question: - get_sbo_location($sbo); - return $orig{$sbo}; -} - -=head2 get_sbo_location - - my $loc = get_sbo_location($sbo, ...); - my $loc = get_sbo_location([$sbo, ...]); - -C<get_sbo_location()> returns the location in the C<LOCAL_OVERRIDES> or the -SlackBuilds.org tree for the first C<$sbo> given. - -Specifying more than one C<$sbo> is useful for only needing to access the -filesystem once when searching, and populating the internal cache. - -=cut - -sub get_sbo_location { - my @sbos = map { s/-compat32$//r } defined $_[0] && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; - script_error('get_sbo_location requires an argument.') unless @sbos; - - # if we already have the location, return it now. - return $$store{$sbos[0]} if exists $$store{$sbos[0]}; - my %locations = get_sbo_locations(@sbos); - return $locations{$sbos[0]}; -} - -=head2 get_sbo_locations - - my %locations = get_sbo_locations(@sbos); - -C<get_sbo_locations> tries to find all C<@sbos> and returns a hash matching the -package name to its location. - -=cut - -sub get_sbo_locations { - my @sbos = map { s/-compat32$//r } defined $_[0] && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; - script_error('get_sbo_locations requires an argument.') unless @_; - - my %locations; - - # if an sbo is already in the $store, set the %location for it and filter it out - @sbos = grep { exists $$store{$_} ? ($locations{$_} = $$store{$_}, 0) : 1 } @sbos; - return %locations unless @sbos; - - my ($fh, $exit) = open_read($slackbuilds_txt); - if ($exit) { - warn $fh; - exit $exit; - } - - while (my $line = <$fh>) { - my ($loc, $sbo) = $line =~ m!LOCATION:\s+\.(/[^/]+/([^/\n]+))$! - or next; - my $found = idx($sbo, @sbos); - next unless defined $found; - - $$store{$sbo} = $repo_path . $loc; - $locations{$sbo} = $$store{$sbo}; - - splice @sbos, $found, 1; - last unless @sbos; - } - close $fh; - - # after we've checked the regular sbo locations, we'll see if it needs to - # be overridden by a local change - my $local = $config{LOCAL_OVERRIDES}; - unless ( $local eq 'FALSE' ) { - for my $sbo (@sbos, keys %locations) { - my $loc = "$local/$sbo"; - next unless -d $loc; - $$store{$sbo} = $loc; - $orig{$sbo} //= $locations{$sbo}; - $locations{$sbo} = $loc; - $local{$sbo} = $local; - } - } - - return %locations; -} - -=head2 is_local - - my $bool = is_local($sbo); - -C<is_local()> checks whether the given C<$sbo> is in the C<LOCAL_OVERRIDES> or -not, and returns a true value if it is, and a false value if it isn't. - -=cut - -sub is_local { - script_error('is_local requires an argument.') unless @_ == 1; - my $sbo = shift; - # Make sure we have checked for the slackbuild in question: - get_sbo_location($sbo); - return !!$local{$sbo}; -} - -1; diff --git a/SBO-Lib/lib/SBO/Lib/Util.pm b/SBO-Lib/lib/SBO/Lib/Util.pm deleted file mode 100644 index 1598cf1..0000000 --- a/SBO-Lib/lib/SBO/Lib/Util.pm +++ /dev/null @@ -1,566 +0,0 @@ -package SBO::Lib::Util; - -use 5.016; -use strict; -use warnings; - -our $VERSION = '2.8.0'; - -use Exporter 'import'; -use Sort::Versions; - -my $consts; -use constant $consts = { - _ERR_USAGE => 1, # usage errors - _ERR_SCRIPT => 2, # errors with the scripts themselves - _ERR_BUILD => 3, # errors during the slackbuild process - _ERR_MD5SUM => 4, # md5sum verification - _ERR_DOWNLOAD => 5, # errors with downloading things - _ERR_OPENFH => 6, # opening file handles - _ERR_NOINFO => 7, # missing information - _ERR_F_SETFD => 8, # unsetting exec-on-close bit - _ERR_NOMULTILIB => 9, # lacking multilib where required - _ERR_CONVERTPKG => 10, # errors while running convertpkg-compat32 - _ERR_NOCONVERTPKG => 11, # lacking convertpkg-compat32 where required -}; - -my @EXPORT_CONSTS = keys %$consts; -my @EXPORT_CONFIG = qw{ - read_config - - $conf_dir - $conf_file - %config -}; - -our @EXPORT_OK = ( - qw{ - check_multilib - get_arch - get_kernel_version - get_sbo_from_loc - get_slack_version - get_slack_version_key - get_slack_version_url - idx - in - indent - open_fh - open_read - print_failures - prompt - script_error - show_version - slurp - uniq - usage_error - version_cmp - }, - @EXPORT_CONSTS, - @EXPORT_CONFIG, -); - -our %EXPORT_TAGS = ( - all => \@EXPORT_OK, - const => \@EXPORT_CONSTS, - config => \@EXPORT_CONFIG, -); - -=pod - -=encoding UTF-8 - -=head1 NAME - -SBO::Lib::Util - Utility functions for SBO::Lib and the sbotools - -=head1 SYNOPSIS - - use SBO::Lib::Util qw/uniq/; - - # ('duplicate'); - my @uniq = uniq('duplicate', 'duplicate'); - -=head1 VARIABLES - -=head2 $conf_dir - -By default, C<$conf_dir> will be C</etc/sbotools>. - -=head2 $conf_file - -By default, C<$conf_file> will be C</etc/sbotools/sbotools.conf>. - -=head2 %config - -By default, all values are set to C<"FALSE">, but when C<read_config()> is run, -the values will change according to the configuration, and C<SBO_HOME> will by -default get changed to C</usr/sbo>. - -The supported keys are: C<NOCLEAN>, C<DISTCLEAN>, C<JOBS>, C<PKG_DIR>, -C<SBO_HOME>, C<LOCAL_OVERRIDES>, C<SLACKWARE_VERSION>, C<REPO>, C<GPG_KEY>. - -=cut - -# global config variables -our $conf_dir = '/etc/sbotools'; -our $conf_file = "$conf_dir/sbotools.conf"; -our %config = ( - NOCLEAN => 'FALSE', - DISTCLEAN => 'FALSE', - JOBS => 'FALSE', - PKG_DIR => 'FALSE', - SBO_HOME => 'FALSE', - LOCAL_OVERRIDES => 'FALSE', - SLACKWARE_VERSION => 'FALSE', - REPO => 'FALSE', - GPG_KEY => 'D3076BC3E783EE747F09B8B70368EF579C7BA3B6', -); - -read_config(); - -=head1 SUBROUTINES - -=cut - -=head2 check_multilib - - my $ml = check_multilib(); - -C<check_multilib()> checks if the file C</etc/profile.d/32dev.sh> exists, -because without it, there's no way to build 32bit things on an x64 arch. - -Returns a true value if it exists, and a false value otherwise. - -=cut - -# can't do 32-bit on x86_64 without this file, so we'll use it as the test to -# to determine whether or not an x86_64 system is setup for multilib -sub check_multilib { - return 1 if -f '/etc/profile.d/32dev.sh'; - return(); -} - -=head2 get_arch - - my $arch = get_arch(); - -C<get_arch()> returns the current machine architechture as reported by C<uname --m>. - -=cut - -sub get_arch { - chomp(my $arch = `uname -m`); - return $arch; -} - -=head2 get_kernel_version - - my $kv = get_kernel_version(); - -C<get_kernel_version()> will check what the version of the currently running -kernel is and return it in a format suitable for appending to a slackware -package version. - -=cut - -sub get_kernel_version { - state $kv; - return $kv if defined $kv; - - chomp($kv = `uname -r`); - $kv =~ s/-/_/g; - return $kv; -} - -=head2 get_sbo_from_loc - - my $sbo = get_sbo_from_loc($location); - -C<get_sbo_from_loc()> gets the package name from the C<$location> passed in -and returns it. - -=cut - -# pull the sbo name from a $location: $repo_path/system/wine, etc. -sub get_sbo_from_loc { - script_error('get_sbo_from_loc requires an argument.') unless @_ == 1; - return (shift =~ qr#/([^/]+)$#)[0]; -} - -=head2 get_slack_version - - my $version = get_slack_version(); - -C<get_slack_version()> checks which version of the SBo repository to use and if -successful, returns it. - -If there is an error in getting the slackware version, or if it's not a -supported version, an error message will be shown on STDERR, and the program -will exit. - -=cut - -# %supported maps what's in /etc/slackware-version to an rsync or https URL -my %supported = ( - '14.0' => 'rsync://slackbuilds.org/slackbuilds/14.0/', - '14.1' => 'rsync://slackbuilds.org/slackbuilds/14.1/', - '14.2' => 'rsync://slackbuilds.org/slackbuilds/14.2/', - '15.0' => 'rsync://slackbuilds.org/slackbuilds/15.0/', - '15.0+' => 'https://github.com/Ponce/slackbuilds.git', - current => 'https://github.com/Ponce/slackbuilds.git', -); - -sub get_slack_version { - return $config{SLACKWARE_VERSION} unless $config{SLACKWARE_VERSION} eq 'FALSE'; - my ($fh, $exit) = open_read('/etc/slackware-version'); - if ($exit) { - warn $fh; - exit $exit; - } - chomp(my $line = <$fh>); - close $fh; - my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; - usage_error("Unsupported Slackware version: $version\n" . - "Suggest you set the sbotools REPO setting to $supported{current}\n") - unless $supported{$version}; - return $version; -} - -=head2 get_slack_version_url - - my $url = get_slack_version_url(); - -C<get_slack_version_url()> returns the default URL for the given slackware -version. - -If there is an error in getting the URL, or if it's not a supported version, -an error message will be shown on STDERR, and the program will exit. - -=cut - -sub get_slack_version_url { - return $supported{get_slack_version()}; -} - -=head2 idx - - my $idx = idx($needle, @haystack); - -C<idx()> looks for C<$needle> in C<@haystack>, and returns the index of where -it was found, or C<undef> if it wasn't found. - -=cut - -sub idx { - for my $idx (1 .. $#_) { - $_[0] eq $_[$idx] and return $idx - 1; - } - return undef; -} - -=head2 in - - my $found = in($needle, @haystack); - -C<in()> looks for C<$needle> in C<@haystack>, and returns a true value if it -was found, and a false value otherwise. - -=cut - -# Checks if the first argument equals any of the subsequent ones -sub in { - my ($first, @rest) = @_; - foreach my $arg (@rest) { - return 1 if ref $arg eq 'Regexp' and $first =~ $arg; - return 1 if $first eq $arg; - } - return 0; -} - -=head2 indent - - my $str = indent($indent, $text); - -C<indent()> indents every non-empty line in C<$text> C<$indent> spaces and -returns the resulting string. - -=cut - -sub indent { - my ($indent, $text) = @_; - return $text unless $indent; - - my @lines = split /\n/, $text; - foreach my $line (@lines) { - next unless length($line); - $line = (" " x $indent) . $line; - } - return join "\n", @lines; -} - -=head2 open_fh - - my ($ret, $exit) = open_fh($fn, $op); - -C<open_fh()> will open C<$fn> for reading and/or writing depending on what -C<$op> is. - -It returns a list of two values. The second value is the exit status, and if it -is true, the first value will be an error message. Otherwise it will be the -opened filehandle. - -=cut - -# sub for opening files, second arg is like '<','>', etc -sub open_fh { - script_error('open_fh requires two arguments') unless @_ == 2; - unless ($_[1] eq '>') { - -f $_[0] or script_error("open_fh, $_[0] is not a file"); - } - my ($file, $op) = @_; - my $fh; - _race::cond('$file could be deleted between -f test and open'); - unless (open $fh, $op, $file) { - my $warn = "Unable to open $file.\n"; - my $exit = _ERR_OPENFH; - return ($warn, $exit); - } - return $fh; -} - -=head2 open_read - - my ($ret, $exit) = open_read($fn); - -C<open_read()> will open C<$fn> for reading. - -It returns a list of two values. The second value is the exit status, and if it -is true, the first value will be an error message. Otherwise it will be the -opened filehandle. - -=cut - -sub open_read { - return open_fh(shift, '<'); -} - -=head2 print_failures - - print_failures($failures); - -C<print_failures()> prints all the failures in the C<$failures> array reference -to STDERR if any. - -There is no useful return value. - -=cut - -# subroutine to print out failures -sub print_failures { - my $failures = shift; - if (@$failures > 0) { - warn "Failures:\n"; - for my $failure (@$failures) { - warn " $_: $$failure{$_}" for keys %$failure; - } - } -} - -=head2 prompt - - exit unless prompt "Should we continue?", default => "yes"; - -C<prompt()> prompts the user for an answer, optionally specifying a default of -C<yes> or C<no>. If the default has been specified it returns a true value in -case 'yes' was selected, and a false value if 'no' was selected. Otherwise it -returns whatever the user answered. - -=cut - -sub prompt { - my ($q, %opts) = @_; - my $def = $opts{default}; - $q = sprintf '%s [%s] ', $q, $def eq 'yes' ? 'y' : 'n' if defined $def; - - print $q; - - my $res = readline STDIN; - - if (defined $def) { - return 1 if $res =~ /^y/i; - return 0 if $res =~ /^n/i; - return $def eq 'yes' if $res =~ /^\n/; - - # if none of the above matched, we ask again - goto &prompt; - } - return $res; -} - -=head2 read_config - - read_config(); - -C<read_config()> reads in the configuration settings from -C</etc/sbotools/sbotools.conf> and updates the C<%config> hash with them. - -There is no useful return value. - -=cut - -# subroutine to suck in config in order to facilitate unit testing -sub read_config { - my $text = slurp($conf_file); - if (defined $text) { - my %conf_values = $text =~ /^(\w+)=(.*)$/mg; - for my $key (keys %config) { - $config{$key} = $conf_values{$key} if exists $conf_values{$key}; - } - $config{JOBS} = 'FALSE' unless $config{JOBS} =~ /^\d+$/; - } else { - warn "Unable to open $conf_file.\n" if -f $conf_file; - } - - $config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; - unless ($config{SBO_HOME} =~ qr#^(/|$)#) { - usage_error( "The configuration parameter SBO_HOME must be an absolute path."); - } -} - -=head2 script_error - - script_error(); - script_error($msg); - -script_error() will warn and exit, saying on STDERR - - A fatal script error has occurred. Exiting. - -If there was a $msg supplied, it will instead say - - A fatal script error has occurred: - $msg. - Exiting. - -There is no useful return value. - -=cut - -# subroutine for throwing internal script errors -sub script_error { - if (@_) { - warn "A fatal script error has occurred:\n$_[0]\nExiting.\n"; - } else { - warn "A fatal script error has occurred. Exiting.\n"; - } - exit _ERR_SCRIPT; -} - -=head2 show_version - - show_version(); - -C<show_version()> will print out the sbotools version and licensing information -to STDOUT. - -There is no useful return value. - -=cut - -sub show_version { - say "sbotools version $SBO::Lib::VERSION"; -} - -=head2 slurp - - my $data = slurp($fn); - -C<slurp()> takes a filename in C<$fn>, opens it, and reads in the entire file, -the contents of which is then returned. On error, it returns C<undef>. - -=cut - -sub slurp { - my $fn = shift; - return undef unless -f $fn; - my ($fh, $exit) = open_read($fn); - return undef if $exit; - local $/; - return scalar readline($fh); -} - -=head2 uniq - - my @uniq = uniq(@duplicates); - -C<uniq()> removes the duplicates from C<@duplicates> but otherwise returns the -list in the same order. - -=cut - -sub uniq { - my %seen; - return grep { !$seen{$_}++ } @_; -} - -=head2 usage_error - - usage_error($msg); - -usage_error will warn and exit, saying on STDERR - - $msg - -There is no useful return value. - -=cut - -# subroutine for usage errors -sub usage_error { - warn shift ."\n"; - exit _ERR_USAGE; -} - -=head2 version_cmp - - my $cmp = version_cmp($ver1, $ver2); - -C<version_cmp()> will compare C<$ver1> with C<$ver2> to try to determine which -is bigger than the other, and returns 1 if C<$ver1> is bigger, -1 if C<$ver2> -is bigger, and 0 if they are just as big. Before making the comparison, it will -strip off the version of your running kernel as well as any locale information -if it happens to be appended to the version string being compared. - -=cut - -# wrapper around versioncmp for checking if versions have kernel version -# or locale info appended to them -sub version_cmp { - my ($v1, $v2) = @_; - my $kv = get_kernel_version(); - - # strip off kernel version - if ($v1 =~ /(.+)_\Q$kv\E$/) { $v1 = $1 } - if ($v2 =~ /(.+)_\Q$kv\E$/) { $v2 = $1 } - - # if $v2 doesn't end in the same thing, strip off locale info from $v1 - if ($v1 =~ /(.*)_([a-z]{2})_([A-Z]{2})$/) { - my $v = $1; - if ($v2 !~ /_$2_$3$/) { $v1 = $v; } - } - # and vice versa... - if ($v2 =~ /(.*)_([a-z]{2})_([A-Z]{2})$/) { - my $v = $1; - if ($v1 !~ /_$2_$3$/) { $v2 = $v; } - } - - versioncmp($v1, $v2); -} - -# _race::cond will allow both documenting and testing race conditions -# by overriding its implementation for tests -sub _race::cond { return } - -1; diff --git a/SBO-Lib/lib/Sort/Versions.pm b/SBO-Lib/lib/Sort/Versions.pm deleted file mode 100644 index 1bcde93..0000000 --- a/SBO-Lib/lib/Sort/Versions.pm +++ /dev/null @@ -1,162 +0,0 @@ -package Sort::Versions; -$Sort::Versions::VERSION = '1.62'; -# 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. - -use 5.006; -use strict; -use warnings; - -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT = qw(&versions &versioncmp); -our @EXPORT_OK = qw(); - -sub versioncmp ($$) { - 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; -} - -sub versions () { - my $callerpkg = (caller)[0]; - my $caller_a = "${callerpkg}::a"; - my $caller_b = "${callerpkg}::b"; - no strict 'refs'; - return versioncmp($$caller_a, $$caller_b); -} - -=encoding utf-8 - -=head1 NAME - -Sort::Versions - a perl 5 module for sorting of revision-like numbers - -=head1 SYNOPSIS - - use Sort::Versions; - @l = sort { versioncmp($a, $b) } qw( 1.2 1.2.0 1.2a.0 1.2.a 1.a 02.a ); - - ... - - use Sort::Versions; - print 'lower' if versioncmp('1.2', '1.2a') == -1; - - ... - - use Sort::Versions; - %h = (1 => 'd', 2 => 'c', 3 => 'b', 4 => 'a'); - @h = sort { versioncmp($h{$a}, $h{$b}) } keys %h; - -=head1 DESCRIPTION - -Sort::Versions allows easy sorting of mixed non-numeric and numeric strings, -like the 'version numbers' that many shared library systems and revision -control packages use. This is quite useful if you are trying to deal with -shared libraries. It can also be applied to applications that intersperse -variable-width numeric fields within text. Other applications can -undoubtedly be found. - -For an explanation of the algorithm, it's simplest to look at these examples: - - 1.1 < 1.2 - 1.1a < 1.2 - 1.1 < 1.1.1 - 1.1 < 1.1a - 1.1.a < 1.1a - 1 < a - a < b - 1 < 2 - 1.1-3 < 1.1-4 - 1.1-5 < 1.1.6 - -More precisely (but less comprehensibly), the two strings are treated -as subunits delimited by periods or hyphens. Each subunit can contain -any number of groups of digits or non-digits. If digit groups are -being compared on both sides, a numeric comparison is used, otherwise -a ASCII ordering is used. A group or subgroup with more units will win -if all comparisons are equal. A period binds digit groups together -more tightly than a hyphen. - -Some packages use a different style of version numbering: a simple -real number written as a decimal. Sort::Versions has limited support -for this style: when comparing two subunits which are both digit -groups, if either subunit has a leading zero, then both are treated -like digits after a decimal point. So for example: - - 0002 < 1 - 1.06 < 1.5 - -This wonE<39>t always work, because there wonE<39>t always be a leading zero -in real-number style version numbers. There is no way for -Sort::Versions to know which style was intended. But a lot of the time -it will do the right thing. If you are making up version numbers, the -style with (possibly) more than one dot is the style to use. - -=head1 USAGE - -The function C<versioncmp()> takes two arguments and compares them like C<cmp>. -With perl 5.6 or later, you can also use this function directly in sorting: - - @l = sort versioncmp qw(1.1 1.2 1.0.3); - -The function C<versions()> can be used directly as a sort function even on -perl 5.005 and earlier, but its use is deprecated. - -=head1 SEE ALSO - -L<version>, L<CPAN::Version> which is part of the L<CPAN> distribution. - - -=head1 REPOSITORY - -L<https://github.com/neilb/Sort-Versions> - -=head1 AUTHOR - -Ed Avis <ed@membled.com> and Matt Johnson <mwj99@doc.ic.ac.uk> for -recent releases; the original author is Kenneth J. Albanowski -<kjahds@kjahds.com>. Thanks to Hack Kampbjørn and Slaven Rezic for -patches and bug reports. - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 1996 by Kenneth J. Albanowski. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut - -1; - |