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 16package Dpkg::Vendor; 17 18use strict; 19use warnings; 20use feature qw(state); 21 22our $VERSION = '1.01'; 23our @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 32use Exporter qw(import); 33 34use Dpkg (); 35use Dpkg::ErrorHandling; 36use Dpkg::Gettext; 37use Dpkg::Build::Env; 38use Dpkg::Control::HashCore; 39 40my $origins = "$Dpkg::CONFDIR/origins"; 41$origins = $ENV{DPKG_ORIGINS_DIR} if $ENV{DPKG_ORIGINS_DIR}; 42 43=encoding utf8 44 45=head1 NAME 46 47Dpkg::Vendor - get access to some vendor specific information 48 49=head1 DESCRIPTION 50 51The files in $Dpkg::CONFDIR/origins/ can provide information about various 52vendors who are providing Debian packages. Currently those files look like 53this: 54 55 Vendor: Debian 56 Vendor-URL: https://www.debian.org/ 57 Bugs: debbugs://bugs.debian.org 58 59If the vendor derives from another vendor, the file should document 60the relationship by listing the base distribution in the Parent field: 61 62 Parent: Debian 63 64The file should be named according to the vendor name. The usual convention 65is to name the vendor file using the vendor name in all lowercase, but some 66variation is permitted. Namely, spaces are mapped to dashes ('-'), and the 67file 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 = get_vendor_dir() 74 75Returns the current dpkg origins directory name, where the vendor files 76are stored. 77 78=cut 79 80sub get_vendor_dir { 81 return $origins; 82} 83 84=item $fields = get_vendor_info($name) 85 86Returns a Dpkg::Control object with the information parsed from the 87corresponding vendor file in $Dpkg::CONFDIR/origins/. If $name is omitted, 88it will use $Dpkg::CONFDIR/origins/default which is supposed to be a symlink 89to the vendor of the currently installed operating system. Returns undef 90if there's no file for the given vendor. 91 92=cut 93 94sub 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, compression => 0) or error(g_('%s is empty'), $file); 103 $VENDOR_CACHE{$vendor} = $fields; 104 return $fields; 105} 106 107=item $name = get_vendor_file($name) 108 109Check if there's a file for the given vendor and returns its 110name. 111 112=cut 113 114sub 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 = get_current_vendor() 128 129Returns the name of the current vendor. If DEB_VENDOR is set, it uses 130that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default. 131If that file doesn't exist, it returns undef. 132 133=cut 134 135sub 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 = get_vendor_object($name) 147 148Return the Dpkg::Vendor::* object of the corresponding vendor. 149If $name is omitted, return the object of the current vendor. 150If no vendor can be identified, then return the Dpkg::Vendor::Default 151object. 152 153=cut 154 155sub 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 run_vendor_hook($hookid, @params) 184 185Run a hook implemented by the current vendor object. 186 187=cut 188 189sub 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 200New function: get_vendor_dir(). 201 202=head2 Version 1.00 (dpkg 1.16.1) 203 204Mark the module as public. 205 206=head1 SEE ALSO 207 208deb-origin(5). 209 210=cut 211 2121; 213