chiark - git - mdw - dpkg/blob - scripts/Dpkg/Vendor.pm

   1 # Copyright © 2008-2009 Raphaël Hertzog <hertzog@debian.org>
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  15
  16 package Dpkg::Vendor;
  17
  18 use strict;
  19 use warnings;
  20 use feature qw(state);
  21
  22 our $VERSION = '1.01';
  23 our @EXPORT_OK = qw(
  24     get_current_vendor
  25     get_vendor_info
  26     get_vendor_file
  27     get_vendor_dir
  28     get_vendor_object
  29     run_vendor_hook
  30 );
  31
  32 use Exporter qw(import);
  33
  34 use Dpkg ();
  35 use Dpkg::ErrorHandling;
  36 use Dpkg::Gettext;
  37 use Dpkg::Build::Env;
  38 use Dpkg::Control::HashCore;
  39
  40 my $origins = "$Dpkg::CONFDIR/origins";
  41 $origins = $ENV{DPKG_ORIGINS_DIR} if $ENV{DPKG_ORIGINS_DIR};
  42
  43 =encoding utf8
  44
  45 =head1 NAME
  46
  47 Dpkg::Vendor - get access to some vendor specific information
  48
  49 =head1 DESCRIPTION
  50
  51 The files in $Dpkg::CONFDIR/origins/ can provide information about various
  52 vendors who are providing Debian packages. Currently those files look like
  53 this:
  54
  55   Vendor: Debian
  56   Vendor-URL: https://www.debian.org/
  57   Bugs: debbugs://bugs.debian.org
  58
  59 If the vendor derives from another vendor, the file should document
  60 the relationship by listing the base distribution in the Parent field:
  61
  62   Parent: Debian
  63
  64 The file should be named according to the vendor name. The usual convention
  65 is to name the vendor file using the vendor name in all lowercase, but some
  66 variation is permitted. Namely, spaces are mapped to dashes ('-'), and the
  67 file can have the same casing as the Vendor field, or it can be capitalized.
  68
  69 =head1 FUNCTIONS
  70
  71 =over 4
  72
  73 =item $dir = Dpkg::Vendor::get_vendor_dir()
  74
  75 Returns the current dpkg origins directory name, where the vendor files
  76 are stored.
  77
  78 =cut
  79
  80 sub get_vendor_dir {
  81     return $origins;
  82 }
  83
  84 =item $fields = Dpkg::Vendor::get_vendor_info($name)
  85
  86 Returns a Dpkg::Control object with the information parsed from the
  87 corresponding vendor file in $Dpkg::CONFDIR/origins/. If $name is omitted,
  88 it will use $Dpkg::CONFDIR/origins/default which is supposed to be a symlink
  89 to the vendor of the currently installed operating system. Returns undef
  90 if there's no file for the given vendor.
  91
  92 =cut
  93
  94 sub get_vendor_info(;$) {
  95     my $vendor = shift || 'default';
  96     state %VENDOR_CACHE;
  97     return $VENDOR_CACHE{$vendor} if exists $VENDOR_CACHE{$vendor};
  98
  99     my $file = get_vendor_file($vendor);
 100     return unless $file;
 101     my $fields = Dpkg::Control::HashCore->new();
 102     $fields->load($file) or error(g_('%s is empty'), $file);
 103     $VENDOR_CACHE{$vendor} = $fields;
 104     return $fields;
 105 }
 106
 107 =item $name = Dpkg::Vendor::get_vendor_file($name)
 108
 109 Check if there's a file for the given vendor and returns its
 110 name.
 111
 112 =cut
 113
 114 sub get_vendor_file(;$) {
 115     my $vendor = shift || 'default';
 116     my $file;
 117     my @tries = ($vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor)));
 118     if ($vendor =~ s/\s+/-/) {
 119         push @tries, $vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor));
 120     }
 121     foreach my $name (@tries) {
 122         $file = "$origins/$name" if -e "$origins/$name";
 123     }
 124     return $file;
 125 }
 126
 127 =item $name = Dpkg::Vendor::get_current_vendor()
 128
 129 Returns the name of the current vendor. If DEB_VENDOR is set, it uses
 130 that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default.
 131 If that file doesn't exist, it returns undef.
 132
 133 =cut
 134
 135 sub get_current_vendor() {
 136     my $f;
 137     if (Dpkg::Build::Env::has('DEB_VENDOR')) {
 138         $f = get_vendor_info(Dpkg::Build::Env::get('DEB_VENDOR'));
 139         return $f->{'Vendor'} if defined $f;
 140     }
 141     $f = get_vendor_info();
 142     return $f->{'Vendor'} if defined $f;
 143     return;
 144 }
 145
 146 =item $object = Dpkg::Vendor::get_vendor_object($name)
 147
 148 Return the Dpkg::Vendor::* object of the corresponding vendor.
 149 If $name is omitted, return the object of the current vendor.
 150 If no vendor can be identified, then return the Dpkg::Vendor::Default
 151 object.
 152
 153 =cut
 154
 155 sub get_vendor_object {
 156     my $vendor = shift || get_current_vendor() || 'Default';
 157     state %OBJECT_CACHE;
 158     return $OBJECT_CACHE{$vendor} if exists $OBJECT_CACHE{$vendor};
 159
 160     my ($obj, @names);
 161     push @names, $vendor, lc($vendor), ucfirst($vendor), ucfirst(lc($vendor));
 162
 163     foreach my $name (@names) {
 164         eval qq{
 165             pop \@INC if \$INC[-1] eq '.';
 166             require Dpkg::Vendor::$name;
 167             \$obj = Dpkg::Vendor::$name->new();
 168         };
 169         unless ($@) {
 170             $OBJECT_CACHE{$vendor} = $obj;
 171             return $obj;
 172         }
 173     }
 174
 175     my $info = get_vendor_info($vendor);
 176     if (defined $info and defined $info->{'Parent'}) {
 177         return get_vendor_object($info->{'Parent'});
 178     } else {
 179         return get_vendor_object('Default');
 180     }
 181 }
 182
 183 =item Dpkg::Vendor::run_vendor_hook($hookid, @params)
 184
 185 Run a hook implemented by the current vendor object.
 186
 187 =cut
 188
 189 sub run_vendor_hook {
 190     my $vendor_obj = get_vendor_object();
 191     $vendor_obj->run_hook(@_);
 192 }
 193
 194 =back
 195
 196 =head1 CHANGES
 197
 198 =head2 Version 1.01 (dpkg 1.17.0)
 199
 200 New function: get_vendor_dir().
 201
 202 =head2 Version 1.00 (dpkg 1.16.1)
 203
 204 Mark the module as public.
 205
 206 =head1 SEE ALSO
 207
 208 deb-origin(5).
 209
 210 =cut
 211
 212 1;