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