scripts: Update restriction formula syntax

 - The restriction list parsing now reflects the changes at
   <https://wiki.debian.org/BuildProfileSpec> which were agreed upon
   in the bootstrap sprint 2014 in Paris.
 - Restriction lists are now restriction formulas.
 - Restriction formulas are given in disjunctive normal form expression:
       pkg <bar baz> <blub>
 - Removal of the implicit prefix/namespace mechanic.
 - Since there can be more than one <> block, the regex in
   parse_string() in Dpkg::Deps is now greedy.
 - Construct the profiles entry of the Packages-List field by converting
   the "<bar baz> <blub>" syntax into "bar,baz+blub".
 - Include a temporary compatibility mapping for the old way to write
   the Build-Profiles field in binary packages which can be removed once
   all affected source packages have moved to the new syntax.
 - Adjust testcases.

Closes: #760158

[guillem@debian.org:
 - Add a warning when using the old syntax in dpkg-source.
 - Move comments before the regexes, not besides them in dpkg-source.
 - Change from an xnor to == in evaluate_restriction_formula().
 - Move the Dpkg::Util import close to the other Dpkg imports.
 - Add test cases for the new parse_build_profiles() behavior. ]

Signed-off-by: Guillem Jover <guillem@debian.org>

5 files changed, 108 insertions, 56 deletions

diff --git a/scripts/Dpkg/BuildProfiles.pm b/scripts/Dpkg/BuildProfiles.pm
index d35396eb1..692e61d37 100644
--- a/scripts/Dpkg/BuildProfiles.pm
+++ b/scripts/Dpkg/BuildProfiles.pm
@@ -24,6 +24,7 @@ our @EXPORT_OK = qw(get_build_profiles set_build_profiles parse_build_profiles
 
 use Exporter qw(import);
 
+use Dpkg::Util qw(:list);
 use Dpkg::BuildEnv;
 
 my $cache_profiles;
@@ -78,53 +79,53 @@ sub set_build_profiles {
 
 =item my @profiles = parse_build_profiles($string)
 
-Parses a build profiles specification, into an array.
+Parses a build profiles specification, into an array of array references.
 
 =cut
 
 sub parse_build_profiles {
     my $string = shift;
 
-    return map { lc } split /\s+/, $string;
+    $string =~ s/^\s*<(.*)>\s*$/$1/;
+
+    return map { [ split /\s+/ ] } split />\s+</, $string;
 }
 
 =item evaluate_restriction_formula(\@formula, \@profiles)
 
-Evaluate whether a restriction list, is true or false, given the array of
-enabled build profiles.
+Evaluate whether a restriction formula of the form "<foo bar> <baz>", given as
+a nested array, is true or false, given the array of enabled build profiles.
 
 =cut
 
 sub evaluate_restriction_formula {
-    my ($restrictions, $build_profiles) = @_;
+    my ($formula, $profiles) = @_;
 
-    my $seen_profile = 0;
-    foreach my $restriction (@{$restrictions}) {
-        # Determine if this restriction is negated, and within the "profile"
-        # namespace, otherwise it does not concern this check.
-        next if $restriction !~ m/^(!)?profile\.(.*)/;
+    # Restriction formulas are in disjunctive normal form:
+    # (foo AND bar) OR (blub AND bla)
+    foreach my $restrlist (@{$formula}) {
+        my $seen_profile = 1;
 
-        my $negated = defined $1 && $1 eq '!';
-        my $profile = $2;
+        foreach my $restriction (@$restrlist) {
+            next if $restriction !~ m/^(!)?(.+)/;
 
-        # Determine if the restriction matches any of the specified profiles.
-        my $found = any { $_ eq $profile } @{$build_profiles};
+            my $negated = defined $1 && $1 eq '!';
+            my $profile = $2;
+            my $found = any { $_ eq $profile } @{$profiles};
 
-        if ($negated) {
-            if ($found) {
+            # If a negative set profile is encountered, stop processing.
+            # If a positive unset profile is encountered, stop processing.
+            if ($found == $negated) {
                 $seen_profile = 0;
                 last;
-            } else {
-                # "!profile.this" includes by default all other profiles
-                # unless they also appear in a "!profile.other".
-                $seen_profile = 1;
             }
-        } elsif ($found) {
-            $seen_profile = 1;
-            last;
         }
+
+        # This conjunction evaluated to true so we don't have to evaluate
+        # the others.
+        return 1 if $seen_profile;
     }
-    return $seen_profile;
+    return 0;
 }
 
 =back
diff --git a/scripts/Dpkg/Deps.pm b/scripts/Dpkg/Deps.pm
index d40366e8b..99945fc8e 100644
--- a/scripts/Dpkg/Deps.pm
+++ b/scripts/Dpkg/Deps.pm
@@ -209,15 +209,16 @@ Define the active build profiles. By default no profile is defined.
 =item reduce_profiles (defaults to 0)
 
 If set to 1, ignore dependencies that do not concern the current build
-profile. This implicitly strips off the profile restriction list so
+profile. This implicitly strips off the profile restriction formula so
 that the resulting dependencies are directly applicable to the current
 profiles.
 
 =item reduce_restrictions (defaults to 0)
 
 If set to 1, ignore dependencies that do not concern the current set of
-restrictions. This implicitly strips off any restriction list so that the
-resulting dependencies are directly applicable to the current restriction.
+restrictions. This implicitly strips off any architecture restriction list
+or restriction formula so that the resulting dependencies are directly
+applicable to the current restriction.
 This currently implies C<reduce_arch> and C<reduce_profiles>, and overrides
 them if set.
 
@@ -601,7 +602,7 @@ sub parse_string {
               )?                            # end of optional architecture
               (?:                           # start of optional restriction
                 \s* <                       # open bracket for restriction
-                \s* (.*?)                   # don't parse restrictions now
+                \s* (.*)                    # do not parse restrictions now
                 \s* >                       # closing bracket
               )?                            # end of optional restriction
               \s*$                          # trailing spaces at end
@@ -636,7 +637,9 @@ sub output {
 	$res .= ' [' . join(' ', @{$self->{arches}}) . ']';
     }
     if (defined($self->{restrictions})) {
-	$res .= ' <' . join(' ', @{$self->{restrictions}}) . '>';
+        for my $restrlist (@{$self->{restrictions}}) {
+            $res .= ' <' . join(' ', @{$restrlist}) . '>';
+        }
     }
     if (defined($fh)) {
 	print { $fh } $res;
diff --git a/scripts/dpkg-source.pl b/scripts/dpkg-source.pl
index 83888f25c..9157a43f9 100755
--- a/scripts/dpkg-source.pl
+++ b/scripts/dpkg-source.pl
@@ -273,8 +273,31 @@ if ($options{opmode} =~ /^(-b|--print-format|--(before|after)-build|--commit)$/)
         my $pkg_summary = sprintf('%s %s %s %s', $p, $type, $sect, $prio);
 
         $pkg_summary .= ' arch=' . join ',', split /\s+/, $arch;
-        $pkg_summary .= ' profile=' . join ',', split /\s+/, $profile
-            if defined $profile;
+
+        if (defined $profile) {
+            # If the string does not contain brackets then it is using the
+            # old syntax (glibc, file, dbus and doxygen are affected).
+            # Thus we convert the old syntax to the new one. This conversion
+            # can be dropped once the old syntax is not in the archive anymore.
+            # <http://codesearch.debian.net/search?q=Build-Profiles%3A\s%2B[^<]+path%3Adebian%2Fcontrol>
+            if ($profile !~ m/^\s*<.*>\s*$/) {
+                # Issue an ephemereal non-translatable warning.
+                warning('binary package stanza %s is using an obsolete ' .
+                        'Build-Profiles syntax', $p);
+                $profile =~ s/([!a-z0-9]+)/<$1>/g;
+            }
+
+            # Instead of splitting twice and then joining twice, we just do
+            # simple string replacements:
+
+            # Remove the enclosing <>
+            $profile =~ s/^\s*<(.*)>\s*$/$1/;
+            # Join lists with a plus (OR)
+            $profile =~ s/>\s+</+/g;
+            # Join their elements with a comma (AND)
+            $profile =~ s/\s+/,/g;
+            $pkg_summary .= " profile=$profile";
+        }
 
         push @pkglist, $pkg_summary;
 	push @binarypackages, $p;
diff --git a/scripts/t/Dpkg_BuildProfiles.t b/scripts/t/Dpkg_BuildProfiles.t
index 82663dc6f..4b4b23f77 100644
--- a/scripts/t/Dpkg_BuildProfiles.t
+++ b/scripts/t/Dpkg_BuildProfiles.t
@@ -16,7 +16,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 2;
+use Test::More tests => 6;
 
 BEGIN {
     use_ok('Dpkg::BuildProfiles', qw(parse_build_profiles));
@@ -24,9 +24,26 @@ BEGIN {
 
 # TODO: Add actual test cases.
 
-my @build_profiles = qw(nocheck nodoc stage1);
+my $formula;
 
-is(parse_build_profiles('nocheck nodoc stage1'), @build_profiles,
-   'parse build profiles');
+$formula = [ ];
+is_deeply([ parse_build_profiles('') ], $formula,
+    'parse build profiles formula empty');
+
+$formula = [ [ qw(nocheck) ] ];
+is_deeply([ parse_build_profiles('<nocheck>') ], $formula,
+    'parse build profiles formula single');
+
+$formula = [ [ qw(nocheck nodoc stage1) ] ];
+is_deeply([ parse_build_profiles('<nocheck nodoc stage1>') ], $formula,
+    'parse build profiles formula AND');
+
+$formula = [ [ qw(nocheck) ], [ qw(nodoc) ] ];
+is_deeply([ parse_build_profiles('<nocheck> <nodoc>') ], $formula,
+    'parse build profiles formula OR');
+
+$formula = [ [ qw(nocheck nodoc) ], [ qw(stage1) ] ];
+is_deeply([ parse_build_profiles('<nocheck nodoc> <stage1>') ], $formula,
+    'parse build profiles formula AND, OR');
 
 1;
diff --git a/scripts/t/Dpkg_Deps.t b/scripts/t/Dpkg_Deps.t
index de4e60548..2fbad4287 100644
--- a/scripts/t/Dpkg_Deps.t
+++ b/scripts/t/Dpkg_Deps.t
@@ -70,20 +70,26 @@ is($dep_i386->output(), 'libc6 (>= 2.5)', 'Arch reduce 1/3');
 is($dep_alpha->output(), 'libc6.1', 'Arch reduce 2/3');
 is($dep_hurd->output(), 'libc0.1', 'Arch reduce 3/3');
 
-my $field_profile = 'dep1 <!profile.stage1 !profile.notest>, ' .
-'dep2 <profile.stage1 !profile.notest>, ' .
-'dep3 <profile.notest !profile.stage1>, ' .
-'dep4 <profile.stage1 profile.notest>, ' .
-'dep5 <profile.stage1>, dep6 <!profile.stage1>, ' .
-'dep7 <profile.stage1> | dep8 <profile.notest>';
+my $field_profile = 'dep1 <!stage1 !notest>, ' .
+'dep2 <stage1 !notest>, ' .
+'dep3 <notest !stage1>, ' .
+'dep4 <stage1 notest>, ' .
+'dep5 <stage1>, dep6 <!stage1>, ' .
+'dep7 <stage1> | dep8 <notest>, ' .
+'dep9 <!stage1> <!notest>, ' .
+'dep10 <stage1> <!notest>, ' .
+'dep11 <stage1> <notest>, '.
+'dep12 <!notest> <!stage1>, ' .
+'dep13 <notest> <!stage1>, ' .
+'dep14 <notest> <stage1>';
 my $dep_noprof = deps_parse($field_profile, reduce_profiles => 1, build_profiles => []);
 my $dep_stage1 = deps_parse($field_profile, reduce_profiles => 1, build_profiles => ['stage1']);
 my $dep_notest = deps_parse($field_profile, reduce_profiles => 1, build_profiles => ['notest']);
 my $dep_stage1notest = deps_parse($field_profile, reduce_profiles => 1, build_profiles => ['stage1', 'notest']);
-is($dep_noprof->output(), 'dep1, dep2, dep3, dep6', 'Profile reduce 1/4');
-is($dep_stage1->output(), 'dep2, dep4, dep5, dep7', 'Profile reduce 2/4');
-is($dep_notest->output(), 'dep3, dep4, dep6, dep8', 'Profile reduce 3/4');
-is($dep_stage1notest->output(), 'dep2, dep3, dep4, dep5, dep7 | dep8', 'Profile reduce 4/4');
+is($dep_noprof->output(), 'dep1, dep6, dep9, dep10, dep12, dep13', 'Profile reduce 1/4');
+is($dep_stage1->output(), 'dep2, dep5, dep7, dep9, dep10, dep11, dep12, dep14', 'Profile reduce 2/4');
+is($dep_notest->output(), 'dep3, dep6, dep8, dep9, dep11, dep12, dep13, dep14', 'Profile reduce 3/4');
+is($dep_stage1notest->output(), 'dep4, dep5, dep7 | dep8, dep10, dep11, dep13, dep14', 'Profile reduce 4/4');
 
 $dep_noprof = deps_parse($field_profile);
 $dep_noprof->reduce_profiles([]);
@@ -93,21 +99,23 @@ $dep_notest = deps_parse($field_profile);
 $dep_notest->reduce_profiles(['notest']);
 $dep_stage1notest = deps_parse($field_profile);
 $dep_stage1notest->reduce_profiles(['stage1', 'notest']);
-is($dep_noprof->output(), 'dep1, dep2, dep3, dep6', 'Profile post-reduce 1/4');
-is($dep_stage1->output(), 'dep2, dep4, dep5, dep7', 'Profile post-reduce 2/4');
-is($dep_notest->output(), 'dep3, dep4, dep6, dep8', 'Profile post-reduce 3/4');
-is($dep_stage1notest->output(), 'dep2, dep3, dep4, dep5, dep7 | dep8', 'Profile post-reduce 4/4');
-
-my $field_restrict = 'dep1 <!profile.bootstrap !other.restrict>, ' .
-'dep2 <profile.bootstrap other.restrict>, ' .
-'dep3 <!other.restrict>, ' .
-'dep4 <other.restrict>';
+is($dep_noprof->output(), 'dep1, dep6, dep9, dep10, dep12, dep13', 'Profile post-reduce 1/4');
+is($dep_stage1->output(), 'dep2, dep5, dep7, dep9, dep10, dep11, dep12, dep14', 'Profile post-reduce 2/4');
+is($dep_notest->output(), 'dep3, dep6, dep8, dep9, dep11, dep12, dep13, dep14', 'Profile post-reduce 3/4');
+is($dep_stage1notest->output(), 'dep4, dep5, dep7 | dep8, dep10, dep11, dep13, dep14', 'Profile post-reduce 4/4');
+
+my $field_restrict = 'dep1 <!bootstrap !restrict>, ' .
+'dep2 <bootstrap restrict>, ' .
+'dep3 <!restrict>, ' .
+'dep4 <restrict>, ' .
+'dep5 <!bootstrap> <!restrict>, ' .
+'dep6 <bootstrap> <restrict>';
 my $dep_restrict = deps_parse($field_restrict, reduce_restrictions => 1, build_profiles => []);
-is($dep_restrict->output(), 'dep1', 'Unknown restrictions reduce');
+is($dep_restrict->output(), 'dep1, dep3, dep5', 'Unknown restrictions reduce');
 
 $dep_restrict = deps_parse($field_restrict);
 $dep_restrict->reduce_profiles([]);
-is($dep_restrict->output(), 'dep1', 'Unknown restrictions post-reduce');
+is($dep_restrict->output(), 'dep1, dep3, dep5', 'Unknown restrictions post-reduce');
 
 my $facts = Dpkg::Deps::KnownFacts->new();
 $facts->add_installed_package('mypackage', '1.3.4-1', get_host_arch(), 'no');