view release on metacpan or  search on metacpan

lib/Dpkg/Vendor.pm  view on Meta::CPAN

number of non-alphanumeric characters (that is B<[^A-Za-z0-9]>) into "B<->",
then the resulting name will be tried in sequence by lower-casing it,
keeping it as is, lower-casing then capitalizing it, and capitalizing it.

=cut

sub get_vendor_file {
    my $vendor = shift || 'default';

    my @names;
    my $vendor_sep = $vendor =~ s{$vendor_sep_regex}{-}gr;
    push @names, lc $vendor_sep, $vendor_sep, ucfirst lc $vendor_sep, ucfirst $vendor_sep;

    foreach my $name (uniq @names) {
        next unless -e "$origins/$name";
        return "$origins/$name";
    }
    return;
}

=item $name = get_current_vendor()

Returns the name of the current vendor. If DEB_VENDOR is set, it uses
that first, otherwise it falls back to parsing $Dpkg::CONFDIR/origins/default.
If that file doesn't exist, it returns undef.

=cut

sub get_current_vendor {
    my $f;
    if (Dpkg::BuildEnv::has('DEB_VENDOR')) {
        $f = get_vendor_info(Dpkg::BuildEnv::get('DEB_VENDOR'));
        return $f->{'Vendor'} if defined $f;
    }
    $f = get_vendor_info();
    return $f->{'Vendor'} if defined $f;
    return;
}

=item $object = get_vendor_object($name)

Return the Dpkg::Vendor::* object of the corresponding vendor.
If $name is omitted, return the object of the current vendor.
If no vendor can be identified, then return the L<Dpkg::Vendor::Default>
object.

The module name will be derived from the vendor name, by splitting parts
around groups of non alphanumeric character (that is B<[^A-Za-z0-9]>)
separators, by either capitalizing or lower-casing and capitalizing each part
and then joining them without the separators. So the expected casing is based
on the one from the B<Vendor> field in the F<origins> file.

=cut

sub get_vendor_object {
    my $vendor = shift || get_current_vendor() || 'Default';
    my $vendor_key = lc $vendor =~ s{$vendor_sep_regex}{}gr;
    state %OBJECT_CACHE;
    return $OBJECT_CACHE{$vendor_key} if exists $OBJECT_CACHE{$vendor_key};

    my @vendor_parts = split m{$vendor_sep_regex}, $vendor;

    my @names;
    push @names, join q{}, map { ucfirst } @vendor_parts;
    push @names, join q{}, map { ucfirst lc } @vendor_parts;

    foreach my $name (uniq @names) {
        my $module = "Dpkg::Vendor::$name";
        eval qq{
            require $module;
        };
        next if $@;

        my $obj = $module->new();
        $OBJECT_CACHE{$vendor_key} = $obj;
        return $obj;
    }

    my $info = get_vendor_info($vendor);
    if (defined $info and defined $info->{'Parent'}) {
        return get_vendor_object($info->{'Parent'});
    } else {
        return get_vendor_object('Default');
    }
}

=item run_vendor_hook($hookid, @params)

Run a hook implemented by the current vendor object.

=cut

sub run_vendor_hook {
    my @args = @_;
    my $vendor_obj = get_vendor_object();

    $vendor_obj->run_hook(@args);
}

=back

=head1 CHANGES

=head2 Version 1.03 (dpkg 1.22.12)

Obsolete behavior: get_vendor_file() and get_vendor_object() no longer
support the deprecated behavior from 1.02.

=head2 Version 1.02 (dpkg 1.21.10)

Deprecated behavior: get_vendor_file() loading vendor files with no special
characters remapping. get_vendor_object() loading vendor module names with
no special character stripping.

=head2 Version 1.01 (dpkg 1.17.0)

New function: get_vendor_dir().

=head2 Version 1.00 (dpkg 1.16.1)

Mark the module as public.