1#!/usr/bin/perl 2# $OpenBSD: pkg-config,v 1.93 2019/12/08 14:22:14 espie Exp $ 3# $CSK: pkgconfig.pl,v 1.39 2006/11/27 16:26:20 ckuethe Exp $ 4 5# Copyright (c) 2006 Chris Kuethe <ckuethe@openbsd.org> 6# Copyright (c) 2011,2019 Jasper Lievisse Adriaanse <jasper@openbsd.org> 7# 8# Permission to use, copy, modify, and distribute this software for any 9# purpose with or without fee is hereby granted, provided that the above 10# copyright notice and this permission notice appear in all copies. 11# 12# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 13# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 14# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 15# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 16# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 17# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 18# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 19 20use strict; 21use warnings; 22use Config; 23use Getopt::Long; 24use File::Basename; 25use File::stat; 26use OpenBSD::PkgConfig; 27 28my @PKGPATH = qw(/usr/lib/pkgconfig 29 /usr/local/lib/pkgconfig 30 /usr/local/share/pkgconfig 31 /usr/X11R6/lib/pkgconfig 32 /usr/X11R6/share/pkgconfig); 33 34if (defined($ENV{PKG_CONFIG_LIBDIR}) && $ENV{PKG_CONFIG_LIBDIR}) { 35 @PKGPATH = split(/:/, $ENV{PKG_CONFIG_LIBDIR}); 36} elsif (defined($ENV{PKG_CONFIG_PATH}) && $ENV{PKG_CONFIG_PATH}) { 37 unshift(@PKGPATH, split(/:/, $ENV{PKG_CONFIG_PATH})); 38} 39 40my $logfile = ''; 41if (defined($ENV{PKG_CONFIG_LOG}) && $ENV{PKG_CONFIG_LOG}) { 42 $logfile = $ENV{PKG_CONFIG_LOG}; 43} 44 45my $allow_uninstalled = 46 defined $ENV{PKG_CONFIG_DISABLE_UNINSTALLED} ? 0 : 1; 47my $found_uninstalled = 0; 48 49my $version = '0.29.1'; # pretend to be this version of pkgconfig 50 51my %configs = (); 52setup_self(); 53 54my %mode = (); 55my $variables = {}; 56 57$variables->{pc_top_builddir} = $ENV{PKG_CONFIG_TOP_BUILD_DIR} // 58 '$(top_builddir)'; 59 60$variables->{pc_sysrootdir} //= $ENV{PKG_CONFIG_SYSROOT_DIR}; 61# The default '/' is implied. 62 63defined $ENV{PKG_CONFIG_DEBUG_SPEW} ? $mode{debug} = 1 : $mode{debug} = 0; 64 65if ($logfile) { 66 open my $L, ">>" , $logfile or die; 67 print $L beautify_list($0, @ARGV), "\n"; 68 close $L; 69} 70 71# combo arg-parsing and dependency resolution loop. Hopefully when the loop 72# terminates, we have a full list of packages upon which we depend, and the 73# right set of compiler and linker flags to use them. 74# 75# as each .pc file is loaded, it is stored in %configs, indexed by package 76# name. this makes it possible to then pull out flags or do substitutions 77# without having to go back and reload the files from disk. 78 79Getopt::Long::Configure('no_ignore_case'); 80GetOptions( 'debug' => \$mode{debug}, 81 'help' => \&help, #does not return 82 'usage' => \&help, #does not return 83 'list-all' => \$mode{list}, 84 'version' => sub { print "$version\n" ; exit(0);} , 85 'errors-to-stdout' => sub { $mode{estdout} = 1}, 86 'print-errors' => sub { $mode{printerr} = 1}, 87 'silence-errors' => sub { $mode{printerr} = 0}, 88 'short-errors' => sub { $mode{printerr} = 0}, 89 'atleast-pkgconfig-version=s' => \$mode{myminvers}, 90 'print-provides' => \$mode{printprovides}, 91 'print-requires' => \$mode{printrequires}, 92 'print-requires-private' => \$mode{printrequiresprivate}, 93 94 'cflags' => sub { $mode{cflags} = 3}, 95 'cflags-only-I' => sub { $mode{cflags} |= 1}, 96 'cflags-only-other' => sub { $mode{cflags} |= 2}, 97 'libs' => sub { $mode{libs} = 7}, 98 'libs-only-l' => sub { $mode{libs} |= 1}, 99 'libs-only-L' => sub { $mode{libs} |= 2}, 100 'libs-only-other' => sub { $mode{libs} |= 4}, 101 'exists' => sub { $mode{exists} = 1} , 102 'validate' => sub { $mode{validate} = 1}, 103 'static' => sub { $mode{static} = 1}, 104 'uninstalled' => sub { $mode{uninstalled} = 1}, 105 'atleast-version=s' => \$mode{minversion}, 106 'exact-version=s' => \$mode{exactversion}, 107 'max-version=s' => \$mode{maxversion}, 108 'modversion' => \$mode{modversion}, 109 'variable=s' => \$mode{variable}, 110 'define-variable=s' => $variables, 111 ); 112 113# Unconditionally switch to static mode on static arches as --static 114# may not have been passed explicitly, but we don't want to re-order 115# and simplify the libs like we do for shared architectures. 116{ 117 my @static_archs = qw(); 118 my $machine_arch = $Config{'ARCH'}; 119 if (grep { $_ eq $machine_arch } @static_archs){ 120 $mode{static} = 1; 121 } 122} 123 124# Initial value of printerr depends on the options... 125if (!defined $mode{printerr}) { 126 if (defined $mode{libs} 127 or defined $mode{cflags} 128 or defined $mode{version} 129 or defined $mode{list} 130 or defined $mode{validate}) { 131 $mode{printerr} = 1; 132 } else { 133 $mode{printerr} = 0; 134 } 135} 136 137say_debug("\n" . beautify_list($0, @ARGV)); 138 139my $rc = 0; 140 141# XXX pkg-config is a bit weird 142{ 143my $p = join(' ', @ARGV); 144$p =~ s/^\s+//; 145@ARGV = split(/\,?\s+/, $p); 146} 147 148if ($mode{myminvers}) { 149 exit self_version($mode{myminvers}); 150} 151 152if ($mode{list}) { 153 exit do_list(); 154} 155 156my $cfg_full_list = []; 157my $top_config = []; 158 159# When we got here we're supposed to have had at least one 160# package as argument. 161if (!@ARGV){ 162 say_error("No package name(s) specified."); 163 exit 1; 164} 165 166# Return the next module from @ARGV, if it turns out to be a comma separated 167# module list, take the first one and put the rest back to the front. 168sub get_next_module 169{ 170 my $module = shift @ARGV; 171 my $m; 172 if ($module =~ m/,/) { 173 my @ms = split(/,/, $module); 174 $m = shift @ms; 175 unshift(@ARGV, @ms) if (scalar(@ms) > 0); 176 } else { 177 return $module; 178 } 179 180 return $m; 181} 182 183while (@ARGV){ 184 my $p = get_next_module(); 185 my $op = undef; 186 my $v = undef; 187 if (@ARGV >= 2 && $ARGV[0] =~ /^[<=>!]+$/ && 188 $ARGV[1] =~ /^[\d\.]+[\w\.]*$/) { 189 $op = shift @ARGV; 190 $v = shift @ARGV; 191 } 192 # For these modes we just need some meta-information and 193 # parsing the requirements is not needed. 194 if (!($mode{modversion} || $mode{printprovides})) { 195 handle_config($p, $op, $v, $cfg_full_list); 196 } 197 push(@$top_config, $p); 198} 199 200if ($mode{exists} || $mode{validate}) { 201 exit $rc; 202} 203 204if ($mode{uninstalled}) { 205 $rc = 1 unless $found_uninstalled; 206 exit $rc; 207} 208 209if ($mode{modversion} || $mode{printprovides}) { 210 for my $pkg (@$top_config) { 211 do_modversion($pkg); 212 } 213} 214 215if ($mode{printrequires} || $mode{printrequiresprivate}) { 216 for my $pkg (@$top_config) { 217 print_requires($pkg); 218 } 219} 220 221if ($mode{minversion}) { 222 my $v = $mode{minversion}; 223 for my $pkg (@$top_config) { 224 $rc = 1 unless versionmatch($configs{$pkg}, '>=', $v); 225 } 226 exit $rc; 227} 228 229if ($mode{exactversion}) { 230 my $v = $mode{exactversion}; 231 for my $pkg (@$top_config) { 232 $rc = 1 unless versionmatch($configs{$pkg}, '=', $v); 233 } 234 exit $rc; 235} 236 237if ($mode{maxversion}) { 238 my $v = $mode{maxversion}; 239 for my $pkg (@$top_config) { 240 $rc = 1 unless versionmatch($configs{$pkg}, '<=', $v); 241 } 242 exit $rc; 243} 244 245my @vlist = (); 246 247if ($mode{variable}) { 248 for my $pkg (@$top_config) { 249 do_variable($pkg, $mode{variable}); 250 } 251} 252 253my $dep_cfg_list = $cfg_full_list; 254 255if ($mode{static}){ 256 $dep_cfg_list = [reverse(@$cfg_full_list)]; 257} else { 258 $dep_cfg_list = simplify_and_reverse($cfg_full_list); 259} 260 261if ($mode{cflags} || $mode{libs} || $mode{variable}) { 262 push @vlist, do_cflags($dep_cfg_list) if $mode{cflags}; 263 push @vlist, do_libs($dep_cfg_list) if $mode{libs}; 264 print join(' ', @vlist), "\n" if $rc == 0; 265} 266 267exit $rc; 268 269########################################################################### 270 271sub handle_config 272{ 273 my ($p, $op, $v, $list) = @_; 274 my $cfg = cache_find_config($p); 275 276 unshift @$list, $p if defined $cfg; 277 278 if (!defined $cfg) { 279 $rc = 1; 280 return undef; 281 } 282 283 if (defined $op) { 284 if (!versionmatch($cfg, $op, $v)) { 285 mismatch($p, $cfg, $op, $v) if $mode{printerr}; 286 $rc = 1; 287 return undef; 288 } 289 } 290 291 my $get_props = sub { 292 my $property = shift; 293 my $pkg; 294 295 # See if there's anything in the environment that we need to 296 # take into account. 297 ($pkg = $p) =~ s/(^.*\/)?(.*?)\.pc$/$2/g; 298 $pkg = uc($pkg); 299 300 if (grep {/PKG_CONFIG_${pkg}.*/} keys %ENV) { 301 # Now that we know we have something to look for, do 302 # the inefficient iteration. 303 while (my ($k, $v) = each %ENV) { 304 if ($k =~ /^PKG_CONFIG_${pkg}_(\w+)/) { 305 $variables->{lc($1)} = $v; 306 } 307 } 308 } 309 310 my $deps = $cfg->get_property($property, $variables); 311 return unless defined $deps; 312 for my $dep (@$deps) { 313 if ($dep =~ m/^(.*?)\s*([<=>]+)\s*([\d\.]+|[\d\.]+[\w]*[\d]+)$/) { 314 handle_config($1, $2, $3, $list); 315 } else { 316 handle_config($dep, undef, undef, $list); 317 } 318 } 319 say_debug("package $p " . lc($property) . " " . join(',', @$deps)); 320 }; 321 322 if (defined $mode{cflags} 323 or ($mode{static} && $mode{libs}) 324 or $mode{printrequiresprivate} 325 or $mode{exists}) { 326 &$get_props("Requires.private"); 327 } 328 329 unless (defined $mode{validate}) { 330 &$get_props("Requires"); 331 } 332} 333 334# look for the .pc file in each of the PKGPATH elements. Return the path or 335# undef if it's not there 336sub pathresolve 337{ 338 my ($p) = @_; 339 340 if ($allow_uninstalled && $p !~ m/\-uninstalled$/) { 341 for my $d (@PKGPATH) { 342 my $f = "$d/$p-uninstalled.pc"; 343 say_debug("pathresolve($p) looking in $f"); 344 if (-f $f) { 345 $found_uninstalled = 1; 346 return $f; 347 } 348 } 349 } 350 351 for my $d (@PKGPATH) { 352 my $f = "$d/$p.pc"; 353 say_debug("pathresolve($p) looking in $f"); 354 return $f if -f $f; 355 } 356 return undef; 357} 358 359sub get_config 360{ 361 my ($f) = @_; 362 363 my $cfg; 364 eval { 365 $cfg = OpenBSD::PkgConfig->read_file($f); 366 }; 367 if (!$@) { 368 return validate_config($f, $cfg); 369 } else { 370 say_debug($@); 371 } 372 return undef; 373} 374 375sub cache_find_config 376{ 377 my $name = shift; 378 379 say_debug("processing $name"); 380 381 if (exists $configs{$name}) { 382 return $configs{$name}; 383 } else { 384 return $configs{$name} = find_config($name); 385 } 386} 387 388# Required elements for a valid .pc file: Name, Description, Version 389sub validate_config 390{ 391 my ($f, $cfg) = @_; 392 my @required_elems = ('Name', 'Description', 'Version'); 393 394 # Check if we're dealing with an empty file, but don't error out just 395 # yet, we'll do that when we realize there's no Name field. 396 if (stat($f)->size == 0) { 397 say_error("Package file '$f' appears to be empty"); 398 } 399 400 for my $p (@required_elems) { 401 my $e = $cfg->get_property($p, $variables); 402 if (!defined $e) { 403 $f =~ s/(^.*\/)?(.*?)\.pc$/$2/g; 404 say_error("Package '$f' has no $p: field"); 405 return undef; 406 } 407 } 408 409 return $cfg; 410} 411 412# pkg-config won't install a pkg-config.pc file itself, but it may be 413# listed as a dependency in other files. so prime the cache with self. 414sub setup_self 415{ 416 my $pkg_pc = OpenBSD::PkgConfig->new; 417 $pkg_pc->add_property('Version', $version); 418 $pkg_pc->add_variable('pc_path', join(":", @PKGPATH)); 419 $pkg_pc->add_property('URL', "http://man.openbsd.org/pkg-config"); 420 $pkg_pc->add_property('Description', "fetch metadata about installed software packages"); 421 $configs{'pkg-config'} = $pkg_pc; 422} 423 424sub find_config 425{ 426 my ($p) = @_; 427 428 # Differentiate between getting a full path and just the module name. 429 my $f = ($p =~ m/\.pc$/ ? $p : pathresolve($p)); 430 431 return get_config($f) if defined($f); 432 433 say_error("Package $p was not found in the pkg-config search path"); 434 435 return undef; 436} 437 438sub stringize 439{ 440 my $list = shift; 441 my $sep = shift || ','; 442 443 if (defined $list) { 444 return join($sep, @$list) 445 } else { 446 return ''; 447 } 448} 449 450#if the variable option is set, pull out the named variable 451sub do_variable 452{ 453 my ($p, $v) = @_; 454 455 my $cfg = cache_find_config($p); 456 457 if (defined $cfg) { 458 my $value = $cfg->get_variable($v, $variables); 459 if (defined $value) { 460 push(@vlist, $value); 461 } 462 return undef; 463 } 464 $rc = 1; 465} 466 467#if the modversion or print-provides options are set, 468#pull out the compiler flags 469sub do_modversion 470{ 471 my ($p) = @_; 472 473 my $cfg = cache_find_config($p); 474 475 if (defined $cfg) { 476 my $value = $cfg->get_property('Version', $variables); 477 if (defined $value) { 478 if (defined($mode{printprovides})){ 479 print "$p = " . stringize($value) . "\n"; 480 return undef; 481 } else { 482 print stringize($value), "\n"; 483 return undef; 484 } 485 } 486 } 487 $rc = 1; 488} 489 490#if the cflags option is set, pull out the compiler flags 491sub do_cflags 492{ 493 my $list = shift; 494 495 my $cflags = []; 496 497 for my $pkg (@$list) { 498 my $l = $configs{$pkg}->get_property('Cflags', $variables); 499 for my $path (@$l) { 500 unless ($path =~ /-I\/usr\/include\/*$/) { 501 push(@$cflags, $path); 502 } 503 } 504 } 505 my $a = OpenBSD::PkgConfig->compress($cflags, 506 sub { 507 local $_ = shift; 508 if (($mode{cflags} & 1) && /^-I/ || 509 ($mode{cflags} & 2) && !/^-I/) { 510 return 1; 511 } else { 512 return 0; 513 } 514 }); 515 if (defined($a) && defined($variables->{pc_sysrootdir})){ 516 $a =~ s/[\w]?-I/$&$variables->{pc_sysrootdir}/g; 517 } 518 519 return $a; 520} 521 522#if the lib option is set, pull out the linker flags 523sub do_libs 524{ 525 my $list = shift; 526 527 my $libs = []; 528 529 # In static mode, we have to make sure we discover the libs in dependency 530 # order, not in search order. Ordering matters for static linking: 531 # Start with Libs (first our own, then dependencies), and append 532 # Libs.private (same order as for Libs). 533 for my $pkg (@$list) { 534 my $l = $configs{$pkg}->get_property('Libs', $variables); 535 for my $path (@$l) { 536 unless ($path =~ /-L\/usr\/lib\/*$/) { 537 push(@$libs, $path); 538 } 539 } 540 if ($mode{static}) { 541 my $lp = $configs{$pkg}->get_property('Libs.private', $variables); 542 for my $path (@$lp) { 543 unless ($path =~ /-L\/usr\/lib\/*/) { 544 push(@$libs, $path); 545 } 546 } 547 } 548 } 549 550 # Get the linker path directives (-L) and store it in $a. 551 # $b will be the actual libraries. 552 my $a = OpenBSD::PkgConfig->compress($libs, 553 sub { 554 local $_ = shift; 555 if (($mode{libs} & 2) && /^-L/ || 556 ($mode{libs} & 4) && !/^-[lL]/) { 557 return 1; 558 } else { 559 return 0; 560 } 561 }); 562 563 if (defined($variables->{pc_sysrootdir})){ 564 $a =~ s/[\w]?-[lL]/$&$variables->{pc_sysrootdir}/g; 565 } 566 567 if ($mode{libs} & 1) { 568 my $b = OpenBSD::PkgConfig->rcompress($libs, 569 sub { shift =~ m/^-l/; }); 570 return ($a, $b); 571 } else { 572 return $a; 573 } 574} 575 576#list all packages 577sub do_list 578{ 579 my ($p, $x, $y, @files, $fname, $name); 580 my $error = 0; 581 582 for my $p (@PKGPATH) { 583 push(@files, <$p/*.pc>); 584 } 585 586 # Scan the lengths of the package names so I can make a format 587 # string to line the list up just like the real pkgconfig does. 588 $x = 0; 589 for my $f (@files) { 590 $fname = basename($f, '.pc'); 591 $y = length $fname; 592 $x = (($y > $x) ? $y : $x); 593 } 594 $x *= -1; 595 596 for my $f (@files) { 597 my $cfg = get_config($f); 598 if (!defined $cfg) { 599 say_warning("Problem reading file $f"); 600 $error = 1; 601 next; 602 } 603 $fname = basename($f, '.pc'); 604 printf("%${x}s %s - %s\n", $fname, 605 stringize($cfg->get_property('Name', $variables), ' '), 606 stringize($cfg->get_property('Description', $variables), 607 ' ')); 608 } 609 return $error; 610} 611 612sub help 613{ 614 print <<EOF 615Usage: $0 [options] 616--debug - turn on debugging output 617--help - this message 618--usage - this message 619--list-all - show all packages that $0 can find 620--version - print version of pkgconfig 621--errors-to-stdout - direct error messages to stdout rather than stderr 622--print-errors - print error messages in case of error 623--print-provides - print all the modules the given package provides 624--print-requires - print all the modules the given package requires 625--print-requires-private - print all the private modules the given package requires 626--silence-errors - don\'t print error messages in case of error 627--atleast-pkgconfig-version [version] - require a certain version of pkgconfig 628--cflags package [versionspec] [package [versionspec]] 629--cflags-only-I - only output -Iincludepath flags 630--cflags-only-other - only output flags that are not -I 631--define-variable=NAME=VALUE - define variables 632--libs package [versionspec] [package [versionspec]] 633--libs-only-l - only output -llib flags 634--libs-only-L - only output -Llibpath flags 635--libs-only-other - only output flags that are not -l or -L 636--exists package [versionspec] [package [versionspec]] 637--validate package 638--uninstalled - allow for uninstalled versions to be used 639--static - adjust output for static linking 640--atleast-version [version] - require a certain version of a package 641--exact-version [version] - require exactly the specified version of a package 642--max-version [version] - require at most a certain version of a package 643--modversion [package] - query the version of a package 644--variable var package - return the definition of <var> in <package> 645EOF 646; 647 exit 0; 648} 649 650# do we meet/beat the version the caller requested? 651sub self_version 652{ 653 my ($v) = @_; 654 my (@a, @b); 655 656 @a = split(/\./, $v); 657 @b = split(/\./, $version); 658 659 if (($b[0] >= $a[0]) && ($b[1] >= $a[1])) { 660 return 0; 661 } else { 662 return 1; 663 } 664} 665 666sub compare 667{ 668 my ($a, $b) = @_; 669 my ($full_a, $full_b) = ($a, $b); 670 my (@suffix_a, @suffix_b); 671 672 return 0 if ($a eq $b); 673 674 # is there a valid non-numeric suffix to deal with later? 675 # accepted are (in order): a(lpha) < b(eta) < rc < ' '. 676 # suffix[0] is the 'alpha' part, suffix[1] is the '1' part in 'alpha1'. 677 if ($a =~ s/(rc|beta|b|alpha|a)(\d+)$//) { 678 say_debug("valid suffix $1$2 found in $a$1$2."); 679 $suffix_a[0] = $1; 680 $suffix_a[1] = $2; 681 } 682 683 if ($b =~ s/(rc|beta|b|alpha|a)(\d+)$//) { 684 say_debug("valid suffix $1$2 found in $b$1$2."); 685 $suffix_b[0] = $1; 686 $suffix_b[1] = $2; 687 } 688 689 # The above are standard suffixes; deal with single alphabetical 690 # suffixes too, e.g. 1.0.1h 691 if ($a =~ s/([a-zA-Z]){1}$//) { 692 say_debug("valid suffix $1 found in $a$1."); 693 $suffix_a[0] = $1; 694 } 695 696 if ($b =~ s/([a-zA-Z]){1}$//) { 697 say_debug("valid suffix $1 found in $b$1."); 698 $suffix_b[0] = $1; 699 } 700 701 my @a = split(/\./, $a); 702 my @b = split(/\./, $b); 703 704 while (@a && @b) { #so long as both lists have something 705 if (!(@suffix_a || @suffix_b)) { 706 # simple comparison when no suffixes are in the game. 707 my $rc = compare_numeric($a[0], $b[0], 0); 708 return $rc if defined($rc); 709 } else { 710 # extended comparison. 711 if (((@a == 1) || (@b == 1)) && 712 ($a[0] == $b[0])){ 713 # one of the arrays has reached the last element, 714 # compare the suffix. 715 716 # directly compare suffixes, provided both suffixes 717 # are present. 718 if (@suffix_a && @suffix_b) { 719 my $first_char = sub { 720 return substr(shift, 0, 1); 721 }; 722 723 # suffixes are equal, compare on numeric 724 if (&$first_char($suffix_a[0]) eq 725 &$first_char($suffix_b[0])) { 726 return compare_numeric($suffix_a[1], $suffix_b[1], 1); 727 } 728 729 # rc beats beta beats alpha 730 if (&$first_char($suffix_a[0]) lt &$first_char($suffix_b[0])) { 731 say_debug("$full_a (installed) < $full_b (wanted)"); 732 return -1; 733 } else { 734 say_debug("$full_a (installed) > $full_b (wanted)"); 735 return 1; 736 } 737 738 } else { 739 # one of either is lacking a suffix, 740 # thereby beating the other. 741 # e.g.: 1.02 > 1.02b1 742 if (@suffix_a) { # a is older 743 say_debug("$full_a (installed) < $full_b (wanted)"); 744 return 1; 745 } 746 747 if (@suffix_b) { # b is older 748 say_debug("$full_a (installed) > $full_b (wanted)"); 749 return -1; 750 } 751 } 752 } else { 753 my $rc = compare_numeric($a[0], $b[0], 0); 754 return $rc if defined($rc); 755 } 756 } 757 shift @a; shift @b; 758 } 759 return 1 if @a; 760 return -1 if @b; 761 return 0; 762} 763 764# simple numeric comparison, with optional equality test. 765sub compare_numeric 766{ 767 my ($x, $y, $eq) = @_; 768 769 return 1 if $x > $y; 770 return -1 if $x < $y; 771 return 0 if (($x == $y) and ($eq == 1)); 772 return undef; 773} 774 775# got a package meeting the requested specific version? 776sub versionmatch 777{ 778 my ($cfg, $op, $want) = @_; 779 780 # can't possibly match if we can't find the file 781 return 0 if !defined $cfg; 782 783 my $inst = stringize($cfg->get_property('Version', $variables)); 784 785 # can't possibly match if we can't find the version string 786 return 0 if $inst eq ''; 787 788 say_debug("comparing $want (wanted) to $inst (installed)"); 789 my $value = compare($inst, $want); 790 if ($op eq '>=') { return $value >= 0; } 791 elsif ($op eq '=') { return $value == 0; } 792 elsif ($op eq '!=') { return $value != 0; } 793 elsif ($op eq '<') { return $value < 0; } 794 elsif ($op eq '>') { return $value > 0; } 795 elsif ($op eq '<=') { return $value <= 0; } 796} 797 798sub mismatch 799{ 800 my ($p, $cfg, $op, $v) = @_; 801 my $name = stringize($cfg->get_property('Name'), ' '); 802 my $version = stringize($cfg->get_property('Version')); 803 my $url = stringize($cfg->get_property('URL')); 804 805 say_warning("Requested '$p $op $v' but version of $name is $version"); 806 say_warning("You may find new versions of $name at $url") if $url; 807} 808 809sub simplify_and_reverse 810{ 811 my $reqlist = shift; 812 my $dejavu = {}; 813 my $result = []; 814 815 for my $item (@$reqlist) { 816 if (!$dejavu->{$item}) { 817 unshift @$result, $item; 818 $dejavu->{$item} = 1; 819 } 820 } 821 return $result; 822} 823 824# retrieve and print Requires(.private) 825sub print_requires 826{ 827 my ($p) = @_; 828 829 my $cfg = cache_find_config($p); 830 831 if (defined($cfg)) { 832 my $value; 833 834 if (defined($mode{printrequires})) { 835 $value = $cfg->get_property('Requires', $variables); 836 } elsif (defined($mode{printrequiresprivate})) { 837 $value = $cfg->get_property('Requires.private', $variables); 838 } else { 839 say_debug("Unknown mode for print_requires."); 840 return 1; 841 } 842 843 if (defined($value)) { 844 print "$_\n" for @$value; 845 return undef; 846 } 847 } 848 849 $rc = 1; 850} 851 852sub beautify_list 853{ 854 return join(' ', map {"[$_]"} @_); 855} 856 857sub say_debug 858{ 859 say_msg(shift) if $mode{debug}; 860} 861 862sub say_error 863{ 864 say_msg(shift) if $mode{printerr} 865} 866 867sub say_warning 868{ 869 say_msg(shift); 870} 871 872sub say_msg 873{ 874 my $str = shift; 875 876 # If --errors-to-stdout was given, close STDERR (to be safe), 877 # then dup the output to STDOUT and delete the key from %mode so we 878 # won't keep checking it. STDERR stays dup'ed. 879 if ($mode{estdout}) { 880 close(STDERR); 881 open(STDERR, ">&STDOUT") or die "Can't dup STDOUT: $!"; 882 delete($mode{estdout}); 883 } 884 885 print STDERR $str, "\n"; 886} 887