diff options
Diffstat (limited to '')
| -rw-r--r-- | scripts/Dpkg/Control.pm | 269 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Changelog.pm | 65 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Fields.pm | 69 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/FieldsCore.pm | 971 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Hash.pm | 48 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/HashCore.pm | 559 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Info.pm | 227 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Tests.pm | 83 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Tests/Entry.pm | 94 | ||||
| -rw-r--r-- | scripts/Dpkg/Control/Types.pm | 102 |
10 files changed, 2487 insertions, 0 deletions
diff --git a/scripts/Dpkg/Control.pm b/scripts/Dpkg/Control.pm new file mode 100644 index 0000000..f41f250 --- /dev/null +++ b/scripts/Dpkg/Control.pm @@ -0,0 +1,269 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Control; + +use strict; +use warnings; + +our $VERSION = '1.03'; +our @EXPORT = qw( + CTRL_UNKNOWN + CTRL_INFO_SRC + CTRL_INFO_PKG + CTRL_INDEX_SRC + CTRL_INDEX_PKG + CTRL_REPO_RELEASE + 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); + +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Control::Types; +use Dpkg::Control::Hash; +use Dpkg::Control::Fields; + +use parent qw(Dpkg::Control::Hash); + +=encoding utf8 + +=head1 NAME + +Dpkg::Control - parse and manipulate official control-like information + +=head1 DESCRIPTION + +The Dpkg::Control object is a smart version of Dpkg::Control::Hash. +It associates a type to the control information. That type can be +used to know what fields are allowed and in what order they must be +output. + +The types are constants that are exported by default. Here's the full +list: + +=over 4 + +=item CTRL_UNKNOWN + +This type is the default type, it indicates that the type of control +information is not yet known. + +=item CTRL_INFO_SRC + +Corresponds to the first block of information in a F<debian/control> file in +a Debian source package. + +=item CTRL_INFO_PKG + +Corresponds to subsequent blocks of information in a F<debian/control> file +in a Debian source package. + +=item CTRL_REPO_RELEASE + +Corresponds to a F<Release> file in a repository. + +=item CTRL_INDEX_SRC + +Corresponds to an entry in a F<Sources> file of a source package +repository. + +=item CTRL_INDEX_PKG + +Corresponds to an entry in a F<Packages> file of a binary package +repository. + +=item CTRL_PKG_SRC + +Corresponds to a .dsc file of a Debian source package. + +=item CTRL_PKG_DEB + +Corresponds to the F<control> file generated by dpkg-gencontrol +(F<DEBIAN/control>) and to the same file inside .deb packages. + +=item CTRL_FILE_BUILDINFO + +Corresponds to a .buildinfo file. + +=item CTRL_FILE_CHANGES + +Corresponds to a .changes file. + +=item CTRL_FILE_VENDOR + +Corresponds to a vendor file in $Dpkg::CONFDIR/origins/. + +=item CTRL_FILE_STATUS + +Corresponds to an entry in dpkg's F<status> file ($Dpkg::ADMINDIR/status). + +=item CTRL_CHANGELOG + +Corresponds to the output of dpkg-parsechangelog. + +=item CTRL_COPYRIGHT_HEADER + +Corresponds to the header control block in a F<debian/copyright> file in +machine readable format. + +=item CTRL_COPYRIGHT_FILES + +Corresponds to a files control block in a F<debian/copyright> file in +machine readable format. + +=item CTRL_COPYRIGHT_LICENSE + +Corresponds to a license control block in a F<debian/copyright> file in +machine readable format. + +=item CTRL_TESTS + +Corresponds to a package tests control file in F<debian/tests/control>. + +=back + +=head1 METHODS + +All the methods of Dpkg::Control::Hash are available. Those listed below +are either new or overridden with a different behaviour. + +=over 4 + +=item $c = Dpkg::Control->new(%opts) + +If the "type" option is given, it's used to setup default values +for other options. See set_options() for more details. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + + my $self = Dpkg::Control::Hash->new(); + bless $self, $class; + $self->set_options(%opts); + + return $self; +} + +=item $c->set_options(%opts) + +Changes the value of one or more options. If the "type" option is changed, +it is used first to define default values for others options. The option +"allow_pgp" is set to 1 for CTRL_PKG_SRC, CTRL_FILE_CHANGES and +CTRL_REPO_RELEASE and to 0 otherwise. The option "drop_empty" is set to 0 +for CTRL_INFO_PKG and CTRL_INFO_SRC and to 1 otherwise. The option "name" +is set to a textual description of the type of control information. + +The output order is also set to match the ordered list returned by +Dpkg::Control::Fields::field_ordered_list($type). + +=cut + +sub set_options { + my ($self, %opts) = @_; + if (exists $opts{type}) { + my $t = $opts{type}; + $$self->{allow_pgp} = ($t & (CTRL_PKG_SRC | CTRL_FILE_CHANGES | CTRL_REPO_RELEASE)) ? 1 : 0; + $$self->{drop_empty} = ($t & (CTRL_INFO_PKG | CTRL_INFO_SRC)) ? 0 : 1; + if ($t == CTRL_INFO_SRC) { + $$self->{name} = g_('general section of control info file'); + } elsif ($t == CTRL_INFO_PKG) { + $$self->{name} = g_("package's section of control info file"); + } elsif ($t == CTRL_CHANGELOG) { + $$self->{name} = g_('parsed version of changelog'); + } elsif ($t == CTRL_COPYRIGHT_HEADER) { + $$self->{name} = g_('header stanza of copyright file'); + } elsif ($t == CTRL_COPYRIGHT_FILES) { + $$self->{name} = g_('files stanza of copyright file'); + } elsif ($t == CTRL_COPYRIGHT_HEADER) { + $$self->{name} = g_('license stanza of copyright file'); + } elsif ($t == CTRL_TESTS) { + $$self->{name} = g_("package's tests control file"); + } elsif ($t == CTRL_REPO_RELEASE) { + $$self->{name} = sprintf(g_("repository's %s file"), 'Release'); + } elsif ($t == CTRL_INDEX_SRC) { + $$self->{name} = sprintf(g_("entry in repository's %s file"), 'Sources'); + } elsif ($t == CTRL_INDEX_PKG) { + $$self->{name} = sprintf(g_("entry in repository's %s file"), 'Packages'); + } elsif ($t == CTRL_PKG_SRC) { + $$self->{name} = sprintf(g_('%s file'), '.dsc'); + } elsif ($t == CTRL_PKG_DEB) { + $$self->{name} = g_('control info of a .deb package'); + } elsif ($t == CTRL_FILE_BUILDINFO) { + $$self->{name} = g_('build information file'); + } elsif ($t == CTRL_FILE_CHANGES) { + $$self->{name} = sprintf(g_('%s file'), '.changes'); + } elsif ($t == CTRL_FILE_VENDOR) { + $$self->{name} = g_('vendor file'); + } elsif ($t == CTRL_FILE_STATUS) { + $$self->{name} = g_("entry in dpkg's status file"); + } + $self->set_output_order(field_ordered_list($opts{type})); + } + + # Options set by the user override default values + $$self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $c->get_type() + +Returns the type of control information stored. See the type parameter +set during new(). + +=cut + +sub get_type { + my $self = shift; + return $$self->{type}; +} + +=back + +=head1 CHANGES + +=head2 Version 1.03 (dpkg 1.18.11) + +New type: CTRL_FILE_BUILDINFO. + +=head2 Version 1.02 (dpkg 1.18.8) + +New type: CTRL_TESTS. + +=head2 Version 1.01 (dpkg 1.18.5) + +New types: CTRL_REPO_RELEASE, CTRL_COPYRIGHT_HEADER, CTRL_COPYRIGHT_FILES, +CTRL_COPYRIGHT_LICENSE. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; diff --git a/scripts/Dpkg/Control/Changelog.pm b/scripts/Dpkg/Control/Changelog.pm new file mode 100644 index 0000000..1f65127 --- /dev/null +++ b/scripts/Dpkg/Control/Changelog.pm @@ -0,0 +1,65 @@ +# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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 object 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 <hertzog@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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..f460433 --- /dev/null +++ b/scripts/Dpkg/Control/FieldsCore.pm @@ -0,0 +1,971 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Control::FieldsCore; + +use strict; +use warnings; + +our $VERSION = '1.00'; +our @EXPORT = qw( + field_capitalize + field_is_official + field_is_allowed_in + field_transfer_single + field_transfer_all + 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_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 = ( + 'architecture' => { + name => 'Architecture', + allowed => (ALL_PKG | ALL_SRC | CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES) & (~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 | CTRL_FILE_BUILDINFO | CTRL_FILE_CHANGES, + # 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, + }, + '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 | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, + }, + 'checksums-sha1' => { + name => 'Checksums-Sha1', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, + }, + 'checksums-sha256' => { + name => 'Checksums-Sha256', + allowed => CTRL_PKG_SRC | CTRL_INDEX_SRC | CTRL_FILE_CHANGES | CTRL_FILE_BUILDINFO, + }, + '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 | CTRL_FILE_CHANGES | CTRL_COPYRIGHT_HEADER | CTRL_FILE_BUILDINFO, + }, + '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 => 11, + }, + '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, + }, + '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, + }, + '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, + }, + '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_INFO_SRC | CTRL_INFO_PKG)), + }, +); + +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); +my @src_checksums_fields = qw(checksums-md5 checksums-sha1 checksums-sha256); +my @bin_checksums_fields = qw(md5sum sha1 sha256); + +our %FIELD_ORDER = ( + CTRL_PKG_DEB() => [ + qw(package package-type source version built-using kernel-version + built-for-profiles auto-built-package architecture subarchitecture + installer-menu-item build-essential essential origin bugs + maintainer installed-size), @bin_dep_fields, + qw(section priority multi-arch homepage description tag task) + ], + CTRL_INDEX_PKG() => [ + qw(package package-type source version built-using kernel-version + built-for-profiles auto-built-package architecture subarchitecture + installer-menu-item build-essential essential origin bugs + maintainer installed-size), @bin_dep_fields, + qw(filename size), @bin_checksums_fields, + qw(section priority multi-arch homepage description tag task) + ], + CTRL_PKG_SRC() => [ + qw(format source binary architecture version origin maintainer + uploaders homepage description standards-version vcs-browser + vcs-arch vcs-bzr vcs-cvs vcs-darcs vcs-git vcs-hg vcs-mtn + vcs-svn testsuite testsuite-triggers), @src_dep_fields, + qw(package-list), @src_checksums_fields, qw(files) + ], + CTRL_INDEX_SRC() => [ + qw(format package binary architecture version priority section origin + maintainer uploaders homepage description standards-version vcs-browser + vcs-arch vcs-bzr vcs-cvs vcs-darcs vcs-git vcs-hg vcs-mtn vcs-svn + testsuite testsuite-triggers), @src_dep_fields, + qw(package-list directory), @src_checksums_fields, qw(files) + ], + 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_CHANGELOG() => [ + qw(source binary-only version distribution urgency maintainer + timestamp date closes changes) + ], + CTRL_FILE_STATUS() => [ + # Same as fieldinfos in lib/dpkg/parse.c + qw(package essential 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 + homepage installer-menu-item kernel-version package-type + subarchitecture tag task) + ], + CTRL_REPO_RELEASE() => [ + qw(origin label suite codename changelogs date valid-until + architectures components description), @bin_checksums_fields + ], + 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) + ], +); + +=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 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 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 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_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_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 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_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 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 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 + }; +} + +=item field_insert_after($type, $ref, @fields) + +Place field after another one ($ref) in output of control information of +type $type. + +=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 field_insert_before($type, $ref, @fields) + +Place field before another one ($ref) in output of control information of +type $type. + +=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.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..607ad2f --- /dev/null +++ b/scripts/Dpkg/Control/Hash.pm @@ -0,0 +1,48 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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 block of RFC822-like 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..5420693 --- /dev/null +++ b/scripts/Dpkg/Control/HashCore.pm @@ -0,0 +1,559 @@ +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2012-2015 Guillem Jover <guillem@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Control::HashCore; + +use strict; +use warnings; + +our $VERSION = '1.01'; + +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 block of RFC822-like fields + +=head1 DESCRIPTION + +The Dpkg::Control::Hash object 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. 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, + 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); + } + } + $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 gnupg. + $$self->{is_pgp_signed} = 1; + } + last; # Finished parsing one block + } 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*$//; + } + } + $v =~ s/\$\{\}/\$/g; # XXX: what for? + + $self->{$f} = $v; + } +} + +package Dpkg::Control::HashCore::Tie; + +# This object 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.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..9b07eed --- /dev/null +++ b/scripts/Dpkg/Control/Info.pm @@ -0,0 +1,227 @@ +# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2009, 2012-2015 Guillem Jover <guillem@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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 an object to access data of files that follow the same +syntax as F<debian/control>. + +=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<debian/control>. +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 block lacks a Source field')); + } + 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_("block lacks the '%s' field"), + 'Package'); + } + unless (exists $cdata->{Architecture}) { + $cdata->parse_error($desc, g_("block 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..439eee8 --- /dev/null +++ b/scripts/Dpkg/Control/Tests.pm @@ -0,0 +1,83 @@ +# Copyright © 2016 Guillem Jover <guillem@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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 an object to access data of files that follow the same +syntax as F<debian/tests/control>. + +=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..92eea49 --- /dev/null +++ b/scripts/Dpkg/Control/Tests/Entry.pm @@ -0,0 +1,94 @@ +# Copyright © 2016 Guillem Jover <guillem@debian.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 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 <https://www.gnu.org/licenses/>. + +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 object 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_('block 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..5d9496a --- /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 <https://www.gnu.org/licenses/>. + +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 block in debian/control. + CTRL_INFO_SRC => 1, + # Subsequent control blocks in debian/control. + CTRL_INFO_PKG => 2, + # Entry in repository's Sources files. + CTRL_INDEX_SRC => 4, + # Entry in repository's Packages files. + CTRL_INDEX_PKG => 8, + # .dsc file of source package. + CTRL_PKG_SRC => 16, + # DEBIAN/control in binary packages. + CTRL_PKG_DEB => 32, + # .changes file. + CTRL_FILE_CHANGES => 64, + # File in $Dpkg::CONFDIR/origins. + CTRL_FILE_VENDOR => 128, + # $Dpkg::ADMINDIR/status. + CTRL_FILE_STATUS => 256, + # Output of dpkg-parsechangelog. + CTRL_CHANGELOG => 512, + # Repository's (In)Release file. + CTRL_REPO_RELEASE => 1024, + # Header control block in debian/copyright. + CTRL_COPYRIGHT_HEADER => 2048, + # Files control block in debian/copyright. + CTRL_COPYRIGHT_FILES => 4096, + # License control block in debian/copyright. + CTRL_COPYRIGHT_LICENSE => 8192, + # Package test suite control file in debian/tests/control. + CTRL_TESTS => 16384, + # .buildinfo file + CTRL_FILE_BUILDINFO => 32768, +}; + +=head1 CHANGES + +=head2 Version 0.xx + +This is a private module. + +=cut + +1; |