Bug#686122: [new] tool to determine policy-compliant binary package name

[Jakub Wilk]

Package: devscripts
Version: 2.12.1
Severity: wishlist
User: devscripts at packages.debian.org
Usertags: new

As suggested by Russ Albery in #661928, I wrote a script to determine 
policy-compliant binary package name for a shared library. (As a bonus, 
it also can do the same thing for Python and Perl modules).

Example:

$ binpkgname /usr/lib/libgauche-0.9.so.0.1 /usr/lib/python2.7/dist-packages/debian/__init__.py /usr/share/perl5/JSON.pm
libgauche-0.9-0: /usr/lib/libgauche-0.9.so.0.1
python-debian: /usr/lib/python2.7/dist-packages/debian/__init__.py
libjson-perl: /usr/share/perl5/JSON.pm

-- 
Jakub Wilk
-------------- next part --------------
#!/usr/bin/perl

# Copyright ? 2012 Jakub Wilk <jwilk at debian.org>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the ?Software?), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED ?AS IS?, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

=head1 NAME

binpkgname - determine binary package name

=head1 SYNOPSIS

B<binpkgname> I<file>...

=head1 DESCRIPTION

B<binpkgname> determines policy-compliant binary package name for the specified
file.  The file can be a shared library, a Perl module, or a Python module.

=head1 CONFROMS TO

Debian Policy, version 3.9.3

Debian Perl Policy, version 3.9.3

Debian Python Policy, version 0.9.4.2

=cut

use strict;
use warnings;

use Getopt::Long qw(:config gnu_getopt auto_help);

my $python_re = qr{^
( /usr/lib/pymodules/python2\.\d+/
| /usr/lib/python2\.\d+/(?:site|dist)-packages/
| /usr/share/pyshared/
| /usr/share/python-support/[^/]+/
)
}x;

my $python3_re = qr{^
  /usr/lib/python3/dist-packages/
}x;

my $perl_re = qr{
( /usr/share/perl5/
| /usr/lib/perl5/
)
}x;

my $shlib_re = qr{^
(?: /usr )? /lib/.* # directory part
(?<=/) lib [^/]+ \.so (?: \.[^/]+ )? # filename part
$
}x;

sub python_file_to_package {
    # Debian Python Policy ?2.2
    ($_, my $version) = @_;
    my $suffix = '';
    if ($version >= 3 and s{\.cpython-\d+(d?)[^.]+\.so$}{}) {
        $suffix = '-dbg' if $1;
    } elsif ($version <= 2 and s{_d\.so$}{}) {
        $suffix = '-dbg';
    } elsif (s{\.so$}{} or s{\.py$}{}) {
        # pass
    } else {
        die;
    }
    s{/__init__}{};
    s{/}{.}g;
    y{A-Z_}{a-z-};
    if ($version eq 2) {
        $version = '';
    }
    return "python$version-$_$suffix";
}

sub perl_file_to_package {
    # Debian Perl Policy ?4.2
    ($_) = @_;
    s{\.pm$}{} or s{auto/(.+)(?:[.](?:bs|so))}{$1};
    s{/$}{}g;
    s{/}{-}g;
    y{A-Z_}{a-z-};
    return "lib$_-perl";
}

sub shlib_to_package {
    # Debian Policy ?8.1
    my $soname;
    open(my $fh, '-|', 'readelf', '-d', $_) or die;
    while (<$fh>) {
        if (m{Library soname:\s+\[(.+)\]}) {
            $soname = $1;
            last;
        }
    }
    close($fh) or die;
    defined($soname) or die;
    $_ = $soname;
    s{([0-9])\.so\.}{$1-};
    s{\.so(?:\.|$)}{};
    y{A-Z_}{a-z-};
    return $_;
}

sub file_to_package {
    ($_) = @_;
    m{^/} or die;
    s{//+}{/}g;
    if (s{$python_re}{}) {
        return python_file_to_package($_, 2);
    } elsif (s{$python3_re}{}) {
        return python_file_to_package($_, 3);
    } elsif (s{$perl_re}{}) {
        return perl_file_to_package($_, 3);
    } elsif (m{$shlib_re}) {
        return shlib_to_package($_);
    }
    die;
}

GetOptions();
for my $file (@ARGV) {
    my $pkgname = file_to_package($file);
    print "$pkgname: $file\n";
}

# vim:ts=4 sw=4 et