1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
#!/usr/bin/perl
# dh_builtusing - set dpkg-gencontrol substitution variables for the Built-Using field
# SPDX-License-Identifier: GPL-3.0+
# (GNU General Public License, version 3 or later at your convenience)
# Copyright 2023-2025 Nicolas Boulenguez <nicolas@debian.org>
# This program is free software: you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
use feature qw( signatures state );
use re '/amsx';
use strict;
use warnings;
use Debian::Debhelper::Dh_Lib;
use Dpkg::BuildProfiles 'get_build_profiles';
use Dpkg::Control::Info;
use Dpkg::Deps;
use Dpkg::Deps::Simple;
use English '-no_match_vars';
my $control_file = 'debian/control';
my $logorrheic_print = sub { };
init(
options => {
'c=s' => \$control_file,
'logorrheic' => sub {
$dh{VERBOSE} = 1;
$logorrheic_print = \&verbose_print;
},
}
);
my $control = Dpkg::Control::Info->new($control_file);
# pkg: a binary package that may
# be produced by the current build,
# directly or indirectly use a dh_builtusing substitution variable.
# dep: a binary package that may
# match a dh_builtusing substitution variable,
# be installed during the build,
# belong to a Build-Depends field,
# carry an :ARCH suffix.
# Deps in the Build-Depends$suffix control field, filtered by the
# architecture and profile restrictions.
# For alternatives, both choices are reported.
sub build_depends : prototype($) ($suffix) {
state %cache;
my $field = "Build-Depends$suffix";
if ( not $cache{$field} ) {
$cache{$field} = [];
my $contents = $control->get_source->{$field};
if ($contents) {
deps_iterate(
deps_parse(
$contents,
reduce_restrictions => 1,
build_profiles => [get_build_profiles],
build_dep => 1,
),
sub {
my ($simple) = @_;
my $result = $simple->{package};
if ( $simple->{archqual} ) {
$result .= q{:} . $simple->{archqual};
}
&{$logorrheic_print}(" $field: $result");
push @{ $cache{$field} }, $result;
}
);
}
}
return @{ $cache{$field} };
}
# Return source package and version of the unique installed dep
# matching $glob.
# If $glob carries no architecture suffix, dpkg-query reports
# Multi-Arch: same co-installed variants. Only consider host and
# 'all' (MA:same and A:all may one day be compatible).
sub source_version : prototype($) ($glob) {
&{$logorrheic_print}(" source_version: $glob");
my $format =
"\${source:Package},\${source:Version},\${Architecture},\${Multi-Arch}\n";
my @out = qx_cmd( 'dpkg-query', '-Wf', $format, $glob ); # _;
my @result;
for (@out) {
chomp;
&{$logorrheic_print}(" $_");
my ( $source, $version, $architecture, $multi_arch ) = split qr/ , /;
if (
$architecture # The match is an installed package.
and (
$glob =~ m/ : / # $glob selects an architecture
or $multi_arch ne 'same' # the package is not co-installable
or $architecture eq hostarch or $architecture eq 'all'
)
)
{
push @result, $source, $version;
}
}
if ( @result != 2 ) {
error( "$glob should match one installed package, got:\n" . join q{ },
@out );
}
return @result;
}
my $RE_PATTERN = qr/ [[:lower:]\dS] [[:lower:]\dDPS-] + /;
my $RE_ARCH = qr/ (?: : [[:lower:]] [[:lower:]\d] + ) ? /;
my $RE_CAPTURE = qr{
[$][{]
( dh- (?:static)? builtusing: # var
( $RE_PATTERN $RE_ARCH ) # pattern
)
[}]
( [^,|]* ) # restrictions
};
sub search_in_dependency_string : prototype($$) ( $pkg, $string ) {
&{$logorrheic_print}(" dependency_string=|$string|");
while ( $string =~ m/$RE_CAPTURE/g ) {
my ( $var, $pattern, $restrictions ) = ( $1, $2, $3 );
&{$logorrheic_print}(" v=$var p=$pattern r=|$restrictions|");
my $parsed = Dpkg::Deps::Simple->new("fake $restrictions");
if ( $parsed->{relation} ) {
error("$var carries a version relation");
}
if ( $parsed->arch_is_concerned(hostarch)
and $parsed->profile_is_concerned( [get_build_profiles] ) )
{
my $regex = $pattern;
$regex =~ s/ D /[.]/g;
$regex =~ s/ P /[+]/g;
$regex =~ s/ S /.*/g;
my @bds = grep { m/ ^ $regex $ / }
build_depends(q{}),
build_depends( package_is_arch_all($pkg) ? '-Indep' : '-Arch' );
# If no build dependency matches, search installed packages.
if ( not @bds ) {
push @bds, $pattern =~ tr/DPS/.+*/r;
}
for my $glob (@bds) {
my ( $source, $version ) = source_version($glob);
verbose_print("In package $pkg, substvar $var += $source");
addsubstvar( $pkg, $var, $source, "= $version" );
}
}
else {
verbose_print(
"In package $pkg, substvar $var += disabled-by-restriction");
addsubstvar( $pkg, $var, 'disabled-by-restriction (= 0)' );
}
}
return;
}
# Only search in uncommented right hand sides.
sub search_in_substvars_file : prototype($) ($pkg) {
my $path = 'debian/' . pkgext($pkg) . 'substvars';
if ( -e $path ) {
&{$logorrheic_print}("substvars_file=$path");
open my $file, q{<}, $path or error("open $path failed: $ERRNO");
while (<$file>) {
if (m/ ^ [[:alnum:]] [[:alnum:]:-]* [?]? = (.*) /) {
search_in_dependency_string( $pkg, $1 );
}
}
close $file or error("close $path failed: $ERRNO");
}
return;
}
for my $pkg ( @{ $dh{'DOPACKAGES'} } ) {
# Parse the substvars file before extending it.
search_in_substvars_file($pkg);
for my $field_name ( 'Built-Using', 'Static-Built-Using' ) {
&{$logorrheic_print}("pkg=$pkg field=$field_name");
my $field_contents = $control->get_pkg_by_name($pkg)->{$field_name};
if ($field_contents) {
search_in_dependency_string( $pkg, $field_contents );
}
}
}
|
