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