Util.pm (12842B)
1 package SBO::Lib::Util; 2 3 use 5.016; 4 use strict; 5 use warnings; 6 7 our $VERSION = '2.9.0'; 8 9 use Exporter 'import'; 10 use Sort::Versions; 11 12 my $consts; 13 use constant $consts = { 14 _ERR_USAGE => 1, # usage errors 15 _ERR_SCRIPT => 2, # errors with the scripts themselves 16 _ERR_BUILD => 3, # errors during the slackbuild process 17 _ERR_MD5SUM => 4, # md5sum verification 18 _ERR_DOWNLOAD => 5, # errors with downloading things 19 _ERR_OPENFH => 6, # opening file handles 20 _ERR_NOINFO => 7, # missing information 21 _ERR_F_SETFD => 8, # unsetting exec-on-close bit 22 _ERR_NOMULTILIB => 9, # lacking multilib where required 23 _ERR_CONVERTPKG => 10, # errors while running convertpkg-compat32 24 _ERR_NOCONVERTPKG => 11, # lacking convertpkg-compat32 where required 25 }; 26 27 my @EXPORT_CONSTS = keys %$consts; 28 my @EXPORT_CONFIG = qw{ 29 read_config 30 31 $conf_dir 32 $conf_file 33 %config 34 }; 35 36 our @EXPORT_OK = ( 37 qw{ 38 check_multilib 39 get_arch 40 get_kernel_version 41 get_sbo_from_loc 42 get_slack_version 43 get_slack_version_key 44 get_slack_version_url 45 idx 46 in 47 indent 48 open_fh 49 open_read 50 print_failures 51 prompt 52 script_error 53 show_version 54 slurp 55 uniq 56 usage_error 57 version_cmp 58 }, 59 @EXPORT_CONSTS, 60 @EXPORT_CONFIG, 61 ); 62 63 our %EXPORT_TAGS = ( 64 all => \@EXPORT_OK, 65 const => \@EXPORT_CONSTS, 66 config => \@EXPORT_CONFIG, 67 ); 68 69 =pod 70 71 =encoding UTF-8 72 73 =head1 NAME 74 75 SBO::Lib::Util - Utility functions for SBO::Lib and the sbotools 76 77 =head1 SYNOPSIS 78 79 use SBO::Lib::Util qw/uniq/; 80 81 # ('duplicate'); 82 my @uniq = uniq('duplicate', 'duplicate'); 83 84 =head1 VARIABLES 85 86 =head2 $conf_dir 87 88 By default, C<$conf_dir> will be C</etc/sbotools>. 89 90 =head2 $conf_file 91 92 By default, C<$conf_file> will be C</etc/sbotools/sbotools.conf>. 93 94 =head2 %config 95 96 By default, all values are set to C<"FALSE">, but when C<read_config()> is run, 97 the values will change according to the configuration, and C<SBO_HOME> will by 98 default get changed to C</usr/sbo>. 99 100 The supported keys are: C<NOCLEAN>, C<DISTCLEAN>, C<JOBS>, C<PKG_DIR>, 101 C<SBO_HOME>, C<LOCAL_OVERRIDES>, C<SLACKWARE_VERSION>, C<REPO>, C<GPG_KEY>. 102 103 =cut 104 105 # global config variables 106 our $conf_dir = '/etc/sbotools'; 107 our $conf_file = "$conf_dir/sbotools.conf"; 108 our %config = ( 109 NOCLEAN => 'FALSE', 110 DISTCLEAN => 'FALSE', 111 JOBS => 'FALSE', 112 PKG_DIR => 'FALSE', 113 SBO_HOME => 'FALSE', 114 LOCAL_OVERRIDES => 'FALSE', 115 SLACKWARE_VERSION => 'FALSE', 116 REPO => 'FALSE', 117 GPG_KEY => 'D3076BC3E783EE747F09B8B70368EF579C7BA3B6', 118 FALLBACK_ARCHIVE => "ftp://slackware.uk/sbosrcarch", 119 ); 120 121 read_config(); 122 123 =head1 SUBROUTINES 124 125 =cut 126 127 =head2 check_multilib 128 129 my $ml = check_multilib(); 130 131 C<check_multilib()> checks if the file C</etc/profile.d/32dev.sh> exists, 132 because without it, there's no way to build 32bit things on an x64 arch. 133 134 Returns a true value if it exists, and a false value otherwise. 135 136 =cut 137 138 # can't do 32-bit on x86_64 without this file, so we'll use it as the test to 139 # to determine whether or not an x86_64 system is setup for multilib 140 sub check_multilib { 141 return 1 if -f '/etc/profile.d/32dev.sh'; 142 return(); 143 } 144 145 =head2 get_arch 146 147 my $arch = get_arch(); 148 149 C<get_arch()> returns the current machine architechture as reported by C<uname 150 -m>. 151 152 =cut 153 154 sub get_arch { 155 chomp(my $arch = `uname -m`); 156 return $arch; 157 } 158 159 =head2 get_kernel_version 160 161 my $kv = get_kernel_version(); 162 163 C<get_kernel_version()> will check what the version of the currently running 164 kernel is and return it in a format suitable for appending to a slackware 165 package version. 166 167 =cut 168 169 sub get_kernel_version { 170 state $kv; 171 return $kv if defined $kv; 172 173 chomp($kv = `uname -r`); 174 $kv =~ s/-/_/g; 175 return $kv; 176 } 177 178 =head2 get_sbo_from_loc 179 180 my $sbo = get_sbo_from_loc($location); 181 182 C<get_sbo_from_loc()> gets the package name from the C<$location> passed in 183 and returns it. 184 185 =cut 186 187 # pull the sbo name from a $location: $repo_path/system/wine, etc. 188 sub get_sbo_from_loc { 189 script_error('get_sbo_from_loc requires an argument.') unless @_ == 1; 190 return (shift =~ qr#/([^/]+)$#)[0]; 191 } 192 193 =head2 get_slack_version 194 195 my $version = get_slack_version(); 196 197 C<get_slack_version()> checks which version of the SBo repository to use and if 198 successful, returns it. 199 200 If there is an error in getting the slackware version, or if it's not a 201 supported version, an error message will be shown on STDERR, and the program 202 will exit. 203 204 =cut 205 206 # %supported maps what's in /etc/slackware-version to an rsync or https URL 207 my %supported = ( 208 '14.0' => 'rsync://slackbuilds.org/slackbuilds/14.0/', 209 '14.1' => 'rsync://slackbuilds.org/slackbuilds/14.1/', 210 '14.2' => 'rsync://slackbuilds.org/slackbuilds/14.2/', 211 '15.0' => 'rsync://slackbuilds.org/slackbuilds/15.0/', 212 '15.0+' => 'https://github.com/Ponce/slackbuilds.git', 213 current => 'https://github.com/Ponce/slackbuilds.git', 214 ); 215 216 sub get_slack_version { 217 return $config{SLACKWARE_VERSION} unless $config{SLACKWARE_VERSION} eq 'FALSE'; 218 my ($fh, $exit) = open_read('/etc/slackware-version'); 219 if ($exit) { 220 warn $fh; 221 exit $exit; 222 } 223 chomp(my $line = <$fh>); 224 close $fh; 225 my $version = ($line =~ /\s+(\d+[^\s]+)$/)[0]; 226 usage_error("Unsupported Slackware version: $version\n" . 227 "Suggest you set the sbotools REPO setting to $supported{current}\n") 228 unless $supported{$version}; 229 return $version; 230 } 231 232 =head2 get_slack_version_url 233 234 my $url = get_slack_version_url(); 235 236 C<get_slack_version_url()> returns the default URL for the given slackware 237 version. 238 239 If there is an error in getting the URL, or if it's not a supported version, 240 an error message will be shown on STDERR, and the program will exit. 241 242 =cut 243 244 sub get_slack_version_url { 245 return $supported{get_slack_version()}; 246 } 247 248 =head2 idx 249 250 my $idx = idx($needle, @haystack); 251 252 C<idx()> looks for C<$needle> in C<@haystack>, and returns the index of where 253 it was found, or C<undef> if it wasn't found. 254 255 =cut 256 257 sub idx { 258 for my $idx (1 .. $#_) { 259 $_[0] eq $_[$idx] and return $idx - 1; 260 } 261 return undef; 262 } 263 264 =head2 in 265 266 my $found = in($needle, @haystack); 267 268 C<in()> looks for C<$needle> in C<@haystack>, and returns a true value if it 269 was found, and a false value otherwise. 270 271 =cut 272 273 # Checks if the first argument equals any of the subsequent ones 274 sub in { 275 my ($first, @rest) = @_; 276 foreach my $arg (@rest) { 277 return 1 if ref $arg eq 'Regexp' and $first =~ $arg; 278 return 1 if $first eq $arg; 279 } 280 return 0; 281 } 282 283 =head2 indent 284 285 my $str = indent($indent, $text); 286 287 C<indent()> indents every non-empty line in C<$text> C<$indent> spaces and 288 returns the resulting string. 289 290 =cut 291 292 sub indent { 293 my ($indent, $text) = @_; 294 return $text unless $indent; 295 296 my @lines = split /\n/, $text; 297 foreach my $line (@lines) { 298 next unless length($line); 299 $line = (" " x $indent) . $line; 300 } 301 return join "\n", @lines; 302 } 303 304 =head2 open_fh 305 306 my ($ret, $exit) = open_fh($fn, $op); 307 308 C<open_fh()> will open C<$fn> for reading and/or writing depending on what 309 C<$op> is. 310 311 It returns a list of two values. The second value is the exit status, and if it 312 is true, the first value will be an error message. Otherwise it will be the 313 opened filehandle. 314 315 =cut 316 317 # sub for opening files, second arg is like '<','>', etc 318 sub open_fh { 319 script_error('open_fh requires two arguments') unless @_ == 2; 320 unless ($_[1] eq '>') { 321 -f $_[0] or script_error("open_fh, $_[0] is not a file"); 322 } 323 my ($file, $op) = @_; 324 my $fh; 325 _race::cond('$file could be deleted between -f test and open'); 326 unless (open $fh, $op, $file) { 327 my $warn = "Unable to open $file.\n"; 328 my $exit = _ERR_OPENFH; 329 return ($warn, $exit); 330 } 331 return $fh; 332 } 333 334 =head2 open_read 335 336 my ($ret, $exit) = open_read($fn); 337 338 C<open_read()> will open C<$fn> for reading. 339 340 It returns a list of two values. The second value is the exit status, and if it 341 is true, the first value will be an error message. Otherwise it will be the 342 opened filehandle. 343 344 =cut 345 346 sub open_read { 347 return open_fh(shift, '<'); 348 } 349 350 =head2 print_failures 351 352 print_failures($failures); 353 354 C<print_failures()> prints all the failures in the C<$failures> array reference 355 to STDERR if any. 356 357 There is no useful return value. 358 359 =cut 360 361 # subroutine to print out failures 362 sub print_failures { 363 my $failures = shift; 364 if (@$failures > 0) { 365 warn "Failures:\n"; 366 for my $failure (@$failures) { 367 warn " $_: $$failure{$_}" for keys %$failure; 368 } 369 } 370 } 371 372 =head2 prompt 373 374 exit unless prompt "Should we continue?", default => "yes"; 375 376 C<prompt()> prompts the user for an answer, optionally specifying a default of 377 C<yes> or C<no>. If the default has been specified it returns a true value in 378 case 'yes' was selected, and a false value if 'no' was selected. Otherwise it 379 returns whatever the user answered. 380 381 =cut 382 383 sub prompt { 384 my ($q, %opts) = @_; 385 my $def = $opts{default}; 386 $q = sprintf '%s [%s] ', $q, $def eq 'yes' ? 'y' : 'n' if defined $def; 387 388 print $q; 389 390 my $res = readline STDIN; 391 392 if (defined $def) { 393 return 1 if $res =~ /^y/i; 394 return 0 if $res =~ /^n/i; 395 return $def eq 'yes' if $res =~ /^\n/; 396 397 # if none of the above matched, we ask again 398 goto &prompt; 399 } 400 return $res; 401 } 402 403 =head2 read_config 404 405 read_config(); 406 407 C<read_config()> reads in the configuration settings from 408 C</etc/sbotools/sbotools.conf> and updates the C<%config> hash with them. 409 410 There is no useful return value. 411 412 =cut 413 414 # subroutine to suck in config in order to facilitate unit testing 415 sub read_config { 416 my $text = slurp($conf_file); 417 if (defined $text) { 418 my %conf_values = $text =~ /^(\w+)=(.*)$/mg; 419 for my $key (keys %config) { 420 $config{$key} = $conf_values{$key} if exists $conf_values{$key}; 421 } 422 $config{JOBS} = 'FALSE' unless $config{JOBS} =~ /^\d+$/; 423 } else { 424 warn "Unable to open $conf_file.\n" if -f $conf_file; 425 } 426 427 $config{SBO_HOME} = '/usr/sbo' if $config{SBO_HOME} eq 'FALSE'; 428 unless ($config{SBO_HOME} =~ qr#^(/|$)#) { 429 usage_error( "The configuration parameter SBO_HOME must be an absolute path."); 430 } 431 } 432 433 =head2 script_error 434 435 script_error(); 436 script_error($msg); 437 438 script_error() will warn and exit, saying on STDERR 439 440 A fatal script error has occurred. Exiting. 441 442 If there was a $msg supplied, it will instead say 443 444 A fatal script error has occurred: 445 $msg. 446 Exiting. 447 448 There is no useful return value. 449 450 =cut 451 452 # subroutine for throwing internal script errors 453 sub script_error { 454 if (@_) { 455 warn "A fatal script error has occurred:\n$_[0]\nExiting.\n"; 456 } else { 457 warn "A fatal script error has occurred. Exiting.\n"; 458 } 459 exit _ERR_SCRIPT; 460 } 461 462 =head2 show_version 463 464 show_version(); 465 466 C<show_version()> will print out the sbotools version and licensing information 467 to STDOUT. 468 469 There is no useful return value. 470 471 =cut 472 473 sub show_version { 474 say "sbotools version $SBO::Lib::VERSION"; 475 } 476 477 =head2 slurp 478 479 my $data = slurp($fn); 480 481 C<slurp()> takes a filename in C<$fn>, opens it, and reads in the entire file, 482 the contents of which is then returned. On error, it returns C<undef>. 483 484 =cut 485 486 sub slurp { 487 my $fn = shift; 488 return undef unless -f $fn; 489 my ($fh, $exit) = open_read($fn); 490 return undef if $exit; 491 local $/; 492 return scalar readline($fh); 493 } 494 495 =head2 uniq 496 497 my @uniq = uniq(@duplicates); 498 499 C<uniq()> removes the duplicates from C<@duplicates> but otherwise returns the 500 list in the same order. 501 502 =cut 503 504 sub uniq { 505 my %seen; 506 return grep { !$seen{$_}++ } @_; 507 } 508 509 =head2 usage_error 510 511 usage_error($msg); 512 513 usage_error will warn and exit, saying on STDERR 514 515 $msg 516 517 There is no useful return value. 518 519 =cut 520 521 # subroutine for usage errors 522 sub usage_error { 523 warn shift ."\n"; 524 exit _ERR_USAGE; 525 } 526 527 =head2 version_cmp 528 529 my $cmp = version_cmp($ver1, $ver2); 530 531 C<version_cmp()> will compare C<$ver1> with C<$ver2> to try to determine which 532 is bigger than the other, and returns 1 if C<$ver1> is bigger, -1 if C<$ver2> 533 is bigger, and 0 if they are just as big. Before making the comparison, it will 534 strip off the version of your running kernel as well as any locale information 535 if it happens to be appended to the version string being compared. 536 537 =cut 538 539 # wrapper around versioncmp for checking if versions have kernel version 540 # or locale info appended to them 541 sub version_cmp { 542 my ($v1, $v2) = @_; 543 my $kv = get_kernel_version(); 544 545 # strip off kernel version 546 if ($v1 =~ /(.+)_\Q$kv\E$/) { $v1 = $1 } 547 if ($v2 =~ /(.+)_\Q$kv\E$/) { $v2 = $1 } 548 549 # if $v2 doesn't end in the same thing, strip off locale info from $v1 550 if ($v1 =~ /(.*)_([a-z]{2})_([A-Z]{2})$/) { 551 my $v = $1; 552 if ($v2 !~ /_$2_$3$/) { $v1 = $v; } 553 } 554 # and vice versa... 555 if ($v2 =~ /(.*)_([a-z]{2})_([A-Z]{2})$/) { 556 my $v = $1; 557 if ($v1 !~ /_$2_$3$/) { $v2 = $v; } 558 } 559 560 versioncmp($v1, $v2); 561 } 562 563 # _race::cond will allow both documenting and testing race conditions 564 # by overriding its implementation for tests 565 sub _race::cond { return } 566 567 1;