xref: /openbsd/usr.bin/pkg-config/pkg-config (revision f793e6ae) 
1#!/usr/bin/perl
2# $OpenBSD: pkg-config,v 1.97 2023/09/22 07:28:31 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###########################################################################
282sub set_variables_from_env($file)
283{
284	    state (%done, @l);
285
286	    if (!defined $done{$file}) {
287		    my $pkg = $file;
288
289		    $pkg =~ s/(^.*\/)?(.*?)\.pc$/$2/g;
290		    $pkg = uc($pkg);
291		    if (!@l) {
292			    @l = grep {/PKG_CONFIG_/} keys %ENV;
293		    }
294		    for my $k (@l) {
295			    next unless $k =~ m/PKG_CONFIG_${pkg}_(\w+)/;
296			    $variables->{lc($1)} = $ENV{$k};
297		    }
298		    $done{$file} = 1;
299	    }
300
301}
302
303sub handle_config($p, $op, $v, $list)
304{
305	my $cfg = cache_find_config($p);
306
307	unshift @$list, $p if defined $cfg;
308
309	if (!defined $cfg) {
310		$rc = 1;
311		return undef;
312	}
313
314	if (defined $op) {
315		if (!versionmatch($cfg, $op, $v)) {
316			mismatch($p, $cfg, $op, $v) if $mode{printerr};
317			$rc = 1;
318			return undef;
319		}
320	}
321
322	my $get_props = sub($property) {
323	    set_variables_from_env($p);
324
325	    my $deps = $cfg->get_property($property, $variables);
326	    return unless defined $deps;
327	    for my $dep (@$deps) {
328		    if ($dep =~ m/^(.*?)\s*([<=>]+)\s*([\d\.]+|[\d\.]+\w*\d+)$/) {
329			    handle_config($1, $2, $3, $list);
330		    } else {
331			    handle_config($dep, undef, undef, $list);
332		    }
333	    }
334	    say_debug("package $p " . lc($property) . " " . join(',', @$deps));
335	};
336
337	if (defined $mode{cflags}
338	    or ($mode{static} && $mode{libs})
339	    or $mode{printrequiresprivate}
340    	    or $mode{exists}) {
341		&$get_props("Requires.private");
342	}
343
344	unless (defined $mode{validate}) {
345		&$get_props("Requires");
346	}
347}
348
349# look for the .pc file in each of the PKGPATH elements. Return the path or
350# undef if it's not there
351sub pathresolve($p)
352{
353	if ($allow_uninstalled && $p !~ m/\-uninstalled$/) {
354		for my $d (@PKGPATH) {
355			my $f = "$d/$p-uninstalled.pc";
356			say_debug("pathresolve($p) looking in $f");
357			if (-f $f) {
358				$found_uninstalled = 1;
359				return $f;
360			}
361		}
362	}
363
364	for my $d (@PKGPATH) {
365		my $f = "$d/$p.pc";
366		say_debug("pathresolve($p) looking in $f");
367		return $f if -f $f;
368	}
369	return undef;
370}
371
372sub get_config($f)
373{
374	my $cfg;
375	eval {
376		$cfg = OpenBSD::PkgConfig->read_file($f);
377	};
378	if (!$@) {
379		return validate_config($f, $cfg);
380	} else {
381		say_debug($@);
382	}
383	return undef;
384}
385
386sub cache_find_config($name)
387{
388	say_debug("processing $name");
389
390	if (exists $configs{$name}) {
391		return $configs{$name};
392	} else {
393	    	return $configs{$name} = find_config($name);
394	}
395}
396
397# Required elements for a valid .pc file: Name, Description, Version
398sub validate_config($f, $cfg)
399{
400	my @required_elems = ('Name', 'Description', 'Version');
401
402	# Check if we're dealing with an empty file, but don't error out just
403	# yet, we'll do that when we realize there's no Name field.
404	if (stat($f)->size == 0) {
405		say_error("Package file '$f' appears to be empty");
406	}
407
408	for my $p (@required_elems) {
409		my $e = $cfg->get_property($p, $variables);
410		if (!defined $e) {
411			$f =~ s/(^.*\/)?(.*?)\.pc$/$2/g;
412			say_error("Package '$f' has no $p: field");
413			return undef;
414		}
415	}
416
417	return $cfg;
418}
419
420# pkg-config won't install a pkg-config.pc file itself, but it may be
421# listed as a dependency in other files. so prime the cache with self.
422sub setup_self()
423{
424	my $pkg_pc = OpenBSD::PkgConfig->new;
425	$pkg_pc->add_property('Version', $version);
426	$pkg_pc->add_variable('pc_path', join(":", @PKGPATH));
427	$pkg_pc->add_property('URL', "http://man.openbsd.org/pkg-config");
428	$pkg_pc->add_property('Description', "fetch metadata about installed software packages");
429	$configs{'pkg-config'} = $pkg_pc;
430}
431
432sub find_config($p)
433{
434	# Differentiate between getting a full path and just the module name.
435	my $f = ($p =~ m/\.pc$/ ? $p : pathresolve($p));
436
437	return get_config($f) if defined($f);
438
439	say_error("Package $p was not found in the pkg-config search path");
440
441	return undef;
442}
443
444sub stringize($list, $sep = ',')
445{
446	if (defined $list) {
447		return join($sep, @$list)
448	} else {
449		return '';
450	}
451}
452
453#if the variable option is set, pull out the named variable
454sub do_variable($p, $v)
455{
456	my $cfg = cache_find_config($p);
457
458	if (defined $cfg) {
459		my $value = $cfg->get_variable($v, $variables);
460		if (defined $value) {
461			push(@vlist, $value);
462		}
463		return undef;
464	}
465	$rc = 1;
466}
467
468#if the modversion or print-provides options are set,
469#pull out the compiler flags
470sub do_modversion($p)
471{
472	my $cfg = cache_find_config($p);
473
474	if (defined $cfg) {
475		my $value = $cfg->get_property('Version', $variables);
476		if (defined $value) {
477			if (defined($mode{printprovides})){
478				say "$p = " , stringize($value);
479				return undef;
480			} else {
481				say stringize($value);
482				return undef;
483			}
484		}
485	}
486	$rc = 1;
487}
488
489#if the cflags option is set, pull out the compiler flags
490sub do_cflags($list)
491{
492	my $cflags = [];
493
494	for my $pkg (@$list) {
495		my $l = $configs{$pkg}->get_property('Cflags', $variables);
496		PATH: for my $path (@$l) {
497			for my $sys_path (@sys_includes) {
498				next PATH if $path =~ /\Q${sys_path}\E\/*$/;
499			}
500			push(@$cflags, $path);
501		}
502	}
503	my $a = OpenBSD::PkgConfig->compress($cflags,
504		sub($r) {
505			if (($mode{cflags} & ONLY_I) && $r =~ /^-I/ ||
506			    ($mode{cflags} & ONLY_OTHER) && $r !~ /^-I/) {
507			    return 1;
508			} else {
509			    return 0;
510			}
511		});
512	if (defined($variables->{pc_sysrootdir})){
513		$a =~ s/[\w]?-I/$&$variables->{pc_sysrootdir}/g;
514	}
515
516	return $a;
517}
518
519#if the lib option is set, pull out the linker flags
520sub do_libs($list)
521{
522	my $libs = [];
523
524	# In static mode, we have to make sure we discover the libs in dependency
525	# order, not in search order. Ordering matters for static linking:
526	# Start with Libs (first our own, then dependencies), and append
527	# Libs.private (same order as for Libs).
528	for my $pkg (@$list) {
529		my $l = $configs{$pkg}->get_property('Libs', $variables);
530		for my $path (@$l) {
531			unless ($path =~ /-L\/usr\/lib\/*$/) {
532				push(@$libs, $path);
533			}
534		}
535		if ($mode{static}) {
536			my $lp = $configs{$pkg}->get_property('Libs.private', $variables);
537			for my $path (@$lp) {
538				unless ($path =~ /-L\/usr\/lib\/*/) {
539			   		push(@$libs, $path);
540				}
541			}
542		}
543	}
544
545	# Get the linker path directives (-L) and store it in $a.
546	# $b will be the actual libraries.
547	my $r = OpenBSD::PkgConfig->compress_list($libs,
548	    sub($r) {
549		if (($mode{libs} & ONLY_L) && $r =~ /^-L/ ||
550		    ($mode{libs} & ONLY_OTHER) && $r !~ /^-[lL]/) {
551		    return 1;
552		} else {
553		    return 0;
554		}
555	    });
556
557	if (defined($variables->{pc_sysrootdir})){
558		for my $i (@$r) {
559			$i =~ s/[\w]?-[lL]/$&$variables->{pc_sysrootdir}/;
560		}
561	}
562
563	if ($mode{libs} & ONLY_l) {
564		push(@$r, OpenBSD::PkgConfig->rcompress($libs,
565		    sub($l) { $l =~ m/^-l/; }));
566	}
567	return @$r;
568}
569
570#list all packages
571sub do_list()
572{
573	my ($p, $x, $y, @files, $fname, $name);
574
575	my $error = 0;
576
577	for my $p (@PKGPATH) {
578		push(@files, <$p/*.pc>);
579	}
580
581	# Scan the lengths of the package names so I can make a format
582	# string to line the list up just like the real pkgconfig does.
583	$x = 0;
584	for my $f (@files) {
585		$fname = basename($f, '.pc');
586		$y = length $fname;
587		$x = (($y > $x) ? $y : $x);
588	}
589	$x *= -1;
590
591	for my $f (@files) {
592		my $cfg = get_config($f);
593		if (!defined $cfg) {
594			say_warning("Problem reading file $f");
595			$error = 1;
596			next;
597		}
598		$fname = basename($f, '.pc');
599		printf("%${x}s %s - %s\n", $fname,
600		    stringize($cfg->get_property('Name', $variables), ' '),
601		    stringize($cfg->get_property('Description', $variables),
602		    ' '));
603	}
604	return $error;
605}
606
607sub help(@)
608{
609	print <<EOF
610Usage: $0 [options]
611--debug	- turn on debugging output
612--help - this message
613--usage - this message
614--list-all - show all packages that $0 can find
615--version - print version of pkgconfig
616--errors-to-stdout - direct error messages to stdout rather than stderr
617--print-errors - print error messages in case of error
618--print-provides - print all the modules the given package provides
619--print-requires - print all the modules the given package requires
620--print-requires-private - print all the private modules the given package requires
621--silence-errors - don\'t print error messages in case of error
622--atleast-pkgconfig-version [version] - require a certain version of pkgconfig
623--cflags package [versionspec] [package [versionspec]]
624--cflags-only-I - only output -Iincludepath flags
625--cflags-only-other - only output flags that are not -I
626--define-variable=NAME=VALUE - define variables
627--libs package [versionspec] [package [versionspec]]
628--libs-only-l - only output -llib flags
629--libs-only-L - only output -Llibpath flags
630--libs-only-other - only output flags that are not -l or -L
631--exists package [versionspec] [package [versionspec]]
632--validate package
633--uninstalled - allow for uninstalled versions to be used
634--static - adjust output for static linking
635--atleast-version [version] - require a certain version of a package
636--exact-version [version] - require exactly the specified version of a package
637--max-version [version] - require at most a certain version of a package
638--modversion [package] - query the version of a package
639--variable var package - return the definition of <var> in <package>
640EOF
641;
642	exit 0;
643}
644
645# do we meet/beat the version the caller requested?
646sub self_version($v)
647{
648	my (@a, @b);
649
650	@a = split(/\./, $v);
651	@b = split(/\./, $version);
652
653	if (($b[0] >= $a[0]) && ($b[1] >= $a[1])) {
654		return 0;
655	} else {
656		return 1;
657	}
658}
659
660sub parse_suffix($s)
661{
662	my @l = ();
663	my $full = $s;
664	# is there a valid non-numeric suffix to deal with later?
665	# accepted are (in order): a(lpha) < b(eta) < rc < ' '.
666	# suffix[0] is the 'alpha' part, suffix[1] is the '1' part in 'alpha1'.
667	if ($s =~ s/(rc|beta|b|alpha|a)(\d+)$//) {
668		@l = ($1, $2);
669	}
670	# also deal with -stable extension
671	elsif ($s =~ s/(\-stable)$//) {
672		@l = ($1);
673	}
674	# The above are standard suffixes; deal with single alphabetical
675	# suffixes too, e.g. 1.0.1h
676	elsif ($s =~ s/([a-zA-Z]){1}$//) {
677	    @l = ($1);
678	}
679
680	if (@l) {
681		say_debug("valid suffix @l found in $full.");
682	}
683
684	return ($s, @l);
685}
686
687sub compare($full_a, $full_b)
688{
689	return 0 if $full_a eq $full_b;
690
691	my ($a, @suffix_a) = parse_suffix($full_a);
692	my ($b, @suffix_b) = parse_suffix($full_b);
693
694	my @a = split(/\./, $a);
695	my @b = split(/\./, $b);
696
697	while (@a && @b) { #so long as both lists have something
698		if (!(@suffix_a || @suffix_b)) {
699			# simple comparison when no suffixes are in the game.
700			my $rc = compare_numeric($a[0], $b[0], 0);
701			return $rc if defined($rc);
702		} else {
703			# extended comparison.
704			if (((@a == 1) || (@b == 1)) &&
705			    ($a[0] == $b[0])){
706				# one of the arrays has reached the last element,
707				# compare the suffix.
708
709				# directly compare suffixes, provided both suffixes
710				# are present.
711				if (@suffix_a && @suffix_b) {
712					my $first_char = sub($s) {
713						return substr($s, 0, 1);
714					};
715
716					# suffixes are equal, compare on numeric
717					if (&$first_char($suffix_a[0]) eq
718					    &$first_char($suffix_b[0])) {
719					    	return compare_numeric($suffix_a[1], $suffix_b[1], 1);
720					}
721
722					# rc beats beta beats alpha
723					if (&$first_char($suffix_a[0]) lt &$first_char($suffix_b[0])) {
724						say_debug("$full_a (installed) < $full_b (wanted)");
725						return -1;
726					} else {
727						say_debug("$full_a (installed) > $full_b (wanted)");
728						return 1;
729					}
730
731				} else {
732					# one of either is lacking a suffix,
733					# thereby beating the other.
734					# e.g.: 1.02 > 1.02b1
735					if (@suffix_a) { # a is older
736						say_debug("$full_a (installed) < $full_b (wanted)");
737						return 1;
738					}
739
740					if (@suffix_b) { # b is older
741						say_debug("$full_a (installed) > $full_b (wanted)");
742						return -1;
743					}
744				}
745			} else {
746				my $rc = compare_numeric($a[0], $b[0], 0);
747				return $rc if defined($rc);
748			}
749		}
750		shift @a; shift @b;
751	}
752	return 1 if @a;
753	return -1 if @b;
754	return 0;
755}
756
757# simple numeric comparison, with optional equality test.
758sub compare_numeric($x, $y, $eq)
759{
760	return  1 if $x > $y;
761	return -1 if $x < $y;
762	return  0 if (($x == $y) and ($eq == 1));
763	return undef;
764}
765
766# got a package meeting the requested specific version?
767sub versionmatch($cfg, $op, $want)
768{
769	# can't possibly match if we can't find the file
770	return 0 if !defined $cfg;
771
772	my $inst = stringize($cfg->get_property('Version', $variables));
773
774	# can't possibly match if we can't find the version string
775	return 0 if $inst eq '';
776
777	say_debug("comparing $want (wanted) to $inst (installed)");
778	my $value = compare($inst, $want);
779	if    ($op eq '>=') { return $value >= 0; }
780	elsif ($op eq '=')  { return $value == 0; }
781	elsif ($op eq '!=') { return $value != 0; }
782	elsif ($op eq '<')  { return $value < 0; }
783	elsif ($op eq '>')  { return $value > 0; }
784	elsif ($op eq '<=') { return $value <= 0; }
785}
786
787sub mismatch($p, $cfg, $op, $v)
788{
789	my $name = stringize($cfg->get_property('Name'), ' ');
790	my $version = stringize($cfg->get_property('Version'));
791	my $url = stringize($cfg->get_property('URL'));
792
793	say_warning("Requested '$p $op $v' but version of $name is $version");
794	say_warning("You may find new versions of $name at $url") if $url;
795}
796
797sub simplify_and_reverse($reqlist)
798{
799	my $dejavu = {};
800	my $result = [];
801
802	for my $item (@$reqlist) {
803		if (!$dejavu->{$item}) {
804			unshift @$result, $item;
805			$dejavu->{$item} = 1;
806		}
807	}
808	return $result;
809}
810
811# retrieve and print Requires(.private)
812sub print_requires($p)
813{
814	my $cfg = cache_find_config($p);
815
816	if (defined($cfg)) {
817		my $value;
818
819		if (defined($mode{printrequires})) {
820			$value = $cfg->get_property('Requires', $variables);
821		} elsif (defined($mode{printrequiresprivate})) {
822			$value = $cfg->get_property('Requires.private', $variables);
823		} else {
824			say_debug("Unknown mode for print_requires.");
825			return 1;
826		}
827
828		if (defined($value)) {
829			say $_ for @$value;
830			return undef;
831		}
832	}
833
834	$rc = 1;
835}
836
837sub beautify_list(@p)
838{
839	return join(' ', map {"[$_]"} @p);
840}
841
842sub say_debug($msg)
843{
844	say_msg($msg) if $mode{debug};
845}
846
847sub say_error($msg)
848{
849	say_msg($msg) if $mode{printerr}
850}
851
852sub say_warning($msg)
853{
854	say_msg($msg);
855}
856
857sub say_msg($str)
858{
859	# If --errors-to-stdout was given, close STDERR (to be safe),
860	# then dup the output to STDOUT and delete the key from %mode so we
861	# won't keep checking it. STDERR stays dup'ed.
862	if ($mode{estdout}) {
863		close(STDERR);
864		open(STDERR, ">&STDOUT") or die "Can't dup STDOUT: $!";
865		delete($mode{estdout});
866	}
867
868	say STDERR $str;
869}
870