package SBO::Lib::Build; use 5.016; use strict; use warnings; our $VERSION = '2.6'; 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 $tempdir $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 if it is not set. =head2 $tmpd Will be the same as C<$TMP> if it is set, otherwise it will be C. =head2 $tempdir This is a temporary directory created for sbotools' use, and it should be cleaned up when sbotools exits. =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; our $tempdir = tempdir(CLEANUP => 1, DIR => $tmpd); =head1 SUBROUTINES =cut =head2 do_convertpkg my ($name32, $exit) = do_convertpkg($name64); C runs C 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 will make some checks and set up the C call, if needed run C, 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 runs C 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 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 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/^.*(? searches C<$str> for text matching the output of C 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 returns a list of the directories under C 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 gets the filename in the form of C 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. =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 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 does everything C 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 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 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 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 moves back a slackbuild that was rewritten by C. 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 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/(? $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 runs the C<$cmd >under C 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 and the exit status will hold a true value. =cut sub run_tee { my $cmd = shift; 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; } =head1 AUTHORS SBO::Lib was originally written by Jacob Pipkin with contributions from Luke Williams and Andreas Guldstrand . =head1 LICENSE The sbotools are licensed under the WTFPL . Copyright (C) 2012-2017, Jacob Pipkin, Luke Williams, Andreas Guldstrand. =cut 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;