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