Dpkg::Control::Hash: handle arbitrary field values

Checking the validity of new field values at run-time was very expensive.
In order to avoid this check, the design of the object has been changed to
accept arbitrary values, they are simply escaped as necessary during
output. The only data lost in a save()/load() cycle are the
trailing whitespaces on every line of all values.

This API change implies fixes in all scripts/modules reading/creating
values for multiline fields.

The non-regression test also had to be adjusted.

scripts/Dpkg/Changelog.pm

@@ -549,7 +549,7 @@ sub dpkg {
 	my $newurg = $entry->get_urgency() || '';
 	my $newurgn = $URGENCIES{$newurg} || -1;
 	$f->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
-	$f->{Changes} .= "\n ." . $entry->get_dpkg_changes();
+	$f->{Changes} .= "\n" . $entry->get_dpkg_changes();
 
 	# handle optional fields
 	$opts = $entry->get_optional_fields();

scripts/Dpkg/Changelog/Entry.pm

@@ -286,17 +286,7 @@ sub get_dpkg_changes {
     my ($self) = @_;
     my $header = $self->get_part("header") || "";
     $header =~ s/\s+$//;
-    my $changes = "\n $header\n .\n";
-    foreach my $line (@{$self->get_part("changes")}) {
-        $line =~ s/\s+$//;
-        if ($line eq "") {
-            $changes .= " .\n";
-        } else {
-            $changes .= " $line\n";
-        }
-    }
-    chomp $changes;
-    return $changes;
+    return "\n$header\n\n" . join("\n", @{$self->get_part("changes")});
 }
 
 =back

scripts/Dpkg/Checksums.pm

@@ -37,7 +37,7 @@ sub readchecksums {
 	return;
     }
     my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/;
-    for my $checksum (split /\n /, $fieldtext) {
+    for my $checksum (split /\n */, $fieldtext) {
 	next if $checksum eq '';
 	$checksum =~ m/^($check_regex{$alg})\s+(\d+)\s+($rx_fname)$/
 	    || do {

scripts/Dpkg/Control/Hash.pm

@@ -46,6 +46,13 @@ The order in which fields have been set is remembered and is used
 to be able to dump back the same content. The output order can also be
 overriden if needed.
 
+You can store arbitrary values in the hash, they will always be properly
+escaped in the output to conform to the syntax of control files. This is
+relevant mainly for multilines values: while the first line is always output
+unchanged directly after the field name, supplementary lines are
+modified. Empty lines and lines containing only dots are prefixed with
+" ." (space + dot) while other lines are prefixed with a single space.
+
 =head1 FUNCTIONS
 
 =over 4
@@ -162,7 +169,7 @@ sub parse_fh {
 	next if (m/^$/ and $paraborder);
 	next if (m/^#/);
 	$paraborder = 0;
-	if (m/^(\S+?)\s*:\s*(.*)$/) {
+	if (m/^(\S+?)\s*:\s?(.*)$/) {
 	    if (exists $self->{$1}) {
 		unless ($$self->{'allow_duplicate'}) {
 		    syntaxerr($desc, sprintf(_g("duplicate field %s found"), $1));
@@ -170,11 +177,15 @@ sub parse_fh {
 	    }
 	    $self->{$1} = $2;
 	    $cf = $1;
-	} elsif (m/^\s+\S/) {
+	} elsif (m/^\s(\s*\S.*)$/) {
+	    my $line = $1;
 	    unless (defined($cf)) {
                 syntaxerr($desc, _g("continued value line not in field"));
             }
-	    $self->{$cf} .= "\n$_";
+	    if ($line =~ /^\.+$/) {
+		$line = substr $line, 1;
+	    }
+	    $self->{$cf} .= "\n$line";
 	} elsif (m/^-----BEGIN PGP SIGNED MESSAGE/) {
 	    $expect_pgp_sig = 1;
 	    if ($$self->{'allow_pgp'}) {
@@ -280,16 +291,28 @@ sub output {
         @keys = @{$$self->{'in_order'}};
     }
 
-    foreach (@keys) {
-	if (exists $self->{$_}) {
+    foreach my $key (@keys) {
+	if (exists $self->{$key}) {
+	    my $value = $self->{$key};
             # Skip whitespace-only fields
-            next if $$self->{'drop_empty'} and ($self->{$_} !~ m/\S/);
-
+            next if $$self->{'drop_empty'} and $value !~ m/\S/;
+	    # Escape data to follow control file syntax
+	    my @lines = split(/\n/, $value);
+	    $value = (scalar @lines) ? shift @lines : "";
+	    foreach (@lines) {
+		s/\s+$//;
+		if (/^$/ or /^\.+$/) {
+		    $value .= "\n .$_";
+		} else {
+		    $value .= "\n $_";
+		}
+	    }
+	    # Print it out
             if ($fh) {
-	        print $fh "$_: " . $self->{$_} . "\n" ||
+	        print $fh "$key: $value\n" ||
                     syserr(_g("write error on control data"));
             }
-	    $str .= "$_: " . $self->{$_} . "\n" if defined wantarray;
+	    $str .= "$key: $value\n" if defined wantarray;
 	}
     }
     return $str;
@@ -325,13 +348,16 @@ sub apply_substvars {
 
     foreach my $f (keys %$self) {
         my $v = $substvars->substvars($self->{$f});
-        $v =~ s/\n[ \t]*(\n|$)/$1/; # Drop empty/whitespace-only lines
-
-        # TODO: do this only for dependency fields
-        $v =~ s/,[\s,]*,/,/g;
-        $v =~ s/^\s*,\s*//;
-        $v =~ s/\s*,\s*$//;
-
+	if ($v ne $self->{$f}) {
+	    # If we replaced stuff, ensure we're not breaking
+	    # a dependency field by introducing empty lines, or multiple
+	    # commas
+	    $v =~ s/\n[ \t]*(\n|$)/$1/; # Drop empty/whitespace-only lines
+	    # TODO: do this only for dependency fields
+	    $v =~ s/,[\s,]*,/,/g;
+	    $v =~ s/^\s*,\s*//;
+	    $v =~ s/\s*,\s*$//;
+	}
         $v =~ s/\$\{\}/\$/g; # XXX: what for?
 
         $self->{$f} = $v;
@@ -396,17 +422,6 @@ sub FETCH {
 sub STORE {
     my ($self, $key, $value) = @_;
     my $parent = $self->[1];
-    # Check value is sane
-    if ($value =~ m/\n[ \t]*\n/) {
-        internerr("field %s has blank lines >%s<", $key, $value);
-    }
-    if ($value =~ m/\n\S/) {
-        internerr("field %s has newline then non whitespace >%s<", $key, $value);
-    }
-    if ($value =~ m/\n$/) {
-        internerr("field %s has trailing newline >%s<", $key, $value);
-    }
-    # Store it
     $key = lc($key);
     if (not exists $self->[0]->{$key}) {
 	push @{$$parent->{'in_order'}}, field_capitalize($key);

scripts/Dpkg/Source/Package.pm

@@ -194,7 +194,7 @@ sub parse_files {
     my ($self) = @_;
     my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/;
     my $files = $self->{'fields'}{'Files'};
-    foreach my $file (split(/\n /, $files)) {
+    foreach my $file (split(/\n/, $files)) {
         next if $file eq '';
         $file =~ m/^($check_regex{md5})                    # checksum
                     [ \t]+(\d+)                            # size
@@ -417,9 +417,9 @@ sub add_file {
     getchecksums($filename, \%sums, \$size);
     $self->{'files'}{$fn} = $size;
     foreach my $alg (sort keys %sums) {
-        $self->{'fields'}{"Checksums-$alg"} .= "\n $sums{$alg} $size $fn";
+        $self->{'fields'}{"Checksums-$alg"} .= "\n$sums{$alg} $size $fn";
     }
-    $self->{'fields'}{'Files'}.= "\n $sums{md5} $size $fn";
+    $self->{'fields'}{'Files'}.= "\n$sums{md5} $size $fn";
 }
 
 sub write_dsc {

scripts/dpkg-genchanges.pl

@@ -326,13 +326,9 @@ foreach $_ (keys %{$changelog}) {
 }
 
 if ($changesdescription) {
-    $fields->{'Changes'} = '';
     open(X, "<", $changesdescription) || syserr(_g("read changesdescription"));
-    while(<X>) {
-        s/\s*\n$//;
-        $_= '.' unless m/\S/;
-        $fields->{'Changes'}.= "\n $_";
-    }
+    $fields->{'Changes'} = "\n" . join("", <X>);
+    close(X);
 }
 
 for my $pa (keys %pa2f) {
@@ -394,7 +390,7 @@ if (!is_binaryonly) {
 
     my $rx_fname = qr/[0-9a-zA-Z][-+:.,=0-9a-zA-Z_~]+/;
     my $files = $dsc_fields->{'Files'};
-    for my $line (split(/\n /, $files)) {
+    for my $line (split(/\n/, $files)) {
 	next if $line eq '';
 	$line =~ m/^($check_regex{md5})[ \t]+(\d+)[ \t]+($rx_fname)$/
 	    || error(_g("Files field contains bad line \`%s'"), $line);
@@ -460,7 +456,7 @@ if (!defined($fields->{'Date'})) {
 
 $fields->{'Binary'} = join(' ', map { $_->{'Package'} } $control->get_packages());
 # Avoid overly long line (>~1000 chars) by splitting over multiple lines
-$fields->{'Binary'} =~ s/(.{980,}?) /$1\n /g;
+$fields->{'Binary'} =~ s/(.{980,}?) /$1\n/g;
 
 unshift(@archvalues,'source') unless is_binaryonly;
 @archvalues = ('all') if $include == ARCH_INDEP;
@@ -468,7 +464,7 @@ unshift(@archvalues,'source') unless is_binaryonly;
     unless $include & ARCH_INDEP;
 $fields->{'Architecture'} = join(' ',@archvalues);
 
-$fields->{'Description'} = "\n ".join("\n ",sort @descriptions);
+$fields->{'Description'} = "\n" . join("\n", sort @descriptions);
 
 $fields->{'Files'} = '';
 
@@ -482,9 +478,9 @@ for my $f (@sourcefiles, @fileslistfiles) {
     $checksum{$f} ||= {};
     getchecksums($uf, $checksum{$f}, \$size{$f});
     foreach my $alg (sort keys %{$checksum{$f}}) {
-	$fields->{"Checksums-$alg"} .= "\n $checksum{$f}{$alg} $size{$f} $f";
+	$fields->{"Checksums-$alg"} .= "\n$checksum{$f}{$alg} $size{$f} $f";
     }
-    $fields->{'Files'} .= "\n $checksum{$f}{md5} $size{$f} $f2sec{$f} $f2pri{$f} $f";
+    $fields->{'Files'} .= "\n$checksum{$f}{md5} $size{$f} $f2sec{$f} $f2pri{$f} $f";
 }
 
 # redundant with the Files field

scripts/dpkg-scanpackages.pl

@@ -5,6 +5,7 @@ use strict;
 
 use IO::Handle;
 use IO::File;
+use IO::String;
 use Dpkg;
 use Dpkg::Gettext;
 use Dpkg::ErrorHandling;
@@ -187,15 +188,9 @@ FILE:
 	}
 	
 	my $fields = Dpkg::Control->new(type => CTRL_INDEX_PKG);
-	my $temp = $control;
-	while ($temp =~ s/^\n*(\S+):[ \t]*(.*(\n[ \t].*)*)\n//) {
-	    my ($key, $value) = ($1, $2);
-	    $value =~ s/\s+$//;
-	    $fields->{$key} = $value;
-	}
-	$temp =~ /^\n*$/
-	    or error(_g("Unprocessed text from %s control file; info:\n%s / %s"),
-	             $fn, $control, $temp);
+	my $io = IO::String->new($control);
+	$fields->parse_fh($io, $fn)
+	    or error(_g("couldn't parse control information from %s."), $fn);
 	
 	defined($fields->{'Package'})
 	    or error(_g("No Package field in control file of %s"), $fn);

scripts/dpkg-scansources.pl

@@ -329,10 +329,10 @@ sub process_dsc {
     # The files field will get an entry for the .dsc file itself.
     foreach my $alg (@check_supported) {
         if ($alg eq "md5") {
-            $fields->{Files} =~ s/^\n/\n $sums->{$alg} $size $file\n/;
+            $fields->{Files} =~ s/^\n/\n$sums->{$alg} $size $file\n/;
         } else {
             my $name = "Checksums-" . ucfirst($alg);
-            $fields->{$name} =~ s/^\n/\n $sums->{$alg} $size $file\n/
+            $fields->{$name} =~ s/^\n/\n$sums->{$alg} $size $file\n/
                 if defined $fields->{$name};
         }
     }

scripts/dpkg-source.pl

@@ -163,7 +163,7 @@ if ($options{'opmode'} eq 'build') {
 	    set_source_package($v);
 	    $fields->{$_} = $v;
 	} elsif (m/^Uploaders$/i) {
-	    ($fields->{$_} = $v) =~ s/[\r\n]//g; # Merge in a single-line
+	    ($fields->{$_} = $v) =~ s/[\r\n]/ /g; # Merge in a single-line
 	} elsif (m/^Build-(Depends|Conflicts)(-Indep)?$/i) {
 	    my $dep;
 	    my $type = field_get_dep_type($_);
@@ -235,7 +235,7 @@ if ($options{'opmode'} eq 'build') {
     
     $fields->{'Binary'} = join(', ', @binarypackages);
     # Avoid overly long line (>~1000 chars) by splitting over multiple lines
-    $fields->{'Binary'} =~ s/(.{980,}?), ?/$1,\n /g;
+    $fields->{'Binary'} =~ s/(.{980,}?), ?/$1,\n/g;
 
     # Generate list of formats to try
     my @try_formats = (@cmdline_formats);

scripts/t/700_Dpkg_Control.t

@@ -15,13 +15,16 @@ my $c = Dpkg::Control::Info->new("$srcdir/control-1");
 
 my $io = IO::String->new();
 $c->dump($io);
-is(${$io->string_ref()},
-'Source: mysource
+my $value = ${$io->string_ref()};
+my $expected = 'Source: mysource
 My-Field-One: myvalue1
 My-Field-Two: myvalue2
 Long-Field: line1
  line 2 line 2 line 2
- line 3 line 3 line 3
+ .
+   line 3 line 3 line 3
+ ..
+ line 4
 Empty-Field: 
 
 Package: mypackage1
@@ -32,17 +35,21 @@ Depends: hello
 
 Package: mypackage3
 Depends: hello
-Description: short one
+Description:   short one
  long one
  very long one
-', "Dump of $srcdir/control-1");
+';
+is($value, $expected, "Dump of $srcdir/control-1");
 
 my $src = $c->get_source();
 is($src->{'my-field-one'}, 'myvalue1', "Access field through badly capitalized field name");
 is($src->{'long-field'}, 
 'line1
- line 2 line 2 line 2
- line 3 line 3 line 3', "Get multi-line field");
+line 2 line 2 line 2
+
+  line 3 line 3 line 3
+.
+line 4', "Get multi-line field");
 is($src->{'Empty-field'}, "", "Get empty field");
 
 my $pkg = $c->get_pkg_by_idx(1);

scripts/t/700_Dpkg_Control/control-1

@@ -3,8 +3,11 @@ Source: mysource
 my-field-one: myvalue1
 my-field-two: myvalue2
 long-field: line1
- line 2 line 2 line 2
- line 3 line 3 line 3
+ line 2 line 2 line 2    
+ .
+   line 3 line 3 line 3
+ ..
+ line 4
 empty-field: 
      
 # First package
@@ -16,7 +19,7 @@ Package: mypackage2
 Depends: hello
 
 Package: mypackage3
-Depends: hello
-Description: short one
+Depends:hello
+Description:   short one
  long one
  very long one