From cbffab246997fb5a06211dfb706b54e5ae5bb59f Mon Sep 17 00:00:00 2001 From: Daniel Baumann Date: Sun, 7 Apr 2024 16:58:51 +0200 Subject: Adding upstream version 1.21.22. Signed-off-by: Daniel Baumann --- scripts/Dpkg/Control/Changelog.pm | 65 ++ scripts/Dpkg/Control/Fields.pm | 69 ++ scripts/Dpkg/Control/FieldsCore.pm | 1377 +++++++++++++++++++++++++++++++++++ scripts/Dpkg/Control/Hash.pm | 48 ++ scripts/Dpkg/Control/HashCore.pm | 589 +++++++++++++++ scripts/Dpkg/Control/Info.pm | 227 ++++++ scripts/Dpkg/Control/Tests.pm | 83 +++ scripts/Dpkg/Control/Tests/Entry.pm | 94 +++ scripts/Dpkg/Control/Types.pm | 102 +++ 9 files changed, 2654 insertions(+) create mode 100644 scripts/Dpkg/Control/Changelog.pm create mode 100644 scripts/Dpkg/Control/Fields.pm create mode 100644 scripts/Dpkg/Control/FieldsCore.pm create mode 100644 scripts/Dpkg/Control/Hash.pm create mode 100644 scripts/Dpkg/Control/HashCore.pm create mode 100644 scripts/Dpkg/Control/Info.pm create mode 100644 scripts/Dpkg/Control/Tests.pm create mode 100644 scripts/Dpkg/Control/Tests/Entry.pm create mode 100644 scripts/Dpkg/Control/Types.pm (limited to 'scripts/Dpkg/Control') diff --git a/scripts/Dpkg/Control/Changelog.pm b/scripts/Dpkg/Control/Changelog.pm new file mode 100644 index 0000000..9184ced --- /dev/null +++ b/scripts/Dpkg/Control/Changelog.pm @@ -0,0 +1,65 @@ +# Copyright © 2009 Raphaël Hertzog + +# 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 2 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 . + +package Dpkg::Control::Changelog; + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use Dpkg::Control; + +use parent qw(Dpkg::Control); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog + +=head1 DESCRIPTION + +This class derives directly from Dpkg::Control with the type +CTRL_CHANGELOG. + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Changelog->new() + +Create a new empty set of changelog related fields. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = Dpkg::Control->new(type => CTRL_CHANGELOG, @_); + return bless $self, $class; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Fields.pm b/scripts/Dpkg/Control/Fields.pm new file mode 100644 index 0000000..33beeec --- /dev/null +++ b/scripts/Dpkg/Control/Fields.pm @@ -0,0 +1,69 @@ +# Copyright © 2007-2009 Raphaël Hertzog +# +# 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 2 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 . + +package Dpkg::Control::Fields; + +use strict; +use warnings; + +our $VERSION = '1.00'; +our @EXPORT = @Dpkg::Control::FieldsCore::EXPORT; + +use Carp; +use Exporter qw(import); + +use Dpkg::Control::FieldsCore; +use Dpkg::Vendor qw(run_vendor_hook); + +# Register vendor specifics fields +foreach my $op (run_vendor_hook('register-custom-fields')) { + next if not (defined $op and ref $op); # Skip when not implemented by vendor + my $func = shift @$op; + if ($func eq 'register') { + my ($field, $allowed_type, @opts) = @{$op}; + field_register($field, $allowed_type, @opts); + } elsif ($func eq 'insert_before') { + my ($type, $ref, @fields) = @{$op}; + field_insert_before($type, $ref, @fields); + } elsif ($func eq 'insert_after') { + my ($type, $ref, @fields) = @{$op}; + field_insert_after($type, $ref, @fields); + } else { + croak "vendor hook register-custom-fields sent bad data: @$op"; + } +} + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Fields - manage (list of official) control fields + +=head1 DESCRIPTION + +The module contains a list of vendor-neutral and vendor-specific fieldnames +with associated meta-data explaining in which type of control information +they are allowed. The vendor-neutral fieldnames and all functions are +inherited from Dpkg::Control::FieldsCore. + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/FieldsCore.pm b/scripts/Dpkg/Control/FieldsCore.pm new file mode 100644 index 0000000..77216c7 --- /dev/null +++ b/scripts/Dpkg/Control/FieldsCore.pm @@ -0,0 +1,1377 @@ +# Copyright © 2007-2009 Raphaël Hertzog +# +# 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 2 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 . + +package Dpkg::Control::FieldsCore; + +use strict; +use warnings; + +our $VERSION = '1.01'; +our @EXPORT = qw( + field_capitalize + field_is_official + field_is_allowed_in + field_transfer_single + field_transfer_all + field_parse_binary_source + field_list_src_dep + field_list_pkg_dep + field_get_dep_type + field_get_sep_type + field_ordered_list + field_register + field_insert_after + field_insert_before + FIELD_SEP_UNKNOWN + FIELD_SEP_SPACE + FIELD_SEP_COMMA + FIELD_SEP_LINE +); + +use Exporter qw(import); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Types; + +use constant { + ALL_PKG => CTRL_INFO_PKG | CTRL_INDEX_PKG | CTRL_PKG_DEB | CTRL_FILE_STATUS, + ALL_SRC => CTRL_INFO_SRC | CTRL_INDEX_SRC | CTRL_PKG_SRC, + ALL_FILE_MANIFEST => CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES, + ALL_CHANGES => CTRL_FILE_CHANGES | CTRL_CHANGELOG, + ALL_COPYRIGHT => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES | CTRL_COPYRIGHT_LICENSE, +}; + +use constant { + FIELD_SEP_UNKNOWN => 0, + FIELD_SEP_SPACE => 1, + FIELD_SEP_COMMA => 2, + FIELD_SEP_LINE => 4, +}; + +# The canonical list of fields. + +# Note that fields used only in dpkg's available file are not listed. +# Deprecated fields of dpkg's status file are also not listed. +our %FIELDS = ( + 'acquire-by-hash' => { + name => 'Acquire-By-Hash', + allowed => CTRL_REPO_RELEASE, + }, + 'architecture' => { + name => 'Architecture', + allowed => (ALL_PKG | ALL_SRC | ALL_FILE_MANIFEST | CTRL_TESTS) & (~CTRL_INFO_SRC), + separator => FIELD_SEP_SPACE, + }, + 'architectures' => { + name => 'Architectures', + allowed => CTRL_REPO_RELEASE, + separator => FIELD_SEP_SPACE, + }, + 'auto-built-package' => { + name => 'Auto-Built-Package', + allowed => ALL_PKG & ~CTRL_INFO_PKG, + separator => FIELD_SEP_SPACE, + }, + 'binary' => { + name => 'Binary', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST, + # XXX: This field values are separated either by space or comma + # depending on the context. + separator => FIELD_SEP_SPACE | FIELD_SEP_COMMA, + }, + 'binary-only' => { + name => 'Binary-Only', + allowed => ALL_CHANGES, + }, + 'binary-only-changes' => { + name => 'Binary-Only-Changes', + allowed => CTRL_FILE_BUILDINFO, + }, + 'breaks' => { + name => 'Breaks', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 7, + }, + 'bugs' => { + name => 'Bugs', + allowed => (ALL_PKG | CTRL_INFO_SRC | CTRL_FILE_VENDOR) & (~CTRL_INFO_PKG), + }, + 'build-architecture' => { + name => 'Build-Architecture', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-conflicts' => { + name => 'Build-Conflicts', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 4, + }, + 'build-conflicts-arch' => { + name => 'Build-Conflicts-Arch', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 5, + }, + 'build-conflicts-indep' => { + name => 'Build-Conflicts-Indep', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 6, + }, + 'build-date' => { + name => 'Build-Date', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-depends' => { + name => 'Build-Depends', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 1, + }, + 'build-depends-arch' => { + name => 'Build-Depends-Arch', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 2, + }, + 'build-depends-indep' => { + name => 'Build-Depends-Indep', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 3, + }, + 'build-essential' => { + name => 'Build-Essential', + allowed => ALL_PKG, + }, + 'build-kernel-version' => { + name => 'Build-Kernel-Version', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-origin' => { + name => 'Build-Origin', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-path' => { + name => 'Build-Path', + allowed => CTRL_FILE_BUILDINFO, + }, + 'build-profiles' => { + name => 'Build-Profiles', + allowed => CTRL_INFO_PKG, + separator => FIELD_SEP_SPACE, + }, + 'build-tainted-by' => { + name => 'Build-Tainted-By', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_SPACE, + }, + 'built-for-profiles' => { + name => 'Built-For-Profiles', + allowed => ALL_PKG | CTRL_FILE_CHANGES, + separator => FIELD_SEP_SPACE, + }, + 'built-using' => { + name => 'Built-Using', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 10, + }, + 'butautomaticupgrades' => { + name => 'ButAutomaticUpgrades', + allowed => CTRL_REPO_RELEASE, + }, + 'changed-by' => { + name => 'Changed-By', + allowed => CTRL_FILE_CHANGES, + }, + 'changelogs' => { + name => 'Changelogs', + allowed => CTRL_REPO_RELEASE, + }, + 'changes' => { + name => 'Changes', + allowed => ALL_CHANGES, + }, + 'checksums-md5' => { + name => 'Checksums-Md5', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST, + }, + 'checksums-sha1' => { + name => 'Checksums-Sha1', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST, + }, + 'checksums-sha256' => { + name => 'Checksums-Sha256', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST, + }, + 'classes' => { + name => 'Classes', + allowed => CTRL_TESTS, + separator => FIELD_SEP_COMMA, + }, + 'closes' => { + name => 'Closes', + allowed => ALL_CHANGES, + separator => FIELD_SEP_SPACE, + }, + 'codename' => { + name => 'Codename', + allowed => CTRL_REPO_RELEASE, + }, + 'comment' => { + name => 'Comment', + allowed => ALL_COPYRIGHT, + }, + 'components' => { + name => 'Components', + allowed => CTRL_REPO_RELEASE, + separator => FIELD_SEP_SPACE, + }, + 'conffiles' => { + name => 'Conffiles', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'config-version' => { + name => 'Config-Version', + allowed => CTRL_FILE_STATUS, + }, + 'conflicts' => { + name => 'Conflicts', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 6, + }, + 'copyright' => { + name => 'Copyright', + allowed => CTRL_COPYRIGHT_HEADER | CTRL_COPYRIGHT_FILES, + }, + 'date' => { + name => 'Date', + allowed => ALL_CHANGES | CTRL_REPO_RELEASE, + }, + 'depends' => { + name => 'Depends', + allowed => ALL_PKG | CTRL_TESTS, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 2, + }, + 'description' => { + name => 'Description', + allowed => ALL_SRC | ALL_PKG | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE, + }, + 'disclaimer' => { + name => 'Disclaimer', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'directory' => { + name => 'Directory', + allowed => CTRL_INDEX_SRC, + }, + 'distribution' => { + name => 'Distribution', + allowed => ALL_CHANGES, + }, + 'enhances' => { + name => 'Enhances', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 5, + }, + 'environment' => { + name => 'Environment', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_LINE, + }, + 'essential' => { + name => 'Essential', + allowed => ALL_PKG, + }, + 'features' => { + name => 'Features', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'filename' => { + name => 'Filename', + allowed => CTRL_INDEX_PKG, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'files' => { + name => 'Files', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_FILES, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'format' => { + name => 'Format', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | ALL_FILE_MANIFEST | CTRL_COPYRIGHT_HEADER, + }, + 'homepage' => { + name => 'Homepage', + allowed => ALL_SRC | ALL_PKG, + }, + 'installed-build-depends' => { + name => 'Installed-Build-Depends', + allowed => CTRL_FILE_BUILDINFO, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 12, + }, + 'installed-size' => { + name => 'Installed-Size', + allowed => ALL_PKG & ~CTRL_INFO_PKG, + }, + 'installer-menu-item' => { + name => 'Installer-Menu-Item', + allowed => ALL_PKG, + }, + 'kernel-version' => { + name => 'Kernel-Version', + allowed => ALL_PKG, + }, + 'label' => { + name => 'Label', + allowed => CTRL_REPO_RELEASE, + }, + 'license' => { + name => 'License', + allowed => ALL_COPYRIGHT, + }, + 'origin' => { + name => 'Origin', + allowed => (ALL_PKG | ALL_SRC | CTRL_REPO_RELEASE) & (~CTRL_INFO_PKG), + }, + 'maintainer' => { + name => 'Maintainer', + allowed => CTRL_PKG_DEB | CTRL_INDEX_PKG | CTRL_FILE_STATUS | ALL_SRC | ALL_CHANGES, + }, + 'md5sum' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'MD5sum', + allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'multi-arch' => { + name => 'Multi-Arch', + allowed => ALL_PKG, + }, + 'no-support-for-architecture-all' => { + name => 'No-Support-for-Architecture-all', + allowed => CTRL_REPO_RELEASE, + }, + 'notautomatic' => { + name => 'NotAutomatic', + allowed => CTRL_REPO_RELEASE, + }, + 'package' => { + name => 'Package', + allowed => ALL_PKG | CTRL_INDEX_SRC, + }, + 'package-list' => { + name => 'Package-List', + allowed => ALL_SRC & ~CTRL_INFO_SRC, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'package-type' => { + name => 'Package-Type', + allowed => ALL_PKG, + }, + 'parent' => { + name => 'Parent', + allowed => CTRL_FILE_VENDOR, + }, + 'pre-depends' => { + name => 'Pre-Depends', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 1, + }, + 'priority' => { + name => 'Priority', + allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG, + }, + 'protected' => { + name => 'Protected', + allowed => ALL_PKG, + }, + 'provides' => { + name => 'Provides', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 9, + }, + 'recommends' => { + name => 'Recommends', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 3, + }, + 'replaces' => { + name => 'Replaces', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 8, + }, + 'restrictions' => { + name => 'Restrictions', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'rules-requires-root' => { + name => 'Rules-Requires-Root', + allowed => CTRL_INFO_SRC, + separator => FIELD_SEP_SPACE, + }, + 'section' => { + name => 'Section', + allowed => CTRL_INFO_SRC | CTRL_INDEX_SRC | ALL_PKG, + }, + 'sha1' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'SHA1', + allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'sha256' => { + # XXX: Wrong capitalization due to historical reasons. + name => 'SHA256', + allowed => CTRL_INDEX_PKG | CTRL_REPO_RELEASE, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'size' => { + name => 'Size', + allowed => CTRL_INDEX_PKG, + separator => FIELD_SEP_LINE | FIELD_SEP_SPACE, + }, + 'source' => { + name => 'Source', + allowed => (ALL_PKG | ALL_SRC | ALL_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO) & + (~(CTRL_INDEX_SRC | CTRL_INFO_PKG)), + }, + 'standards-version' => { + name => 'Standards-Version', + allowed => ALL_SRC, + }, + 'static-built-using' => { + name => 'Static-Built-Using', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'union', + dep_order => 11, + }, + 'status' => { + name => 'Status', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'subarchitecture' => { + name => 'Subarchitecture', + allowed => ALL_PKG, + }, + 'suite' => { + name => 'Suite', + allowed => CTRL_REPO_RELEASE, + }, + 'suggests' => { + name => 'Suggests', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + dependency => 'normal', + dep_order => 4, + }, + 'tag' => { + name => 'Tag', + allowed => ALL_PKG, + separator => FIELD_SEP_COMMA, + }, + 'task' => { + name => 'Task', + allowed => ALL_PKG, + }, + 'test-command' => { + name => 'Test-Command', + allowed => CTRL_TESTS, + }, + 'tests' => { + name => 'Tests', + allowed => CTRL_TESTS, + separator => FIELD_SEP_SPACE, + }, + 'tests-directory' => { + name => 'Tests-Directory', + allowed => CTRL_TESTS, + }, + 'testsuite' => { + name => 'Testsuite', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'testsuite-triggers' => { + name => 'Testsuite-Triggers', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'timestamp' => { + name => 'Timestamp', + allowed => CTRL_CHANGELOG, + }, + 'triggers-awaited' => { + name => 'Triggers-Awaited', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'triggers-pending' => { + name => 'Triggers-Pending', + allowed => CTRL_FILE_STATUS, + separator => FIELD_SEP_SPACE, + }, + 'uploaders' => { + name => 'Uploaders', + allowed => ALL_SRC, + separator => FIELD_SEP_COMMA, + }, + 'upstream-name' => { + name => 'Upstream-Name', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'upstream-contact' => { + name => 'Upstream-Contact', + allowed => CTRL_COPYRIGHT_HEADER, + }, + 'urgency' => { + name => 'Urgency', + allowed => ALL_CHANGES, + }, + 'valid-until' => { + name => 'Valid-Until', + allowed => CTRL_REPO_RELEASE, + }, + 'vcs-browser' => { + name => 'Vcs-Browser', + allowed => ALL_SRC, + }, + 'vcs-arch' => { + name => 'Vcs-Arch', + allowed => ALL_SRC, + }, + 'vcs-bzr' => { + name => 'Vcs-Bzr', + allowed => ALL_SRC, + }, + 'vcs-cvs' => { + name => 'Vcs-Cvs', + allowed => ALL_SRC, + }, + 'vcs-darcs' => { + name => 'Vcs-Darcs', + allowed => ALL_SRC, + }, + 'vcs-git' => { + name => 'Vcs-Git', + allowed => ALL_SRC, + }, + 'vcs-hg' => { + name => 'Vcs-Hg', + allowed => ALL_SRC, + }, + 'vcs-mtn' => { + name => 'Vcs-Mtn', + allowed => ALL_SRC, + }, + 'vcs-svn' => { + name => 'Vcs-Svn', + allowed => ALL_SRC, + }, + 'vendor' => { + name => 'Vendor', + allowed => CTRL_FILE_VENDOR, + }, + 'vendor-url' => { + name => 'Vendor-Url', + allowed => CTRL_FILE_VENDOR, + }, + 'version' => { + name => 'Version', + allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | ALL_CHANGES | CTRL_REPO_RELEASE) & + (~(CTRL_INFO_SRC | CTRL_INFO_PKG)), + }, +); + +my @src_vcs_fields = qw( + vcs-browser + vcs-arch + vcs-bzr + vcs-cvs + vcs-darcs + vcs-git + vcs-hg + vcs-mtn + vcs-svn +); + +my @src_dep_fields = qw( + build-depends + build-depends-arch + build-depends-indep + build-conflicts + build-conflicts-arch + build-conflicts-indep +); +my @bin_dep_fields = qw( + pre-depends + depends + recommends + suggests + enhances + conflicts + breaks + replaces + provides + built-using + static-built-using +); + +my @src_test_fields = qw( + testsuite + testsuite-triggers +); + +my @src_checksums_fields = qw( + checksums-md5 + checksums-sha1 + checksums-sha256 +); +my @bin_checksums_fields = qw( + md5sum + sha1 + sha256 +); + +our %FIELD_ORDER = ( + CTRL_INFO_SRC() => [ + qw( + source + section + priority + maintainer + uploaders + origin + bugs + ), + @src_vcs_fields, + qw( + homepage + standards-version + rules-requires-root + ), + @src_dep_fields, + @src_test_fields, + qw( + description + ), + ], + CTRL_INFO_PKG() => [ + qw( + package + package-type + section + priority + architecture + subarchitecture + multi-arch + essential + protected + build-essential + build-profiles + built-for-profiles + kernel-version + ), + @bin_dep_fields, + qw( + homepage + installer-menu-item + task + tag + description + ), + ], + CTRL_PKG_SRC() => [ + qw( + format + source + binary + architecture + version + origin + maintainer + uploaders + homepage + description + standards-version + ), + @src_vcs_fields, + @src_test_fields, + @src_dep_fields, + qw( + package-list + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_PKG_DEB() => [ + qw( + package + package-type + source + version + kernel-version + built-for-profiles + auto-built-package + architecture + subarchitecture + installer-menu-item + build-essential + essential + protected + origin + bugs + maintainer + installed-size + ), + @bin_dep_fields, + qw( + section + priority + multi-arch + homepage + description + tag + task + ), + ], + CTRL_INDEX_SRC() => [ + qw( + format + package + binary + architecture + version + priority + section + origin + maintainer + uploaders + homepage + description + standards-version + ), + @src_vcs_fields, + @src_test_fields, + @src_dep_fields, + qw( + package-list + directory + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_INDEX_PKG() => [ + qw( + package + package-type + source + version + kernel-version + built-for-profiles + auto-built-package + architecture + subarchitecture + installer-menu-item + build-essential + essential + protected + origin + bugs + maintainer + installed-size + ), + @bin_dep_fields, + qw( + filename + size + ), + @bin_checksums_fields, + qw( + section + priority + multi-arch + homepage + description + tag + task + ), + ], + CTRL_REPO_RELEASE() => [ + qw( + origin + label + suite + version + codename + changelogs + date + valid-until + notautomatic + butautomaticupgrades + acquire-by-hash + no-support-for-architecture-all + architectures + components + description + ), + @bin_checksums_fields + ], + CTRL_CHANGELOG() => [ + qw( + source + binary-only + version + distribution + urgency + maintainer + timestamp + date + closes + changes + ), + ], + CTRL_COPYRIGHT_HEADER() => [ + qw( + format + upstream-name + upstream-contact + source + disclaimer + comment + license + copyright + ), + ], + CTRL_COPYRIGHT_FILES() => [ + qw( + files + copyright + license + comment + ), + ], + CTRL_COPYRIGHT_LICENSE() => [ + qw( + license + comment + ), + ], + CTRL_FILE_BUILDINFO() => [ + qw( + format + source + binary + architecture + version + binary-only-changes + ), + @src_checksums_fields, + qw( + build-origin + build-architecture + build-kernel-version + build-date + build-path + build-tainted-by + installed-build-depends + environment + ), + ], + CTRL_FILE_CHANGES() => [ + qw( + format + date + source + binary + binary-only + built-for-profiles + architecture + version + distribution + urgency + maintainer + changed-by + description + closes + changes + ), + @src_checksums_fields, + qw( + files + ), + ], + CTRL_FILE_VENDOR() => [ + qw( + vendor + vendor-url + bugs + parent + ), + ], + CTRL_FILE_STATUS() => [ + # Same as fieldinfos in lib/dpkg/parse.c + qw( + package + essential + protected + status + priority + section + installed-size + origin + maintainer + bugs + architecture + multi-arch + source + version + config-version + replaces + provides + depends + pre-depends + recommends + suggests + breaks + conflicts + enhances + conffiles + description + triggers-pending + triggers-awaited + ), + # These are allowed here, but not tracked by lib/dpkg/parse.c. + qw( + auto-built-package + build-essential + built-for-profiles + built-using + static-built-using + homepage + installer-menu-item + kernel-version + package-type + subarchitecture + tag + task + ), + ], + CTRL_TESTS() => [ + qw( + test-command + tests + tests-directory + architecture + restrictions + features + classes + depends + ), + ], +); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::FieldsCore - manage (list of official) control fields + +=head1 DESCRIPTION + +The modules contains a list of fieldnames with associated meta-data explaining +in which type of control information they are allowed. The types are the +CTRL_* constants exported by Dpkg::Control. + +=head1 FUNCTIONS + +=over 4 + +=item $f = field_capitalize($field_name) + +Returns the field name properly capitalized. All characters are lowercase, +except the first of each word (words are separated by a hyphen in field names). + +=cut + +sub field_capitalize($) { + my $field = lc(shift); + + # Use known fields first. + return $FIELDS{$field}{name} if exists $FIELDS{$field}; + + # Generic case + return join '-', map { ucfirst } split /-/, $field; +} + +=item $bool = field_is_official($fname) + +Returns true if the field is official and known. + +=cut + +sub field_is_official($) { + my $field = lc shift; + + return exists $FIELDS{$field}; +} + +=item $bool = field_is_allowed_in($fname, @types) + +Returns true (1) if the field $fname is allowed in all the types listed in +the list. Note that you can use type sets instead of individual types (ex: +CTRL_FILE_CHANGES | CTRL_CHANGELOG). + +field_allowed_in(A|B, C) returns true only if the field is allowed in C +and either A or B. + +Undef is returned for non-official fields. + +=cut + +sub field_is_allowed_in($@) { + my ($field, @types) = @_; + $field = lc $field; + + return unless exists $FIELDS{$field}; + + return 0 if not scalar(@types); + foreach my $type (@types) { + next if $type == CTRL_UNKNOWN; # Always allowed + return 0 unless $FIELDS{$field}{allowed} & $type; + } + return 1; +} + +=item $new_field = field_transfer_single($from, $to, $field) + +If appropriate, copy the value of the field named $field taken from the +$from Dpkg::Control object to the $to Dpkg::Control object. + +Official fields are copied only if the field is allowed in both types of +objects. Custom fields are treated in a specific manner. When the target +is not among CTRL_PKG_SRC, CTRL_PKG_DEB or CTRL_FILE_CHANGES, then they +are always copied as is (the X- prefix is kept). Otherwise they are not +copied except if the target object matches the target destination encoded +in the field name. The initial X denoting custom fields can be followed by +one or more letters among "S" (Source: corresponds to CTRL_PKG_SRC), "B" +(Binary: corresponds to CTRL_PKG_DEB) or "C" (Changes: corresponds to +CTRL_FILE_CHANGES). + +Returns undef if nothing has been copied or the name of the new field +added to $to otherwise. + +=cut + +sub field_transfer_single($$;$) { + my ($from, $to, $field) = @_; + $field //= $_; + my ($from_type, $to_type) = ($from->get_type(), $to->get_type()); + $field = field_capitalize($field); + + if (field_is_allowed_in($field, $from_type, $to_type)) { + $to->{$field} = $from->{$field}; + return $field; + } elsif ($field =~ /^X([SBC]*)-/i) { + my $dest = $1; + if (($dest =~ /B/i and $to_type == CTRL_PKG_DEB) or + ($dest =~ /S/i and $to_type == CTRL_PKG_SRC) or + ($dest =~ /C/i and $to_type == CTRL_FILE_CHANGES)) + { + my $new = $field; + $new =~ s/^X([SBC]*)-//i; + $to->{$new} = $from->{$field}; + return $new; + } elsif ($to_type != CTRL_PKG_DEB and + $to_type != CTRL_PKG_SRC and + $to_type != CTRL_FILE_CHANGES) + { + $to->{$field} = $from->{$field}; + return $field; + } + } elsif (not field_is_allowed_in($field, $from_type)) { + warning(g_("unknown information field '%s' in input data in %s"), + $field, $from->get_option('name') || g_('control information')); + } + return; +} + +=item @field_list = field_transfer_all($from, $to) + +Transfer all appropriate fields from $from to $to. Calls +field_transfer_single() on all fields available in $from. + +Returns the list of fields that have been added to $to. + +=cut + +sub field_transfer_all($$) { + my ($from, $to) = @_; + my (@res, $res); + foreach my $k (keys %$from) { + $res = field_transfer_single($from, $to, $k); + push @res, $res if $res and defined wantarray; + } + return @res; +} + +=item @field_list = field_ordered_list($type) + +Returns an ordered list of fields for a given type of control information. +This list can be used to output the fields in a predictable order. +The list might be empty for types where the order does not matter much. + +=cut + +sub field_ordered_list($) { + my $type = shift; + + if (exists $FIELD_ORDER{$type}) { + return map { $FIELDS{$_}{name} } @{$FIELD_ORDER{$type}}; + } + return (); +} + +=item ($source, $version) = field_parse_binary_source($ctrl) + +Parse the B field in a binary package control stanza. The field +contains the source package name where it was built from, and optionally +a space and the source version enclosed in parenthesis if it is different +from the binary version. + +Returns a list with the $source name, and the source $version, or undef +or an empty list when $ctrl does not contain a binary package control stanza. +Neither $source nor $version are validated, but that can be done with +Dpkg::Package::pkg_name_is_illegal() and Dpkg::Version::version_check(). + +=cut + +sub field_parse_binary_source($) { + my $ctrl = shift; + my $ctrl_type = $ctrl->get_type(); + + if ($ctrl_type != CTRL_INDEX_PKG and + $ctrl_type != CTRL_PKG_DEB and + $ctrl_type != CTRL_FILE_CHANGES and + $ctrl_type != CTRL_FILE_BUILDINFO and + $ctrl_type != CTRL_FILE_STATUS) { + return; + } + + my ($source, $version); + + # For .changes and .buildinfo the Source field always exists, + # and there is no Package field. + if (exists $ctrl->{'Source'}) { + $source = $ctrl->{'Source'}; + if ($source =~ m/^([^ ]+) +\(([^)]*)\)$/) { + $source = $1; + $version = $2; + } else { + $version = $ctrl->{'Version'}; + } + } else { + $source = $ctrl->{'Package'}; + $version = $ctrl->{'Version'}; + } + + return ($source, $version); +} + +=item @field_list = field_list_src_dep() + +List of fields that contains dependencies-like information in a source +Debian package. + +=cut + +sub field_list_src_dep() { + my @list = map { + $FIELDS{$_}{name} + } sort { + $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} + } grep { + field_is_allowed_in($_, CTRL_PKG_SRC) and + exists $FIELDS{$_}{dependency} + } keys %FIELDS; + return @list; +} + +=item @field_list = field_list_pkg_dep() + +List of fields that contains dependencies-like information in a binary +Debian package. The fields that express real dependencies are sorted from +the stronger to the weaker. + +=cut + +sub field_list_pkg_dep() { + my @list = map { + $FIELDS{$_}{name} + } sort { + $FIELDS{$a}{dep_order} <=> $FIELDS{$b}{dep_order} + } grep { + field_is_allowed_in($_, CTRL_PKG_DEB) and + exists $FIELDS{$_}{dependency} + } keys %FIELDS; + return @list; +} + +=item $dep_type = field_get_dep_type($field) + +Return the type of the dependency expressed by the given field. Can +either be "normal" for a real dependency field (Pre-Depends, Depends, ...) +or "union" for other relation fields sharing the same syntax (Conflicts, +Breaks, ...). Returns undef for fields which are not dependencies. + +=cut + +sub field_get_dep_type($) { + my $field = lc shift; + + return unless exists $FIELDS{$field}; + return $FIELDS{$field}{dependency} if exists $FIELDS{$field}{dependency}; + return; +} + +=item $sep_type = field_get_sep_type($field) + +Return the type of the field value separator. Can be one of FIELD_SEP_UNKNOWN, +FIELD_SEP_SPACE, FIELD_SEP_COMMA or FIELD_SEP_LINE. + +=cut + +sub field_get_sep_type($) { + my $field = lc shift; + + return $FIELDS{$field}{separator} if exists $FIELDS{$field}{separator}; + return FIELD_SEP_UNKNOWN; +} + +=item field_register($field, $allowed_types, %opts) + +Register a new field as being allowed in control information of specified +types. %opts is optional. + +=cut + +sub field_register($$;@) { + my ($field, $types, %opts) = @_; + + $field = lc $field; + $FIELDS{$field} = { + name => field_capitalize($field), + allowed => $types, + %opts + }; + + return; +} + +=item $bool = field_insert_after($type, $ref, @fields) + +Place field after another one ($ref) in output of control information of +type $type. + +Return true if the field was inserted, otherwise false. + +=cut + +sub field_insert_after($$@) { + my ($type, $field, @fields) = @_; + + return 0 if not exists $FIELD_ORDER{$type}; + + ($field, @fields) = map { lc } ($field, @fields); + @{$FIELD_ORDER{$type}} = map { + ($_ eq $field) ? ($_, @fields) : $_ + } @{$FIELD_ORDER{$type}}; + + return 1; +} + +=item $bool = field_insert_before($type, $ref, @fields) + +Place field before another one ($ref) in output of control information of +type $type. + +Return true if the field was inserted, otherwise false. + +=cut + +sub field_insert_before($$@) { + my ($type, $field, @fields) = @_; + + return 0 if not exists $FIELD_ORDER{$type}; + + ($field, @fields) = map { lc } ($field, @fields); + @{$FIELD_ORDER{$type}} = map { + ($_ eq $field) ? (@fields, $_) : $_ + } @{$FIELD_ORDER{$type}}; + + return 1; +} + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.21.0) + +New function: field_parse_binary_source(). + +=head2 Version 1.00 (dpkg 1.17.0) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Hash.pm b/scripts/Dpkg/Control/Hash.pm new file mode 100644 index 0000000..8b7f54f --- /dev/null +++ b/scripts/Dpkg/Control/Hash.pm @@ -0,0 +1,48 @@ +# Copyright © 2007-2009 Raphaël Hertzog +# +# 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 2 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 . + +package Dpkg::Control::Hash; + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Fields; # Force execution of vendor hook. + +use parent qw(Dpkg::Control::HashCore); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Hash - parse and manipulate a stanza of deb822 fields + +=head1 DESCRIPTION + +This module is just like Dpkg::Control::HashCore, with vendor-specific +field knowledge. + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/HashCore.pm b/scripts/Dpkg/Control/HashCore.pm new file mode 100644 index 0000000..0bdb812 --- /dev/null +++ b/scripts/Dpkg/Control/HashCore.pm @@ -0,0 +1,589 @@ +# Copyright © 2007-2009 Raphaël Hertzog +# Copyright © 2009, 2012-2019, 2021 Guillem Jover +# +# 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 2 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 . + +package Dpkg::Control::HashCore; + +use strict; +use warnings; + +our $VERSION = '1.02'; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::FieldsCore; + +# This module cannot use Dpkg::Control::Fields, because that one makes use +# of Dpkg::Vendor which at the same time uses this module, which would turn +# into a compilation error. We can use Dpkg::Control::FieldsCore instead. + +use parent qw(Dpkg::Interface::Storable); + +use overload + '%{}' => sub { ${$_[0]}->{fields} }, + 'eq' => sub { "$_[0]" eq "$_[1]" }; + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::HashCore - parse and manipulate a stanza of deb822 fields + +=head1 DESCRIPTION + +The Dpkg::Control::Hash class is a hash-like representation of a set of +RFC822-like fields. The fields names are case insensitive and are always +capitalized the same when output (see field_capitalize function in +Dpkg::Control::Fields). +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 +overridden 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. + +During parsing, trailing spaces are stripped on all lines while leading +spaces are stripped only on the first line of each field. + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Hash->new(%opts) + +Creates a new object with the indicated options. Supported options +are: + +=over 8 + +=item allow_pgp + +Configures the parser to accept OpenPGP signatures around the control +information. Value can be 0 (default) or 1. + +=item allow_duplicate + +Configures the parser to allow duplicate fields in the control +information. +The last value overrides any previous values. +Value can be 0 (default) or 1. + +=item keep_duplicate + +Configure the parser to keep values for duplicate fields found in the control +information (when B is enabled), as array references. +Value can be 0 (default) or 1. + +=item drop_empty + +Defines if empty fields are dropped during the output. Value can be 0 +(default) or 1. + +=item name + +The user friendly name of the information stored in the object. It might +be used in some error messages or warnings. A default name might be set +depending on the type. + +=item is_pgp_signed + +Set by the parser (starting in dpkg 1.17.0) if it finds an OpenPGP +signature around the control information. Value can be 0 (default) +or 1, and undef when the option is not supported by the code (in +versions older than dpkg 1.17.0). + +=back + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + # Object is a scalar reference and not a hash ref to avoid + # infinite recursion due to overloading hash-dereferencing + my $self = \{ + in_order => [], + out_order => [], + is_pgp_signed => 0, + allow_pgp => 0, + allow_duplicate => 0, + keep_duplicate => 0, + drop_empty => 0, + }; + bless $self, $class; + + $$self->{fields} = Dpkg::Control::HashCore::Tie->new($self); + + # Options set by the user override default values + $$self->{$_} = $opts{$_} foreach keys %opts; + + return $self; +} + +# There is naturally a circular reference between the tied hash and its +# containing object. Happily, the extra layer of scalar reference can +# be used to detect the destruction of the object and break the loop so +# that everything gets garbage-collected. + +sub DESTROY { + my $self = shift; + delete $$self->{fields}; +} + +=item $c->set_options($option, %opts) + +Changes the value of one or more options. + +=cut + +sub set_options { + my ($self, %opts) = @_; + $$self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $value = $c->get_option($option) + +Returns the value of the corresponding option. + +=cut + +sub get_option { + my ($self, $k) = @_; + return $$self->{$k}; +} + +=item $c->parse_error($file, $fmt, ...) + +Prints an error message and dies on syntax parse errors. + +=cut + +sub parse_error { + my ($self, $file, $msg) = (shift, shift, shift); + + $msg = sprintf($msg, @_) if (@_); + error(g_('syntax error in %s at line %d: %s'), $file, $., $msg); +} + +=item $c->parse($fh, $description) + +Parse a control file from the given filehandle. Exits in case of errors. +$description is used to describe the filehandle, ideally it's a filename +or a description of where the data comes from. It's used in error +messages. When called multiple times, the parsed fields are accumulated. + +Returns true if some fields have been parsed. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + my $paraborder = 1; + my $parabody = 0; + my $cf; # Current field + my $expect_pgp_sig = 0; + local $_; + + while (<$fh>) { + # In the common case there will be just a trailing \n character, + # so using chomp here which is very fast will avoid the latter + # s/// doing anything, which gives usa significant speed up. + chomp; + my $armor = $_; + s/\s+$//; + + next if length == 0 and $paraborder; + + my $lead = substr $_, 0, 1; + next if $lead eq '#'; + $paraborder = 0; + + my ($name, $value) = split /\s*:\s*/, $_, 2; + if (defined $name and $name =~ m/^\S+?$/) { + $parabody = 1; + if ($lead eq '-') { + $self->parse_error($desc, g_('field cannot start with a hyphen')); + } + if (exists $self->{$name}) { + unless ($$self->{allow_duplicate}) { + $self->parse_error($desc, g_('duplicate field %s found'), $name); + } + if ($$self->{keep_duplicate}) { + if (ref $self->{$name} ne 'ARRAY') { + # Switch value into an array. + $self->{$name} = [ $self->{$name}, $value ]; + } else { + # Append the value. + push @{$self->{$name}}, $value; + } + } else { + # Overwrite with last value. + $self->{$name} = $value; + } + } else { + $self->{$name} = $value; + } + $cf = $name; + } elsif (m/^\s(\s*\S.*)$/) { + my $line = $1; + unless (defined($cf)) { + $self->parse_error($desc, g_('continued value line not in field')); + } + if ($line =~ /^\.+$/) { + $line = substr $line, 1; + } + $self->{$cf} .= "\n$line"; + } elsif (length == 0 || + ($expect_pgp_sig && $armor =~ m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) { + if ($expect_pgp_sig) { + # Skip empty lines + $_ = <$fh> while defined && m/^\s*$/; + unless (length) { + $self->parse_error($desc, g_('expected OpenPGP signature, ' . + 'found end of file after blank line')); + } + chomp; + unless (m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/) { + $self->parse_error($desc, g_('expected OpenPGP signature, ' . + "found something else '%s'"), $_); + } + # Skip OpenPGP signature + while (<$fh>) { + chomp; + last if m/^-----END PGP SIGNATURE-----[\r\t ]*$/; + } + unless (defined) { + $self->parse_error($desc, g_('unfinished OpenPGP signature')); + } + # This does not mean the signature is correct, that needs to + # be verified by an OpenPGP backend. + $$self->{is_pgp_signed} = 1; + } + # Finished parsing one stanza. + last; + } elsif ($armor =~ m/^-----BEGIN PGP SIGNED MESSAGE-----[\r\t ]*$/) { + $expect_pgp_sig = 1; + if ($$self->{allow_pgp} and not $parabody) { + # Skip OpenPGP headers + while (<$fh>) { + last if m/^\s*$/; + } + } else { + $self->parse_error($desc, g_('OpenPGP signature not allowed here')); + } + } else { + $self->parse_error($desc, + g_('line with unknown format (not field-colon-value)')); + } + } + + if ($expect_pgp_sig and not $$self->{is_pgp_signed}) { + $self->parse_error($desc, g_('unfinished OpenPGP signature')); + } + + return defined($cf); +} + +=item $c->load($file) + +Parse the content of $file. Exits in case of errors. Returns true if some +fields have been parsed. + +=item $c->find_custom_field($name) + +Scan the fields and look for a user specific field whose name matches the +following regex: /X[SBC]*-$name/i. Return the name of the field found or +undef if nothing has been found. + +=cut + +sub find_custom_field { + my ($self, $name) = @_; + foreach my $key (keys %$self) { + return $key if $key =~ /^X[SBC]*-\Q$name\E$/i; + } + return; +} + +=item $c->get_custom_field($name) + +Identify a user field and retrieve its value. + +=cut + +sub get_custom_field { + my ($self, $name) = @_; + my $key = $self->find_custom_field($name); + return $self->{$key} if defined $key; + return; +} + +=item $str = $c->output() + +=item "$c" + +Get a string representation of the control information. The fields +are sorted in the order in which they have been read or set except +if the order has been overridden with set_output_order(). + +=item $c->output($fh) + +Print the string representation of the control information to a +filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + my @keys; + if (@{$$self->{out_order}}) { + my $i = 1; + my $imp = {}; + $imp->{$_} = $i++ foreach @{$$self->{out_order}}; + @keys = sort { + if (defined $imp->{$a} && defined $imp->{$b}) { + $imp->{$a} <=> $imp->{$b}; + } elsif (defined($imp->{$a})) { + -1; + } elsif (defined($imp->{$b})) { + 1; + } else { + $a cmp $b; + } + } keys %$self; + } else { + @keys = @{$$self->{in_order}}; + } + + foreach my $key (@keys) { + if (exists $self->{$key}) { + my $value = $self->{$key}; + # Skip whitespace-only fields + next if $$self->{drop_empty} and $value !~ m/\S/; + # Escape data to follow control file syntax + my ($first_line, @lines) = split /\n/, $value; + + my $kv = "$key:"; + $kv .= ' ' . $first_line if length $first_line; + $kv .= "\n"; + foreach (@lines) { + s/\s+$//; + if (length == 0 or /^\.+$/) { + $kv .= " .$_\n"; + } else { + $kv .= " $_\n"; + } + } + # Print it out + if ($fh) { + print { $fh } $kv + or syserr(g_('write error on control data')); + } + $str .= $kv if defined wantarray; + } + } + return $str; +} + +=item $c->save($filename) + +Write the string representation of the control information to a file. + +=item $c->set_output_order(@fields) + +Define the order in which fields will be displayed in the output() method. + +=cut + +sub set_output_order { + my ($self, @fields) = @_; + + $$self->{out_order} = [@fields]; +} + +=item $c->apply_substvars($substvars) + +Update all fields by replacing the variables references with +the corresponding value stored in the Dpkg::Substvars object. + +=cut + +sub apply_substvars { + my ($self, $substvars, %opts) = @_; + + # Add substvars to refer to other fields + $substvars->set_field_substvars($self, 'F'); + + foreach my $f (keys %$self) { + my $v = $substvars->substvars($self->{$f}, %opts); + if ($v ne $self->{$f}) { + my $sep; + + $sep = field_get_sep_type($f); + + # If we replaced stuff, ensure we're not breaking + # a dependency field by introducing empty lines, or multiple + # commas + + if ($sep & (FIELD_SEP_COMMA | FIELD_SEP_LINE)) { + # Drop empty/whitespace-only lines + $v =~ s/\n[ \t]*(\n|$)/$1/; + } + + if ($sep & FIELD_SEP_COMMA) { + $v =~ s/,[\s,]*,/,/g; + $v =~ s/^\s*,\s*//; + $v =~ s/\s*,\s*$//; + } + } + # Replace ${} with $, which is otherwise an invalid substitution, but + # this then makes it possible to use ${} as an escape sequence such + # as ${}{VARIABLE}. + $v =~ s/\$\{\}/\$/g; + + $self->{$f} = $v; + } +} + +package Dpkg::Control::HashCore::Tie; + +# This class is used to tie a hash. It implements hash-like functions by +# normalizing the name of fields received in keys (using +# Dpkg::Control::Fields::field_capitalize). It also stores the order in +# which fields have been added in order to be able to dump them in the +# same order. But the order information is stored in a parent object of +# type Dpkg::Control. + +use strict; +use warnings; + +use Dpkg::Control::FieldsCore; + +use Carp; +use Tie::Hash; +use parent -norequire, qw(Tie::ExtraHash); + +# $self->[0] is the real hash +# $self->[1] is a reference to the hash contained by the parent object. +# This reference bypasses the top-level scalar reference of a +# Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed +# properly. + +# Dpkg::Control::Hash->new($parent) +# +# Return a reference to a tied hash implementing storage of simple +# "field: value" mapping as used in many Debian-specific files. + +sub new { + my $class = shift; + my $hash = {}; + tie %{$hash}, $class, @_; ## no critic (Miscellanea::ProhibitTies) + return $hash; +} + +sub TIEHASH { + my ($class, $parent) = @_; + croak 'parent object must be Dpkg::Control::Hash' + if not $parent->isa('Dpkg::Control::HashCore') and + not $parent->isa('Dpkg::Control::Hash'); + return bless [ {}, $$parent ], $class; +} + +sub FETCH { + my ($self, $key) = @_; + $key = lc($key); + return $self->[0]->{$key} if exists $self->[0]->{$key}; + return; +} + +sub STORE { + my ($self, $key, $value) = @_; + $key = lc($key); + if (not exists $self->[0]->{$key}) { + push @{$self->[1]->{in_order}}, field_capitalize($key); + } + $self->[0]->{$key} = $value; +} + +sub EXISTS { + my ($self, $key) = @_; + $key = lc($key); + return exists $self->[0]->{$key}; +} + +sub DELETE { + my ($self, $key) = @_; + my $parent = $self->[1]; + my $in_order = $parent->{in_order}; + $key = lc($key); + if (exists $self->[0]->{$key}) { + delete $self->[0]->{$key}; + @{$in_order} = grep { lc ne $key } @{$in_order}; + return 1; + } else { + return 0; + } +} + +sub FIRSTKEY { + my $self = shift; + my $parent = $self->[1]; + foreach my $key (@{$parent->{in_order}}) { + return $key if exists $self->[0]->{lc $key}; + } +} + +sub NEXTKEY { + my ($self, $last) = @_; + my $parent = $self->[1]; + my $found = 0; + foreach my $key (@{$parent->{in_order}}) { + if ($found) { + return $key if exists $self->[0]->{lc $key}; + } else { + $found = 1 if $key eq $last; + } + } + return; +} + +1; + +=back + +=head1 CHANGES + +=head2 Version 1.02 (dpkg 1.21.0) + +New option: "keep_duplicate" in new(). + +=head2 Version 1.01 (dpkg 1.17.2) + +New method: $c->parse_error(). + +=head2 Version 1.00 (dpkg 1.17.0) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Info.pm b/scripts/Dpkg/Control/Info.pm new file mode 100644 index 0000000..e4bc85e --- /dev/null +++ b/scripts/Dpkg/Control/Info.pm @@ -0,0 +1,227 @@ +# Copyright © 2007-2010 Raphaël Hertzog +# Copyright © 2009, 2012-2015 Guillem Jover +# +# 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 2 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 . + +package Dpkg::Control::Info; + +use strict; +use warnings; + +our $VERSION = '1.01'; + +use Dpkg::Control; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return [ $_[0]->{source}, @{$_[0]->{packages}} ] }; + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Info - parse files like debian/control + +=head1 DESCRIPTION + +It provides a class to access data of files that follow the same +syntax as F. + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Control::Info->new(%opts) + +Create a new Dpkg::Control::Info object. Loads the file from the filename +option, if no option is specified filename defaults to F. +If a scalar is passed instead, it will be used as the filename. If filename +is "-", it parses the standard input. If filename is undef no loading will +be performed. + +=cut + +sub new { + my ($this, @args) = @_; + my $class = ref($this) || $this; + my $self = { + source => undef, + packages => [], + }; + bless $self, $class; + + my %opts; + if (scalar @args == 0) { + $opts{filename} = 'debian/control'; + } elsif (scalar @args == 1) { + $opts{filename} = $args[0]; + } else { + %opts = @args; + } + + $self->load($opts{filename}) if $opts{filename}; + + return $self; +} + +=item $c->reset() + +Resets what got read. + +=cut + +sub reset { + my $self = shift; + $self->{source} = undef; + $self->{packages} = []; +} + +=item $c->parse($fh, $description) + +Parse a control file from the given filehandle. Exits in case of errors. +$description is used to describe the filehandle, ideally it's a filename +or a description of where the data comes from. It is used in error messages. +The data in the object is reset before parsing new control files. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + $self->reset(); + my $cdata = Dpkg::Control->new(type => CTRL_INFO_SRC); + return if not $cdata->parse($fh, $desc); + $self->{source} = $cdata; + unless (exists $cdata->{Source}) { + $cdata->parse_error($desc, g_("first stanza lacks a '%s' field"), + 'Source'); + } + while (1) { + $cdata = Dpkg::Control->new(type => CTRL_INFO_PKG); + last if not $cdata->parse($fh, $desc); + push @{$self->{packages}}, $cdata; + unless (exists $cdata->{Package}) { + $cdata->parse_error($desc, g_("stanza lacks the '%s' field"), + 'Package'); + } + unless (exists $cdata->{Architecture}) { + $cdata->parse_error($desc, g_("stanza lacks the '%s' field"), + 'Architecture'); + } + } +} + +=item $c->load($file) + +Load the content of $file. Exits in case of errors. If file is "-", it +loads from the standard input. + +=item $c->[0] + +=item $c->get_source() + +Returns a Dpkg::Control object containing the fields concerning the +source package. + +=cut + +sub get_source { + my $self = shift; + return $self->{source}; +} + +=item $c->get_pkg_by_idx($idx) + +Returns a Dpkg::Control object containing the fields concerning the binary +package numbered $idx (starting at 1). + +=cut + +sub get_pkg_by_idx { + my ($self, $idx) = @_; + return $self->{packages}[--$idx]; +} + +=item $c->get_pkg_by_name($name) + +Returns a Dpkg::Control object containing the fields concerning the binary +package named $name. + +=cut + +sub get_pkg_by_name { + my ($self, $name) = @_; + foreach my $pkg (@{$self->{packages}}) { + return $pkg if ($pkg->{Package} eq $name); + } + return; +} + + +=item $c->get_packages() + +Returns a list containing the Dpkg::Control objects for all binary packages. + +=cut + +sub get_packages { + my $self = shift; + return @{$self->{packages}}; +} + +=item $str = $c->output([$fh]) + +Return the content info into a string. If $fh is specified print it into +the filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str; + $str .= $self->{source}->output($fh); + foreach my $pkg (@{$self->{packages}}) { + print { $fh } "\n" if defined $fh; + $str .= "\n" . $pkg->output($fh); + } + return $str; +} + +=item "$c" + +Return a string representation of the content. + +=item @{$c} + +Return a list of Dpkg::Control objects, the first one is corresponding to +source information and the following ones are the binary packages +information. + +=back + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.18.0) + +New argument: The $c->new() constructor accepts an %opts argument. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Tests.pm b/scripts/Dpkg/Control/Tests.pm new file mode 100644 index 0000000..3c8d1c0 --- /dev/null +++ b/scripts/Dpkg/Control/Tests.pm @@ -0,0 +1,83 @@ +# Copyright © 2016 Guillem Jover +# +# 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 2 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 . + +package Dpkg::Control::Tests; + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use Dpkg::Control; +use Dpkg::Control::Tests::Entry; +use Dpkg::Index; + +use parent qw(Dpkg::Index); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Tests - parse files like debian/tests/control + +=head1 DESCRIPTION + +It provides a class to access data of files that follow the same +syntax as F. + +=head1 METHODS + +All the methods of Dpkg::Index are available. Those listed below are either +new or overridden with a different behavior. + +=over 4 + +=item $c = Dpkg::Control::Tests->new(%opts) + +Create a new Dpkg::Control::Tests object, which inherits from Dpkg::Index. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = Dpkg::Index->new(type => CTRL_TESTS, %opts); + + return bless $self, $class; +} + +=item $item = $tests->new_item() + +Creates a new item. + +=cut + +sub new_item { + my $self = shift; + + return Dpkg::Control::Tests::Entry->new(); +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.18.8) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Tests/Entry.pm b/scripts/Dpkg/Control/Tests/Entry.pm new file mode 100644 index 0000000..cbcd7e8 --- /dev/null +++ b/scripts/Dpkg/Control/Tests/Entry.pm @@ -0,0 +1,94 @@ +# Copyright © 2016 Guillem Jover +# +# 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 2 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 . + +package Dpkg::Control::Tests::Entry; + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control; + +use parent qw(Dpkg::Control); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Tests::Entry - represents a test suite entry + +=head1 DESCRIPTION + +This class represents a test suite entry. + +=head1 METHODS + +All the methods of Dpkg::Control are available. Those listed below are either +new or overridden with a different behavior. + +=over 4 + +=item $entry = Dpkg::Control::Tests::Entry->new() + +Creates a new object. It does not represent a real control test entry +until one has been successfully parsed or built from scratch. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = Dpkg::Control->new(type => CTRL_TESTS, %opts); + bless $self, $class; + return $self; +} + +=item $entry->parse($fh, $desc) + +Parse a control test entry from a filehandle. When called multiple times, +the parsed fields are accumulated. + +Returns true if parsing was a success. + +=cut + +sub parse { + my ($self, $fh, $desc) = @_; + + return if not $self->SUPER::parse($fh, $desc); + + if (not exists $self->{'Tests'} and not exists $self->{'Test-Command'}) { + $self->parse_error($desc, g_('stanza lacks either %s or %s fields'), + 'Tests', 'Test-Command'); + } + + return 1; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.18.8) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Types.pm b/scripts/Dpkg/Control/Types.pm new file mode 100644 index 0000000..8dd1aa1 --- /dev/null +++ b/scripts/Dpkg/Control/Types.pm @@ -0,0 +1,102 @@ +# 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 2 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 . + +package Dpkg::Control::Types; + +use strict; +use warnings; + +our $VERSION = '0.01'; +our @EXPORT = qw( + CTRL_UNKNOWN + CTRL_INFO_SRC + CTRL_INFO_PKG + CTRL_REPO_RELEASE + CTRL_INDEX_SRC + CTRL_INDEX_PKG + CTRL_PKG_SRC + CTRL_PKG_DEB + CTRL_FILE_BUILDINFO + CTRL_FILE_CHANGES + CTRL_FILE_VENDOR + CTRL_FILE_STATUS + CTRL_CHANGELOG + CTRL_COPYRIGHT_HEADER + CTRL_COPYRIGHT_FILES + CTRL_COPYRIGHT_LICENSE + CTRL_TESTS +); + +use Exporter qw(import); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control::Types - export CTRL_* constants + +=head1 DESCRIPTION + +You should not use this module directly. Instead you more likely +want to use Dpkg::Control which also re-exports the same constants. + +This module has been introduced solely to avoid a dependency loop +between Dpkg::Control and Dpkg::Control::Fields. + +=cut + +use constant { + CTRL_UNKNOWN => 0, + # First control stanza in debian/control. + CTRL_INFO_SRC => 1 << 0, + # Subsequent control stanza in debian/control. + CTRL_INFO_PKG => 1 << 1, + # Entry in repository's Sources files. + CTRL_INDEX_SRC => 1 << 2, + # Entry in repository's Packages files. + CTRL_INDEX_PKG => 1 << 3, + # .dsc file of source package. + CTRL_PKG_SRC => 1 << 4, + # DEBIAN/control in binary packages. + CTRL_PKG_DEB => 1 << 5, + # .changes file. + CTRL_FILE_CHANGES => 1 << 6, + # File in $Dpkg::CONFDIR/origins. + CTRL_FILE_VENDOR => 1 << 7, + # $Dpkg::ADMINDIR/status. + CTRL_FILE_STATUS => 1 << 8, + # Output of dpkg-parsechangelog. + CTRL_CHANGELOG => 1 << 9, + # Repository's (In)Release file. + CTRL_REPO_RELEASE => 1 << 10, + # Header control stanza in debian/copyright. + CTRL_COPYRIGHT_HEADER => 1 << 11, + # Files control stanza in debian/copyright. + CTRL_COPYRIGHT_FILES => 1 << 12, + # License control stanza in debian/copyright. + CTRL_COPYRIGHT_LICENSE => 1 << 13, + # Package test suite control file in debian/tests/control. + CTRL_TESTS => 1 << 14, + # .buildinfo file + CTRL_FILE_BUILDINFO => 1 << 15, +}; + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; -- cgit v1.2.3