scripts/Dpkg/Vendor.pm

   1 # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2008-2009, 2012-2017, 2022 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 =encoding utf8
  18
  19 =head1 NAME
  20
  21 Dpkg::Vendor - get access to some vendor specific information
  22
  23 =head1 DESCRIPTION
  24
  25 The files in $Dpkg::CONFDIR/origins/ can provide information about various
  26 vendors who are providing Debian packages. Currently those files look like
  27 this:
  28
  29   Vendor: Debian
  30   Vendor-URL: https://www.debian.org/
  31   Bugs: debbugs://bugs.debian.org
  32
  33 If the vendor derives from another vendor, the file should document
  34 the relationship by listing the base distribution in the Parent field:
  35
  36   Parent: Debian
  37
  38 The file should be named according to the vendor name. The usual convention
  39 is to name the vendor file using the vendor name in all lowercase, but some
  40 variation is permitted. Namely, spaces are mapped to dashes ('-'), and the
  41 file can have the same casing as the Vendor field, or it can be capitalized.
  42
  43 =cut
  44
  45 package Dpkg::Vendor 1.02;
  46
  47 use strict;
  48 use warnings;
  49 use feature qw(state);
  50
  51 our @EXPORT_OK = qw(
  52     get_current_vendor
  53     get_vendor_info
  54     get_vendor_file
  55     get_vendor_dir
  56     get_vendor_object
  57     run_vendor_hook
  58 );
  59
  60 use Exporter qw(import);
  61 use List::Util qw(uniq);
  62
  63 use Dpkg ();
  64 use Dpkg::ErrorHandling;
  65 use Dpkg::Gettext;
  66 use Dpkg::BuildEnv;
  67 use Dpkg::Control::HashCore;
  68
  69 my $origins = "$Dpkg::CONFDIR/origins";
  70 $origins = $ENV{DPKG_ORIGINS_DIR} if $ENV{DPKG_ORIGINS_DIR};
  71
  72 =head1 FUNCTIONS
  73
  74 =over 4
  75
  76 =item $dir = get_vendor_dir()
  77
  78 Returns the current dpkg origins directory name, where the vendor files
  79 are stored.
  80
  81 =cut
  82
  83 sub get_vendor_dir {
  84     return $origins;
  85 }
  86
  87 =item $fields = get_vendor_info($name)
  88
  89 Returns a Dpkg::Control object with the information parsed from the
  90 corresponding vendor file in $Dpkg::CONFDIR/origins/. If $name is omitted,
  91 it will use $Dpkg::CONFDIR/origins/default which is supposed to be a symlink
  92 to the vendor of the currently installed operating system. Returns undef
  93 if there's no file for the given vendor.
  94
  95 =cut
  96
  97 my $vendor_sep_regex = qr{[^A-Za-z0-9]+};
  98
  99 sub get_vendor_info(;$) {
 100     my $vendor = shift || 'default';
 101     my $vendor_key = lc $vendor =~ s{$vendor_sep_regex}{}gr;
 102     state %VENDOR_CACHE;
 103     return $VENDOR_CACHE{$vendor_key} if exists $VENDOR_CACHE{$vendor_key};
 104
 105     my $file = get_vendor_file($vendor);
 106     return unless $file;
 107     my $fields = Dpkg::Control::HashCore->new();
 108     $fields->load($file, compression => 0) or error(g_('%s is empty'), $file);
 109     $VENDOR_CACHE{$vendor_key} = $fields;
 110     return $fields;
 111 }
 112
 113 =item $name = get_vendor_file($name)
 114
 115 Check if there's a file for the given vendor and returns its
 116 name.
 117
 118 The vendor filename will be derived from the vendor name, by replacing any
 119 number of non-alphanumeric characters (that is B<[^A-Za-z0-9]>) into "B<->",
 120 then the resulting name will be tried in sequence by lower-casing it,
 121 keeping it as is, lower-casing then capitalizing it, and capitalizing it.
 122
 123 In addition, for historical and backwards compatibility, the name will
 124 be tried keeping it as is without non-alphanumeric characters remapping,
 125 then the resulting name will be tried in sequence by lower-casing it,
 126 keeping it as is, lower-casing then capitalizing it, and capitalizing it.
 127 And finally the name will be tried by replacing only spaces to "B<->",
 128 then the resulting name will be tried in sequence by lower-casing it,
 129 keeping it as is, lower-casing then capitalizing it, and capitalizing it.
 130
 131 But these backwards compatible name lookups will be removed during
 132 the dpkg 1.22.x release cycle.
 133
 134 =cut
 135
 136 sub get_vendor_file(;$) {
 137     my $vendor = shift || 'default';
 138
 139     my @names;
 140     my $vendor_sep = $vendor =~ s{$vendor_sep_regex}{-}gr;
 141     push @names, lc $vendor_sep, $vendor_sep, ucfirst lc $vendor_sep, ucfirst $vendor_sep;
 142
 143     # XXX: Backwards compatibility, remove on 1.22.x.
 144     my %name_seen = map { $_ => 1 } @names;
 145     my @obsolete_names = uniq grep {
 146         my $seen = exists $name_seen{$_};
 147         $name_seen{$_} = 1;
 148         not $seen;
 149     } (
 150         (lc $vendor, $vendor, ucfirst lc $vendor, ucfirst $vendor),
 151         ($vendor =~ s{\s+}{-}g) ?
 152         (lc $vendor, $vendor, ucfirst lc $vendor, ucfirst $vendor) : ()
 153     );
 154     my %obsolete_name = map { $_ => 1 } @obsolete_names;
 155     push @names, @obsolete_names;
 156
 157     foreach my $name (uniq @names) {
 158         next unless -e "$origins/$name";
 159         if (exists $obsolete_name{$name}) {
 160             warning(g_('%s origin filename is deprecated; ' .
 161                        'it should have only alphanumeric or dash characters'),
 162                     $name);
 163         }
 164         return "$origins/$name";
 165     }
 166     return;
 167 }
 168
 169 =item $name = get_current_vendor()
 170
 171 Returns the name of the current vendor. If DEB_VENDOR is set, it uses
 172 that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default.
 173 If that file doesn't exist, it returns undef.
 174
 175 =cut
 176
 177 sub get_current_vendor() {
 178     my $f;
 179     if (Dpkg::BuildEnv::has('DEB_VENDOR')) {
 180         $f = get_vendor_info(Dpkg::BuildEnv::get('DEB_VENDOR'));
 181         return $f->{'Vendor'} if defined $f;
 182     }
 183     $f = get_vendor_info();
 184     return $f->{'Vendor'} if defined $f;
 185     return;
 186 }
 187
 188 =item $object = get_vendor_object($name)
 189
 190 Return the Dpkg::Vendor::* object of the corresponding vendor.
 191 If $name is omitted, return the object of the current vendor.
 192 If no vendor can be identified, then return the Dpkg::Vendor::Default
 193 object.
 194
 195 The module name will be derived from the vendor name, by splitting parts
 196 around groups of non alphanumeric character (that is B<[^A-Za-z0-9]>)
 197 separators, by either capitalizing or lower-casing and capitalizing each part
 198 and then joining them without the separators. So the expected casing is based
 199 on the one from the B<Vendor> field in the F<origins> file.
 200
 201 In addition, for historical and backwards compatibility, the module name
 202 will also be looked up without non-alphanumeric character stripping, by
 203 capitalizing, lower-casing then capitalizing, as-is or lower-casing.
 204 But these name lookups will be removed during the 1.22.x release cycle.
 205
 206 =cut
 207
 208 sub get_vendor_object {
 209     my $vendor = shift || get_current_vendor() || 'Default';
 210     my $vendor_key = lc $vendor =~ s{$vendor_sep_regex}{}gr;
 211     state %OBJECT_CACHE;
 212     return $OBJECT_CACHE{$vendor_key} if exists $OBJECT_CACHE{$vendor_key};
 213
 214     my ($obj, @names);
 215
 216     my @vendor_parts = split m{$vendor_sep_regex}, $vendor;
 217     push @names, join q{}, map { ucfirst } @vendor_parts;
 218     push @names, join q{}, map { ucfirst lc } @vendor_parts;
 219
 220     # XXX: Backwards compatibility, remove on 1.22.x.
 221     my %name_seen = map { $_ => 1 } @names;
 222     my @obsolete_names = uniq grep {
 223         my $seen = exists $name_seen{$_};
 224         $name_seen{$_} = 1;
 225         not $seen;
 226     } (ucfirst $vendor, ucfirst lc $vendor, $vendor, lc $vendor);
 227     my %obsolete_name = map { $_ => 1 } @obsolete_names;
 228     push @names, @obsolete_names;
 229
 230     foreach my $name (uniq @names) {
 231         eval qq{
 232             require Dpkg::Vendor::$name;
 233             \$obj = Dpkg::Vendor::$name->new();
 234         };
 235         unless ($@) {
 236             $OBJECT_CACHE{$vendor_key} = $obj;
 237             if (exists $obsolete_name{$name}) {
 238                 warning(g_('%s module name is deprecated; ' .
 239                            'it should be capitalized with only alphanumeric characters'),
 240                         "Dpkg::Vendor::$name");
 241             }
 242             return $obj;
 243         }
 244     }
 245
 246     my $info = get_vendor_info($vendor);
 247     if (defined $info and defined $info->{'Parent'}) {
 248         return get_vendor_object($info->{'Parent'});
 249     } else {
 250         return get_vendor_object('Default');
 251     }
 252 }
 253
 254 =item run_vendor_hook($hookid, @params)
 255
 256 Run a hook implemented by the current vendor object.
 257
 258 =cut
 259
 260 sub run_vendor_hook {
 261     my @args = @_;
 262     my $vendor_obj = get_vendor_object();
 263
 264     $vendor_obj->run_hook(@args);
 265 }
 266
 267 =back
 268
 269 =head1 CHANGES
 270
 271 =head2 Version 1.02 (dpkg 1.21.10)
 272
 273 Deprecated behavior: get_vendor_file() loading vendor files with no special
 274 characters remapping. get_vendor_object() loading vendor module names with
 275 no special character stripping.
 276
 277 =head2 Version 1.01 (dpkg 1.17.0)
 278
 279 New function: get_vendor_dir().
 280
 281 =head2 Version 1.00 (dpkg 1.16.1)
 282
 283 Mark the module as public.
 284
 285 =head1 SEE ALSO
 286
 287 deb-origin(5).
 288
 289 =cut
 290
 291 1;