scripts/Dpkg/Control/Fields.pm

   1 # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 package Dpkg::Control::Fields;
  17
  18 use strict;
  19 use warnings;
  20
  21 our $VERSION = "1.00";
  22
  23 use base qw(Exporter);
  24 use Dpkg::Gettext;
  25 use Dpkg::ErrorHandling;
  26 use Dpkg::Control::Types;
  27 use Dpkg::Checksums;
  28 use Dpkg::Vendor qw(run_vendor_hook);
  29
  30 our @EXPORT = qw(field_capitalize field_is_official field_is_allowed_in
  31                  field_transfer_single field_transfer_all
  32                  field_list_src_dep field_list_pkg_dep field_get_dep_type
  33                  field_ordered_list field_register
  34                  field_insert_after field_insert_before);
  35
  36 use constant {
  37     ALL_PKG => CTRL_INFO_PKG | CTRL_INDEX_PKG | CTRL_PKG_DEB | CTRL_FILE_STATUS,
  38     ALL_SRC => CTRL_INFO_SRC | CTRL_INDEX_SRC | CTRL_PKG_SRC,
  39     ALL_CHANGES => CTRL_FILE_CHANGES | CTRL_CHANGELOG,
  40 };
  41
  42 # The canonical list of fields
  43
  44 # Note that fields used only in dpkg's available file are not listed
  45 # Deprecated fields of dpkg's status file are also not listed
  46 our %FIELDS = (
  47     'Architecture' => {
  48         allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_CHANGES) & (~CTRL_INFO_SRC),
  49     },
  50     'Binary' => {
  51         allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES,
  52     },
  53     'Binary-Only' => {
  54         allowed => ALL_CHANGES,
  55     },
  56     'Breaks' => {
  57         allowed => ALL_PKG,
  58         dependency => 'union',
  59         dep_order => 7,
  60     },
  61     'Bugs' => {
  62         allowed => (ALL_PKG | CTRL_INFO_SRC | CTRL_FILE_VENDOR) & (~CTRL_INFO_PKG),
  63     },
  64     'Build-Conflicts' => {
  65         allowed => ALL_SRC,
  66         dependency => 'union',
  67         dep_order => 4,
  68     },
  69     'Build-Conflicts-Arch' => {
  70         allowed => ALL_SRC,
  71         dependency => 'union',
  72         dep_order => 5,
  73     },
  74     'Build-Conflicts-Indep' => {
  75         allowed => ALL_SRC,
  76         dependency => 'union',
  77         dep_order => 6,
  78     },
  79     'Build-Depends' => {
  80         allowed => ALL_SRC,
  81         dependency => 'normal',
  82         dep_order => 1,
  83     },
  84     'Build-Depends-Arch' => {
  85         allowed => ALL_SRC,
  86         dependency => 'normal',
  87         dep_order => 2,
  88     },
  89     'Build-Depends-Indep' => {
  90         allowed => ALL_SRC,
  91         dependency => 'normal',
  92         dep_order => 3,
  93     },
  94     'Built-Using' => {
  95         allowed => ALL_PKG,
  96         dependency => 'union',
  97         dep_order => 10,
  98     },
  99     'Changed-By' => {
 100         allowed => CTRL_FILE_CHANGES,
 101     },
 102     'Changes' => {
 103         allowed => ALL_CHANGES,
 104     },
 105     'Closes' => {
 106         allowed => ALL_CHANGES,
 107     },
 108     'Conffiles' => {
 109         allowed => CTRL_FILE_STATUS,
 110     },
 111     'Config-Version' => {
 112         allowed => CTRL_FILE_STATUS,
 113     },
 114     'Conflicts' => {
 115         allowed => ALL_PKG,
 116         dependency => 'union',
 117         dep_order => 6,
 118     },
 119     'Date' => {
 120         allowed => ALL_CHANGES,
 121     },
 122     'Depends' => {
 123         allowed => ALL_PKG,
 124         dependency => 'normal',
 125         dep_order => 2,
 126     },
 127     'Description' => {
 128         allowed => ALL_PKG | CTRL_FILE_CHANGES,
 129     },
 130     'Directory' => {
 131         allowed => CTRL_INDEX_SRC,
 132     },
 133     'Distribution' => {
 134         allowed => ALL_CHANGES,
 135     },
 136     'Enhances' => {
 137         allowed => ALL_PKG,
 138         dependency => 'union',
 139         dep_order => 5,
 140     },
 141     'Essential' => {
 142         allowed => ALL_PKG,
 143     },
 144     'Filename' => {
 145         allowed => CTRL_INDEX_PKG,
 146     },
 147     'Files' => {
 148         allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES,
 149     },
 150     'Format' => {
 151         allowed => CTRL_PKG_SRC | CTRL_FILE_CHANGES,
 152     },
 153     'Homepage' => {
 154         allowed => ALL_SRC | ALL_PKG,
 155     },
 156     'Installed-Size' => {
 157         allowed => ALL_PKG & ~CTRL_INFO_PKG,
 158     },
 159     'Installer-Menu-Item' => {
 160         allowed => ALL_PKG,
 161     },
 162     'Kernel-Version' => {
 163         allowed => ALL_PKG,
 164     },
 165     'Origin' => {
 166         allowed => (ALL_PKG | ALL_SRC) & (~CTRL_INFO_PKG),
 167     },
 168     'Maintainer' => {
 169         allowed => CTRL_PKG_DEB | ALL_SRC | ALL_CHANGES,
 170     },
 171     'Multi-Arch' => {
 172         allowed => ALL_PKG,
 173     },
 174     'Package' => {
 175         allowed => ALL_PKG,
 176     },
 177     'Package-List' => {
 178         allowed => ALL_SRC & ~CTRL_INFO_SRC,
 179     },
 180     'Package-Type' => {
 181         allowed => ALL_PKG,
 182     },
 183     'Parent' => {
 184         allowed => CTRL_FILE_VENDOR,
 185     },
 186     'Pre-Depends' => {
 187         allowed => ALL_PKG,
 188         dependency => 'normal',
 189         dep_order => 1,
 190     },
 191     'Priority' => {
 192         allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG,
 193     },
 194     'Provides' => {
 195         allowed => ALL_PKG,
 196         dependency => 'union',
 197         dep_order => 9,
 198     },
 199     'Recommends' => {
 200         allowed => ALL_PKG,
 201         dependency => 'normal',
 202         dep_order => 3,
 203     },
 204     'Replaces' => {
 205         allowed => ALL_PKG,
 206         dependency => 'union',
 207         dep_order => 8,
 208     },
 209     'Section' => {
 210         allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG,
 211     },
 212     'Size' => {
 213         allowed => CTRL_INDEX_PKG,
 214     },
 215     'Source' => {
 216         allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES) &
 217                    (~(CTRL_INDEX_SRC | CTRL_INFO_PKG)),
 218     },
 219     'Standards-Version' => {
 220         allowed => ALL_SRC,
 221     },
 222     'Status' => {
 223         allowed => CTRL_FILE_STATUS,
 224     },
 225     'Subarchitecture' => {
 226         allowed => ALL_PKG,
 227     },
 228     'Suggests' => {
 229         allowed => ALL_PKG,
 230         dependency => 'normal',
 231         dep_order => 4,
 232     },
 233     'Tag' => {
 234         allowed => ALL_PKG,
 235     },
 236     'Task' => {
 237         allowed => ALL_PKG,
 238     },
 239     'Triggers-Awaited' => {
 240         allowed => CTRL_FILE_STATUS,
 241     },
 242     'Triggers-Pending' => {
 243         allowed => CTRL_FILE_STATUS,
 244     },
 245     'Uploaders' => {
 246         allowed => ALL_SRC,
 247     },
 248     'Urgency' => {
 249         allowed => ALL_CHANGES,
 250     },
 251     'Vcs-Browser' => {
 252         allowed => ALL_SRC,
 253     },
 254     'Vcs-Arch' => {
 255         allowed => ALL_SRC,
 256     },
 257     'Vcs-Bzr' => {
 258         allowed => ALL_SRC,
 259     },
 260     'Vcs-Cvs' => {
 261         allowed => ALL_SRC,
 262     },
 263     'Vcs-Darcs' => {
 264         allowed => ALL_SRC,
 265     },
 266     'Vcs-Git' => {
 267         allowed => ALL_SRC,
 268     },
 269     'Vcs-Hg' => {
 270         allowed => ALL_SRC,
 271     },
 272     'Vcs-Mtn' => {
 273         allowed => ALL_SRC,
 274     },
 275     'Vcs-Svn' => {
 276         allowed => ALL_SRC,
 277     },
 278     'Vendor' => {
 279         allowed => CTRL_FILE_VENDOR,
 280     },
 281     'Vendor-Url' => {
 282         allowed => CTRL_FILE_VENDOR,
 283     },
 284     'Version' => {
 285         allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES) &
 286                     (~(CTRL_INFO_SRC | CTRL_INFO_PKG)),
 287     },
 288 );
 289
 290 my @checksum_fields = map { &field_capitalize("Checksums-$_") } checksums_get_list();
 291 my @sum_fields = map { $_ eq "md5" ? "MD5sum" : &field_capitalize($_) }
 292                  checksums_get_list();
 293 &field_register($_, CTRL_PKG_SRC | CTRL_FILE_CHANGES) foreach @checksum_fields;
 294 &field_register($_, CTRL_INDEX_PKG) foreach @sum_fields;
 295
 296 our %FIELD_ORDER = (
 297     CTRL_PKG_DEB() => [
 298         qw(Package Package-Type Source Version Built-Using Kernel-Version
 299         Architecture Subarchitecture Installer-Menu-Item Essential Origin Bugs
 300         Maintainer Installed-Size), &field_list_pkg_dep(),
 301         qw(Section Priority Multi-Arch Homepage Description Tag Task)
 302     ],
 303     CTRL_PKG_SRC() => [
 304         qw(Format Source Binary Architecture Version Origin Maintainer
 305         Uploaders Homepage Standards-Version Vcs-Browser
 306         Vcs-Arch Vcs-Bzr Vcs-Cvs Vcs-Darcs Vcs-Git Vcs-Hg Vcs-Mtn
 307         Vcs-Svn), &field_list_src_dep(), qw(Package-List),
 308         @checksum_fields, qw(Files)
 309     ],
 310     CTRL_FILE_CHANGES() => [
 311         qw(Format Date Source Binary Binary-Only Architecture Version
 312         Distribution Urgency Maintainer Changed-By Description
 313         Closes Changes),
 314         @checksum_fields, qw(Files)
 315     ],
 316     CTRL_CHANGELOG() => [
 317         qw(Source Binary-Only Version Distribution Urgency Maintainer
 318         Date Closes Changes)
 319     ],
 320     CTRL_FILE_STATUS() => [ # Same as fieldinfos in lib/dpkg/parse.c
 321         qw(Package Essential Status Priority Section Installed-Size Origin
 322         Maintainer Bugs Architecture Multi-Arch Source Version Config-Version
 323         Replaces Provides Depends Pre-Depends Recommends Suggests Breaks
 324         Conflicts Enhances Conffiles Description Triggers-Pending
 325         Triggers-Awaited)
 326     ],
 327 );
 328 # Order for CTRL_INDEX_PKG is derived from CTRL_PKG_DEB
 329 $FIELD_ORDER{CTRL_INDEX_PKG()} = [ @{$FIELD_ORDER{CTRL_PKG_DEB()}} ];
 330 &field_insert_before(CTRL_INDEX_PKG, 'Section', 'Filename', 'Size', @sum_fields);
 331 # Order for CTRL_INDEX_SRC is derived from CTRL_PKG_SRC
 332 $FIELD_ORDER{CTRL_INDEX_SRC()} = [ @{$FIELD_ORDER{CTRL_PKG_SRC()}} ];
 333 @{$FIELD_ORDER{CTRL_INDEX_SRC()}} = map { $_ eq "Source" ? "Package" : $_ }
 334                                   @{$FIELD_ORDER{CTRL_PKG_SRC()}};
 335 &field_insert_after(CTRL_INDEX_SRC, "Version", "Priority", "Section");
 336 &field_insert_before(CTRL_INDEX_SRC, "Checksums-Md5", "Directory");
 337
 338 # Register vendor specifics fields
 339 foreach my $op (run_vendor_hook("register-custom-fields")) {
 340     next if not (defined $op and ref $op); # Skip when not implemented by vendor
 341     my $func = shift @$op;
 342     if ($func eq "register") {
 343         &field_register(@$op);
 344     } elsif ($func eq "insert_before") {
 345         &field_insert_before(@$op);
 346     } elsif ($func eq "insert_after") {
 347         &field_insert_after(@$op);
 348     } else {
 349         error("vendor hook register-custom-fields sent bad data: @$op");
 350     }
 351 }
 352
 353 =encoding utf8
 354
 355 =head1 NAME
 356
 357 Dpkg::Control::Fields - manage (list of official) control fields
 358
 359 =head1 DESCRIPTION
 360
 361 The modules contains a list of fieldnames with associated meta-data explaining
 362 in which type of control information they are allowed. The types are the
 363 CTRL_* constants exported by Dpkg::Control.
 364
 365 =head1 FUNCTIONS
 366
 367 =over 4
 368
 369 =item my $f = field_capitalize($field_name)
 370
 371 Returns the field name properly capitalized. All characters are lowercase,
 372 except the first of each word (words are separated by a dash in field names).
 373
 374 =cut
 375
 376 sub field_capitalize($) {
 377     my $field = lc(shift);
 378     # Some special cases due to history
 379     return "MD5sum" if $field eq "md5sum";
 380     return uc($field) if checksums_is_supported($field);
 381     # Generic case
 382     return join '-', map { ucfirst } split /-/, $field;
 383 }
 384
 385 =item field_is_official($fname)
 386
 387 Returns true if the field is official and known.
 388
 389 =cut
 390
 391 sub field_is_official($) {
 392     return exists $FIELDS{field_capitalize($_[0])};
 393 }
 394
 395 =item field_is_allowed_in($fname, @types)
 396
 397 Returns true (1) if the field $fname is allowed in all the types listed in
 398 the list. Note that you can use type sets instead of individual types (ex:
 399 CTRL_FILE_CHANGES | CTRL_CHANGELOG).
 400
 401 field_allowed_in(A|B, C) returns true only if the field is allowed in C
 402 and either A or B.
 403
 404 Undef is returned for non-official fields.
 405
 406 =cut
 407
 408 sub field_is_allowed_in($@) {
 409     my ($field, @types) = @_;
 410     $field = field_capitalize($field);
 411     return undef unless field_is_official($field);
 412
 413     return 0 if not scalar(@types);
 414     foreach my $type (@types) {
 415         next if $type == CTRL_UNKNOWN; # Always allowed
 416         return 0 unless $FIELDS{$field}{'allowed'} & $type;
 417     }
 418     return 1;
 419 }
 420
 421 =item field_transfer_single($from, $to, $field)
 422
 423 If appropriate, copy the value of the field named $field taken from the
 424 $from Dpkg::Control object to the $to Dpkg::Control object.
 425
 426 Official fields are copied only if the field is allowed in both types of
 427 objects. Custom fields are treated in a specific manner. When the target
 428 is not among CTRL_PKG_SRC, CTRL_PKG_DEB or CTRL_FILE_CHANGES, then they
 429 are alway copied as is (the X- prefix is kept). Otherwise they are not
 430 copied except if the target object matches the target destination encoded
 431 in the field name. The initial X denoting custom fields can be followed by
 432 one or more letters among "S" (Source: corresponds to CTRL_PKG_SRC), "B"
 433 (Binary: corresponds to CTRL_PKG_DEB) or "C" (Changes: corresponds to
 434 CTRL_FILE_CHANGES).
 435
 436 Returns undef if nothing has been copied or the name of the new field
 437 added to $to otherwise.
 438
 439 =cut
 440
 441 sub field_transfer_single($$;$) {
 442     my ($from, $to, $field) = @_;
 443     $field = $_ unless defined $field;
 444     my ($from_type, $to_type) = ($from->get_type(), $to->get_type());
 445     $field = field_capitalize($field);
 446
 447     if (field_is_allowed_in($field, $from_type, $to_type)) {
 448         $to->{$field} = $from->{$field};
 449         return $field;
 450     } elsif ($field =~ /^X([SBC]*)-/i) {
 451         my $dest = $1;
 452         if (($dest =~ /B/i and $to_type == CTRL_PKG_DEB) or
 453             ($dest =~ /S/i and $to_type == CTRL_PKG_SRC) or
 454             ($dest =~ /C/i and $to_type == CTRL_FILE_CHANGES))
 455         {
 456             my $new = $field;
 457             $new =~ s/^X([SBC]*)-//i;
 458             $to->{$new} = $from->{$field};
 459             return $new;
 460         } elsif ($to_type != CTRL_PKG_DEB and
 461                  $to_type != CTRL_PKG_SRC and
 462                  $to_type != CTRL_FILE_CHANGES)
 463         {
 464             $to->{$field} = $from->{$field};
 465             return $field;
 466         }
 467     } elsif (not field_is_allowed_in($field, $from_type)) {
 468         warning(_g("unknown information field '%s' in input data in %s"),
 469                 $field, $from->get_option("name") || _g("control information"));
 470     }
 471     return undef;
 472 }
 473
 474 =item field_transfer_all($from, $to)
 475
 476 Transfer all appropriate fields from $from to $to. Calls
 477 field_transfer_single() on all fields available in $from.
 478
 479 Returns the list of fields that have been added to $to.
 480
 481 =cut
 482
 483 sub field_transfer_all($$) {
 484     my ($from, $to) = @_;
 485     my (@res, $res);
 486     foreach my $k (keys %$from) {
 487         $res = field_transfer_single($from, $to, $k);
 488         push @res, $res if $res and defined wantarray;
 489     }
 490     return @res;
 491 }
 492
 493 =item field_ordered_list($type)
 494
 495 Returns an ordered list of fields for a given type of control information.
 496 This list can be used to output the fields in a predictable order.
 497 The list might be empty for types where the order does not matter much.
 498
 499 =cut
 500
 501 sub field_ordered_list($) {
 502     my ($type) = @_;
 503     return @{$FIELD_ORDER{$type}} if exists $FIELD_ORDER{$type};
 504     return ();
 505 }
 506
 507 =item field_list_src_dep()
 508
 509 List of fields that contains dependencies-like information in a source
 510 Debian package.
 511
 512 =cut
 513
 514 sub field_list_src_dep() {
 515     return sort {
 516         $FIELDS{$a}{'dep_order'} <=> $FIELDS{$b}{'dep_order'}
 517     } grep {
 518         field_is_allowed_in($_, CTRL_PKG_SRC) and
 519         exists $FIELDS{$_}{'dependency'}
 520     } keys %FIELDS;
 521 }
 522
 523 =item field_list_pkg_dep()
 524
 525 List of fields that contains dependencies-like information in a binary
 526 Debian package. The fields that express real dependencies are sorted from
 527 the stronger to the weaker.
 528
 529 =cut
 530
 531 sub field_list_pkg_dep() {
 532     my @keys = keys %FIELDS;
 533     return sort {
 534         $FIELDS{$a}{'dep_order'} <=> $FIELDS{$b}{'dep_order'}
 535     } grep {
 536         field_is_allowed_in($_, CTRL_PKG_DEB) and
 537         exists $FIELDS{$_}{'dependency'}
 538     } @keys;
 539 }
 540
 541 =item field_get_dep_type($field)
 542
 543 Return the type of the dependency expressed by the given field. Can
 544 either be "normal" for a real dependency field (Pre-Depends, Depends, ...)
 545 or "union" for other relation fields sharing the same syntax (Conflicts,
 546 Breaks, ...). Returns undef for fields which are not dependencies.
 547
 548 =cut
 549
 550 sub field_get_dep_type($) {
 551     my $field = field_capitalize($_[0]);
 552     return undef unless field_is_official($field);
 553     return $FIELDS{$field}{'dependency'} if exists $FIELDS{$field}{'dependency'};
 554     return undef;
 555 }
 556
 557 =item field_register($field, $allowed_types, %opts)
 558
 559 Register a new field as being allowed in control information of specified
 560 types. %opts is optional
 561
 562 =cut
 563
 564 sub field_register($$;@) {
 565     my ($field, $types, %opts) = @_;
 566     $field = field_capitalize($field);
 567     $FIELDS{$field} = {
 568         allowed => $types,
 569         %opts
 570     };
 571 }
 572
 573 =item field_insert_after($type, $ref, @fields)
 574
 575 Place field after another one ($ref) in output of control information of
 576 type $type.
 577
 578 =cut
 579 sub field_insert_after($$@) {
 580     my ($type, $field, @fields) = @_;
 581     return 0 if not exists $FIELD_ORDER{$type};
 582     ($field, @fields) = map { field_capitalize($_) } ($field, @fields);
 583     @{$FIELD_ORDER{$type}} = map {
 584         ($_ eq $field) ? ($_, @fields) : $_
 585     } @{$FIELD_ORDER{$type}};
 586     return 1;
 587 }
 588
 589 =item field_insert_before($type, $ref, @fields)
 590
 591 Place field before another one ($ref) in output of control information of
 592 type $type.
 593
 594 =cut
 595 sub field_insert_before($$@) {
 596     my ($type, $field, @fields) = @_;
 597     return 0 if not exists $FIELD_ORDER{$type};
 598     ($field, @fields) = map { field_capitalize($_) } ($field, @fields);
 599     @{$FIELD_ORDER{$type}} = map {
 600         ($_ eq $field) ? (@fields, $_) : $_
 601     } @{$FIELD_ORDER{$type}};
 602     return 1;
 603 }
 604
 605 =back
 606
 607 =head1 AUTHOR
 608
 609 Raphaël Hertzog <hertzog@debian.org>.
 610
 611 =cut
 612
 613 1;