Build.pm (21238B)
1 package SBO::Lib::Build; 2 3 use 5.016; 4 use strict; 5 use warnings; 6 7 our $VERSION = '2.9.0'; 8 9 use SBO::Lib::Util qw/ :const prompt script_error get_sbo_from_loc get_arch check_multilib uniq %config in /; 10 use SBO::Lib::Tree qw/ get_sbo_location /; 11 use SBO::Lib::Info qw/ get_sbo_version check_x32 get_requires /; 12 use SBO::Lib::Download qw/ get_sbo_downloads get_dl_fns get_filename_from_link check_distfiles /; 13 14 use Exporter 'import'; 15 use Fcntl qw(F_SETFD F_GETFD); 16 use File::Copy; # copy() and move() 17 use File::Path qw/ make_path remove_tree /; 18 use File::Temp qw/ tempdir tempfile /; 19 use Tie::File; 20 use Cwd; 21 22 our @EXPORT_OK = qw{ 23 do_convertpkg 24 do_slackbuild 25 do_upgradepkg 26 get_build_queue 27 get_dc_regex 28 get_pkg_name 29 get_src_dir 30 get_tmp_extfn 31 make_clean 32 make_distclean 33 merge_queues 34 perform_sbo 35 process_sbos 36 revert_slackbuild 37 rewrite_slackbuild 38 run_tee 39 40 $tmpd 41 $env_tmp 42 }; 43 44 our %EXPORT_TAGS = ( 45 all => \@EXPORT_OK, 46 ); 47 48 =pod 49 50 =encoding UTF-8 51 52 =head1 NAME 53 54 SBO::Lib::Build - Routines for building slackware packages from SlackBuilds.org. 55 56 =head1 SYNOPSIS 57 58 use SBO::Lib::Build qw/ perform_sbo /; 59 60 my ($foo, $bar, $exit) = perform_sbo(LOCATION => $location, ARCH => 'x86_64'); 61 62 =head1 VARIABLES 63 64 =head2 $env_tmp 65 66 This will reflect the C<$TMP> from the environment, being C<undef> if it is not 67 set. 68 69 =head2 $tmpd 70 71 Will be the same as C<$TMP> if it is set, otherwise it will be C</tmp/SBo>. 72 73 =cut 74 75 # get $TMP from the env, if defined - we use two variables here because there 76 # are times when we need to know if the environment variable is set, and other 77 # times where it doesn't matter. 78 our $env_tmp = $ENV{TMP}; 79 our $tmpd = $env_tmp ? $env_tmp : '/tmp/SBo'; 80 make_path($tmpd) unless -d $tmpd; 81 82 =head1 SUBROUTINES 83 84 =cut 85 86 =head2 do_convertpkg 87 88 my ($name32, $exit) = do_convertpkg($name64); 89 90 C<do_convertpkg()> runs C<convertpkg> on the package in C<$name64>. 91 92 It returns two values. If the second value is true, the first will contain an 93 error message. Otherwise it will contain the name of the converted package. 94 95 =cut 96 97 # run convertpkg on a package to turn it into a -compat32 thing 98 sub do_convertpkg { 99 script_error('do_convertpkg requires an argument.') unless @_ == 1; 100 my $pkg = shift; 101 my $c32tmpd = $env_tmp // '/tmp'; 102 103 my ($out, $ret) = run_tee("/bin/bash -c '/usr/sbin/convertpkg-compat32 -i $pkg -d $c32tmpd'"); 104 105 if ($ret != 0) { 106 return "convertpkg-compt32 returned non-zero exit status\n", 107 _ERR_CONVERTPKG; 108 } 109 unlink $pkg; 110 return get_pkg_name($out); 111 } 112 113 =head2 do_slackbuild 114 115 my ($ver, $pkg, $src, $exit) = do_slackbuild(LOCATION => $location); 116 117 C<do_slackbuild()> will make some checks and set up the C<perform_sbo()> call, 118 if needed run C<do_convertpkg()>, and return the results. 119 120 It will return a list of four values. If the fourth one is a true value, the 121 first one will be an error message. Otherwise the first will be the version, 122 the second will be the package, and the third will be an array reference to the 123 source directories created by the build. 124 125 =cut 126 127 # "public interface", sort of thing. 128 sub do_slackbuild { 129 my %args = ( 130 OPTS => 0, 131 JOBS => 0, 132 LOCATION => '', 133 COMPAT32 => 0, 134 @_ 135 ); 136 $args{LOCATION} or script_error('do_slackbuild requires LOCATION.'); 137 my $location = $args{LOCATION}; 138 my $sbo = get_sbo_from_loc($location); 139 my $arch = get_arch(); 140 my $multilib = check_multilib(); 141 my $version = get_sbo_version($location); 142 my $x32; 143 # ensure x32 stuff is set correctly, or that we're setup for it 144 if ($args{COMPAT32}) { 145 unless ($multilib) { 146 return "compat32 requires multilib.\n", (undef) x 2, 147 _ERR_NOMULTILIB; 148 } 149 unless (-f '/usr/sbin/convertpkg-compat32') { 150 return "compat32 requires /usr/sbin/convertpkg-compat32.\n", 151 (undef) x 2, _ERR_NOCONVERTPKG; 152 } 153 } else { 154 if ($arch eq 'x86_64') { 155 $x32 = check_x32 $args{LOCATION}; 156 if ($x32 && ! $multilib) { 157 my $warn = 158 "$sbo is 32-bit which requires multilib on x86_64.\n"; 159 return $warn, (undef) x 2, _ERR_NOMULTILIB; 160 } 161 } 162 } 163 # setup and run the .SlackBuild itself 164 my ($pkg, $src, $exit) = perform_sbo( 165 OPTS => $args{OPTS}, 166 JOBS => $args{JOBS}, 167 LOCATION => $location, 168 ARCH => $arch, 169 C32 => $args{COMPAT32}, 170 X32 => $x32, 171 ); 172 return $pkg, (undef) x 2, $exit if $exit; 173 if ($args{COMPAT32}) { 174 ($pkg, $exit) = do_convertpkg($pkg); 175 return $pkg, (undef) x 2, $exit if $exit; 176 } 177 return $version, $pkg, $src; 178 } 179 180 =head2 do_upgradepkg 181 182 do_upgradepkg($pkg); 183 184 C<do_upgradepkg()> runs C<upgradepkg> on C<$pkg>. 185 186 There is no useful return value. 187 188 =cut 189 190 # run upgradepkg for a created package 191 sub do_upgradepkg { 192 script_error('do_upgradepkg requires an argument.') unless @_ == 1; 193 system('/sbin/upgradepkg', '--reinstall', '--install-new', shift); 194 return 1; 195 } 196 197 =head2 get_build_queue 198 199 my @queue = @{ get_build_queue($sbo, my $warnings) }; 200 201 C<get_build_queue()> gets the prerequisites for C<$sbo>, and updates the 202 C<$warnings> hash reference with any C<%README%> encountered. It returns the 203 prerequisites and the C<$sbo> in the order in which they need to be built. 204 205 =cut 206 207 sub get_build_queue { 208 script_error('get_build_queue requires two arguments.') unless @_ == 2; 209 return [ _build_queue(@_) ]; 210 } 211 212 =head2 get_dc_regex 213 214 my ($rx, $initial) = get_dc_regex($line); 215 216 C<get_dc_regex()> when given a line that is an untar or similar command, creates 217 a regular expression which should match the filename. This is returned, together 218 with the C<$initial> character which will start the filename match. 219 220 =cut 221 222 # given a line that looks like it's decompressing something, try to return a 223 # valid filename regex 224 sub get_dc_regex { 225 my $line = shift; 226 # get rid of initial 'tar x'whatever stuff 227 $line =~ s/^.*(?<![a-z])(tar|p7zip|unzip|ar|rpm2cpio|sh)\s+[^\s]+\s+//; 228 # need to know preceeding character - should be safe to assume it's either 229 # a slash or a space 230 my $initial = $line =~ qr|/| ? '/' : ' '; 231 # get rid of initial path info 232 $line =~ s|^\$[^/]+/||; 233 # convert any instances of command substitution to [^-]+ 234 $line =~ s/\$\([^)]+\)/[^-]+/g; 235 # convert any bash variables to [^-]+ 236 $line =~ s/\$(\{|)[A-Za-z0-9_]+(}|)/[^-]+/g; 237 # get rid of anything excess at the end 238 $line =~ s/\s+.*$//; 239 # fix .?z* at the end 240 $line =~ s/\.\?z\*/\.[a-z]z.*/; 241 # return what's left as a regex 242 my $regex = qr/$initial$line/; 243 return $regex, $initial; 244 } 245 246 =head2 get_pkg_name 247 248 my $name = get_pkg_name($str); 249 250 C<get_pkg_name()> searches C<$str> for text matching the output of C<makepkg> 251 where it outputs the filename of the package it made, and returns it. 252 253 =cut 254 255 # pull the created package name from the temp file we tee'd to 256 sub get_pkg_name { 257 my $str = shift; 258 259 my ($out) = $str =~ m/^Slackware\s+package\s+([^\s]+)\s+created\.$/m; 260 261 return $out; 262 } 263 264 =head2 get_src_dir 265 266 my @dirs = @{ get_src_dir(@orig_dirs) }; 267 268 C<get_src_dir()> returns a list of the directories under C</tmp/SBo> or C<$TMP> 269 that aren't in @orig_dirs. 270 271 =cut 272 273 sub get_src_dir { 274 my @ls = @_; 275 my @src_dirs; 276 # scripts use either $TMP or /tmp/SBo 277 if (opendir(my $tsbo_dh, $tmpd)) { 278 FIRST: while (my $ls = readdir $tsbo_dh) { 279 next FIRST if in($ls => qw/ . .. /, qr/^package-/, @ls); 280 next FIRST unless -d "$tmpd/$ls"; 281 282 push @src_dirs, $ls; 283 } 284 close $tsbo_dh; 285 } 286 return \@src_dirs; 287 } 288 289 =head2 get_tmp_extfn 290 291 my ($ret, $exit) = get_tmp_extfn($fh); 292 293 C<get_tmp_extfn()> gets the filename in the form of C</dev/fd/X> for the C<$fh> 294 passed in, setting flags on it that make it usable from other processes without 295 messing things up. 296 297 It returns the filename if successful, otherwise it returns C<undef>. 298 299 =cut 300 301 # return a filename from a temp fh for use externally 302 sub get_tmp_extfn { 303 script_error('get_tmp_extfn requires an argument.') unless @_ == 1; 304 my $fh = shift; 305 unless (fcntl($fh, F_SETFD, 0)) { return undef; } 306 return '/dev/fd/'. fileno $fh; 307 } 308 309 =head2 make_clean 310 311 make_clean(SBO => $sbo, SRC => $src, VERSION => $ver); 312 313 C<make_clean()> removes source directories, package directories, and compat32 314 directories that are left over from a slackbuild run. 315 316 It has no useful return value. 317 318 =cut 319 320 # remove work directories (source and packaging dirs under /tmp/SBo or $TMP and /tmp or $OUTPUT) 321 sub make_clean { 322 my %args = ( 323 SBO => '', 324 SRC => '', 325 VERSION => '', 326 @_ 327 ); 328 unless ($args{SBO} && $args{SRC} && $args{VERSION}) { 329 script_error('make_clean requires three arguments.'); 330 } 331 my $src = $args{SRC}; 332 say "Cleaning for $args{SBO}-$args{VERSION}..."; 333 for my $dir (@$src) { 334 remove_tree("$tmpd/$dir") if -d "$tmpd/$dir"; 335 } 336 337 my $output = $ENV{OUTPUT} // '/tmp'; 338 remove_tree("$output/package-$args{SBO}") if 339 -d "$output/package-$args{SBO}"; 340 341 if ($args{SBO} =~ /^(.+)-compat32$/) { 342 my $pkg_name = $1; 343 remove_tree("/tmp/package-$args{SBO}") if 344 not defined $env_tmp and 345 -d "/tmp/package-$args{SBO}"; 346 remove_tree("$tmpd/package-$pkg_name") if 347 -d "$tmpd/package-$pkg_name"; 348 } 349 return 1; 350 } 351 352 =head2 make_distclean 353 354 make_distclean(SRC => $src, VERSION => $ver, LOCATION => $loc); 355 356 C<make_distclean()> does everything C<make_clean()> does, but in addition it 357 also removes distribution files, such as the downloaded source tarballs. 358 359 It has no useful return value. 360 361 =cut 362 363 # remove distfiles 364 sub make_distclean { 365 my %args = ( 366 SRC => '', 367 VERSION => '', 368 LOCATION => '', 369 @_ 370 ); 371 unless ($args{SRC} && $args{VERSION} && $args{LOCATION}) { 372 script_error('make_distclean requires four arguments.'); 373 } 374 my $sbo = get_sbo_from_loc($args{LOCATION}); 375 make_clean(SBO => $sbo, SRC => $args{SRC}, VERSION => $args{VERSION}); 376 say "Distcleaning for $sbo-$args{VERSION}..."; 377 # remove any distfiles for this particular SBo. 378 my $downloads = get_sbo_downloads(LOCATION => $args{LOCATION}); 379 for my $key (keys %$downloads) { 380 my $filename = get_filename_from_link($key); 381 unlink $filename if -f $filename; 382 } 383 return 1; 384 } 385 386 =head2 merge_queues 387 388 my @merged = @{ merge_queues([@queue1], [@queue2]) }; 389 390 C<merge_queues> takes two array references and merges them with C<@queue1> in 391 front, and then anything in C<@queue2> that wasn't already in C<@queue1>. This 392 is then returned as an array reference. 393 394 =cut 395 396 sub merge_queues { 397 # Usage: merge_queues(\@queue_a, \@queue_b); 398 # Results in queue_b being merged into queue_a (without duplicates) 399 script_error('merge_queues requires two arguments.') unless @_ == 2; 400 401 return [ uniq @{$_[0]}, @{$_[1]} ]; 402 } 403 404 =head2 perform_sbo 405 406 my ($pkg, $src, $exit) = perform_sbo(LOCATION => $location, ARCH => $arch); 407 408 C<perform_sbo()> preps and runs a .SlackBuild. It returns a list of three 409 values, and if the third one is a true value, the first one will be an error 410 message. Otherwise the first one will be the package name that was built, and 411 the second one will be an array reference containing the source directories 412 that were created. 413 414 =cut 415 416 # prep and run .SlackBuild 417 sub perform_sbo { 418 my %args = ( 419 OPTS => 0, 420 JOBS => 0, 421 LOCATION => '', 422 ARCH => '', 423 C32 => 0, 424 X32 => 0, 425 @_ 426 ); 427 unless ($args{LOCATION} && $args{ARCH}) { 428 script_error('perform_sbo requires LOCATION and ARCH.'); 429 } 430 431 my $location = $args{LOCATION}; 432 my $sbo = get_sbo_from_loc($location); 433 434 # we need to get a listing of /tmp/SBo, or $TMP, if we can, before we run 435 # the SlackBuild so that we can compare to a listing taken afterward. 436 my @src_ls; 437 if (opendir(my $tsbo_dh, $tmpd)) { 438 @src_ls = grep { ! in( $_ => qw/ . .. /) } readdir $tsbo_dh; 439 } 440 441 my ($cmd, %changes); 442 # set any changes we need to make to the .SlackBuild, setup the command 443 444 $cmd = ''; 445 446 if ($args{ARCH} eq 'x86_64' and ($args{C32} || $args{X32})) { 447 if ($args{C32}) { 448 $changes{libdirsuffix} = ''; 449 } elsif ($args{X32}) { 450 $changes{arch_out} = 'i486'; 451 } 452 $cmd .= '. /etc/profile.d/32dev.sh &&'; 453 } 454 if ($args{JOBS} and $args{JOBS} ne 'FALSE') { 455 $changes{jobs} = 1; 456 } 457 $cmd .= " $args{OPTS}" if $args{OPTS}; 458 $cmd .= " MAKEOPTS=\"-j$args{JOBS}\"" if $changes{jobs}; 459 460 # set TMP/OUTPUT if set in the environment 461 $cmd .= " TMP=$env_tmp" if $env_tmp; 462 $cmd .= " OUTPUT=$ENV{OUTPUT}" if defined $ENV{OUTPUT}; 463 $cmd .= " /bin/bash $location/$sbo.SlackBuild"; 464 465 # attempt to rewrite the slackbuild, or exit if we can't 466 my ($fail, $exit) = rewrite_slackbuild( 467 SBO => $sbo, 468 SLACKBUILD => "$location/$sbo.SlackBuild", 469 CHANGES => \%changes, 470 C32 => $args{C32}, 471 ); 472 return $fail, undef, $exit if $exit; 473 474 # run the slackbuild, grab its exit status, revert our changes 475 my $cwd = getcwd(); 476 chdir $location; 477 my ($out, $ret) = run_tee($cmd); 478 chdir $cwd; 479 480 revert_slackbuild("$location/$sbo.SlackBuild"); 481 # return error now if the slackbuild didn't exit 0 482 return "$sbo.SlackBuild return non-zero\n", undef, _ERR_BUILD if $ret != 0; 483 my $pkg = get_pkg_name($out); 484 return "$sbo.SlackBuild didn't create a package\n", undef, _ERR_BUILD if not defined $pkg; 485 my $src = get_src_dir(@src_ls); 486 return $pkg, $src; 487 } 488 489 =head2 process_sbos 490 491 my ($failures, $exit) = process_sbos(TODO => [@queue]); 492 493 C<process_sbos()> processes the C<@queue> of slackbuilds and returns a list of 494 two values containing any failed builds in an array ref in the first value, and 495 the exit status in the second. 496 497 =cut 498 499 # do the things with the provided sbos - whether upgrades or new installs. 500 sub process_sbos { 501 my %args = ( 502 TODO => '', 503 CMDS => '', 504 OPTS => '', 505 JOBS => 'FALSE', 506 LOCATIONS => '', 507 NOINSTALL => 0, 508 NOCLEAN => 'FALSE', 509 DISTCLEAN => 'FALSE', 510 NON_INT => 0, 511 @_ 512 ); 513 my $todo = $args{TODO}; 514 my $cmds = $args{CMDS}; 515 my $opts = $args{OPTS}; 516 my $locs = $args{LOCATIONS}; 517 my $jobs = $args{JOBS} =~ /^\d+$/ ? $args{JOBS} : 0; 518 @$todo >= 1 or script_error('process_sbos requires TODO.'); 519 my (@failures, @symlinks, $err); 520 FIRST: for my $sbo (@$todo) { 521 my $compat32 = $sbo =~ /-compat32$/ ? 1 : 0; 522 my ($temp_syms, $exit) = check_distfiles( 523 LOCATION => $$locs{$sbo}, COMPAT32 => $compat32 524 ); 525 # if $exit is defined, prompt to proceed or return with last $exit 526 if ($exit) { 527 $err = $exit; 528 my $fail = $temp_syms; 529 push @failures, {$sbo => $fail}; 530 # return now if we're not interactive 531 return \@failures, $exit if $args{NON_INT}; 532 say "Unable to download/verify source file(s) for $sbo:"; 533 say " $fail"; 534 if (prompt('Do you want to proceed?' , default => 'no')) { 535 next FIRST; 536 } else { 537 unlink for @symlinks; 538 return \@failures, $exit; 539 } 540 } else { 541 push @symlinks, @$temp_syms; 542 } 543 } 544 my $count = 0; 545 FIRST: for my $sbo (@$todo) { 546 $count++; 547 my $options = $$opts{$sbo} // 0; 548 my $cmds = $$cmds{$sbo} // []; 549 for my $cmd (@$cmds) { 550 system($cmd) == 0 or warn "\"$cmd\" exited non-zero\n"; 551 } 552 # switch compat32 on if upgrading/installing a -compat32 553 # else make sure compat32 is off 554 my $compat32 = $sbo =~ /-compat32$/ ? 1 : 0; 555 my ($version, $pkg, $src, $exit) = do_slackbuild( 556 OPTS => $options, 557 JOBS => $jobs, 558 LOCATION => $$locs{$sbo}, 559 COMPAT32 => $compat32, 560 ); 561 if ($exit) { 562 my $fail = $version; 563 push @failures, {$sbo => $fail}; 564 # return now if we're not interactive 565 return \@failures, $exit if $args{NON_INT}; 566 # or if this is the last $sbo 567 return \@failures, $exit if $count == @$todo; 568 say "Failure encountered while building $sbo:"; 569 say " $fail"; 570 if (prompt('Do you want to proceed?', default => 'no')) { 571 next FIRST; 572 } else { 573 unlink for @symlinks; 574 return \@failures, $exit; 575 } 576 } 577 578 do_upgradepkg($pkg) unless $args{NOINSTALL}; 579 580 unless ($args{DISTCLEAN}) { 581 make_clean(SBO => $sbo, SRC => $src, VERSION => $version) 582 unless $args{NOCLEAN}; 583 } else { 584 make_distclean( 585 SBO => $sbo, 586 SRC => $src, 587 VERSION => $version, 588 LOCATION => $$locs{$sbo}, 589 ); 590 } 591 # move package to $config{PKG_DIR} if defined 592 unless ($config{PKG_DIR} eq 'FALSE') { 593 my $dir = $config{PKG_DIR}; 594 unless (-d $dir) { 595 mkdir($dir) or warn "Unable to create $dir\n"; 596 } 597 if (-d $dir) { 598 move($pkg, $dir), say "$pkg stored in $dir"; 599 } else { 600 warn "$pkg left in $tmpd\n"; 601 } 602 } elsif ($args{DISTCLEAN}) { 603 unlink $pkg; 604 } 605 } 606 unlink for @symlinks; 607 return \@failures, $err; 608 } 609 610 =head2 revert_slackbuild 611 612 revert_slackbuild($path); 613 614 C<revert_slackbuild()> moves back a slackbuild that was rewritten by 615 C<rewrite_slackbuild()>. 616 617 There is no useful return value. 618 619 =cut 620 621 # move a backed-up .SlackBuild file back into place 622 sub revert_slackbuild { 623 script_error('revert_slackbuild requires an argument') unless @_ == 1; 624 my $slackbuild = shift; 625 if (-f "$slackbuild.orig") { 626 unlink $slackbuild if -f $slackbuild; 627 rename "$slackbuild.orig", $slackbuild; 628 } 629 return 1; 630 } 631 632 =head2 rewrite_slackbuild 633 634 my ($ret, $exit) = rewrite_slackbuild(SLACKBUILD => $path); 635 636 C<rewrite_slackbuild()> when given a path and some changes to make, will move 637 and copy the C<$path> and rewrite the copy with the needed changes. 638 639 It returns a list of two values. The second value is the exit status, and if it 640 is true, the first value will be an error message. 641 642 =cut 643 644 # make a backup of the existent SlackBuild, and rewrite the original as needed 645 sub rewrite_slackbuild { 646 my %args = ( 647 SBO => '', 648 SLACKBUILD => '', 649 CHANGES => {}, 650 C32 => 0, 651 @_ 652 ); 653 $args{SLACKBUILD} or script_error('rewrite_slackbuild requires SLACKBUILD.'); 654 my $slackbuild = $args{SLACKBUILD}; 655 my $changes = $args{CHANGES}; 656 657 # $status will be undefined if either the rename or the copy fails, otherwise it will be 1 658 my $status = eval { 659 rename($slackbuild, "$slackbuild.orig") or die "not ok"; 660 copy("$slackbuild.orig", $slackbuild) or die "not ok"; 661 1; 662 }; 663 if (not $status) { 664 rename "$slackbuild.orig", $slackbuild if not -f $slackbuild; 665 return "Unable to backup $slackbuild to $slackbuild.orig\n", 666 _ERR_OPENFH; 667 } 668 669 my $libdir_regex = qr/^\s*LIBDIRSUFFIX="64"\s*$/; 670 my $arch_regex = qr/\$VERSION-\$ARCH-\$BUILD/; 671 my $dc_regex = qr/(?<![a-z])(tar|p7zip|unzip|ar|rpm2cpio|sh)\s+/; 672 my $make_regex = qr/^\s*make\s*$/; 673 # tie the slackbuild, because this is the easiest way to handle this. 674 tie my @sb_file, 'Tie::File', $slackbuild; 675 # if we're dealing with a compat32, we need to change the tar line(s) so 676 # that the 32-bit source is untarred 677 if ($args{C32}) { 678 my $location = get_sbo_location($args{SBO}); 679 my $downloads = get_sbo_downloads( 680 LOCATION => $location, 681 32 => 1, 682 ); 683 my $fns = get_dl_fns([keys %$downloads]); 684 for my $line (@sb_file) { 685 if ($line =~ $dc_regex) { 686 my ($regex, $initial) = get_dc_regex($line); 687 for my $fn (@$fns) { 688 $fn = "$initial$fn"; 689 $line =~ s/$regex/$fn/ if $fn =~ $regex; 690 } 691 } 692 } 693 } 694 for my $line (@sb_file) { 695 # then check for and apply any other %$changes 696 if (exists $$changes{libdirsuffix}) { 697 $line =~ s/64/$$changes{libdirsuffix}/ if $line =~ $libdir_regex; 698 } 699 if (exists $$changes{arch_out}) { 700 $line =~ s/\$ARCH/$$changes{arch_out}/ if $line =~ $arch_regex; 701 } 702 if (exists $changes->{jobs}) { 703 $line =~ s/make/make \$MAKEOPTS/ if $line =~ $make_regex; 704 } 705 } 706 untie @sb_file; 707 return 1; 708 } 709 710 =head2 run_tee 711 712 my ($output, $exit) = run_tee($cmd); 713 714 C<run_tee()> runs the C<$cmd >under C<tee(1)> to allow both displaying its 715 output and returning it as a string. It returns a list of the output and the 716 exit status (C<$?> in bash). If it can't even run the bash interpreter, the 717 output will be C<undef> and the exit status will hold a true value. 718 719 =cut 720 721 sub run_tee { 722 my $cmd = shift; 723 724 my $tempdir = tempdir(CLEANUP => 1, DIR => $tmpd); 725 726 my $out_fh = tempfile(DIR => $tempdir); 727 my $out_fn = get_tmp_extfn($out_fh); 728 return undef, _ERR_F_SETFD if not defined $out_fn; 729 730 my $exit_fh = tempfile(DIR => $tempdir); 731 my $exit_fn = get_tmp_extfn($exit_fh); 732 return undef, _ERR_F_SETFD if not defined $exit_fn; 733 734 $cmd = sprintf '( %s; echo $? > %s ) | tee %s', $cmd, $exit_fn, $out_fn; 735 736 my $ret = system('/bin/bash', '-c', $cmd); 737 738 return undef, $ret if $ret; 739 740 seek $exit_fh, 0, 0; 741 chomp($ret = readline $exit_fh); 742 743 seek $out_fh, 0, 0; 744 my $out = do { local $/; readline $out_fh; }; 745 746 return $out, $ret; 747 } 748 749 sub _build_queue { 750 my ($sbos, $warnings) = @_; 751 my @queue = @$sbos; 752 my @result; 753 754 while (my $sbo = shift @queue) { 755 next if $sbo eq "%README%"; 756 my $reqs = get_requires($sbo); 757 if (defined $reqs) { 758 push @result, _build_queue($reqs, $warnings); 759 foreach my $req (@$reqs) { 760 $warnings->{$sbo}="%README%" if $req eq "%README%"; 761 } 762 } 763 else { 764 $warnings->{$sbo} = "nonexistent"; 765 } 766 push @result, $sbo; 767 } 768 769 return uniq @result; 770 } 771 772 1;