File Coverage

blib/lib/ZMQ/FFI/Util.pm

Criterion	Covered	Total	%
statement	30	42	71.4
branch	2	6	33.3
condition	1	6	16.6
subroutine	9	10	90.0
pod	2	2	100.0
total	44	66	66.6

package ZMQ::FFI::Util;
$ZMQ::FFI::Util::VERSION = '0.17';
# ABSTRACT: zmq convenience functions

use strict;
use warnings;

use FFI::Raw;
use Carp;
use Try::Tiny;

use Sub::Exporter -setup => {
    exports => [qw(
        zmq_soname
        zmq_version
    )],
};

sub zmq_soname {
    my %args = @_;

    my $die = $args{die};

    # Try to find a soname available on this system
    #
    # Linux .so symlink conventions are linker_name => soname => real_name
    # e.g. libzmq.so => libzmq.so.X => libzmq.so.X.Y.Z
    # Unfortunately not all distros follow this convention (Ubuntu). So first
    # we'll try the linker_name, then the sonames.
    #
    # If Linux extensions fail also try platform specific
    # extensions (e.g. OS X) before giving up.
    my @sonames = qw(
        libzmq.so    libzmq.so.4    libzmq.so.3    libzmq.so.1
        libzmq.dylib libzmq.4.dylib libzmq.3.dylib libzmq.1.dylib
    );

    my $soname;
    FIND_SONAME:
    for (@sonames) {
        try {
            $soname = $_;

            my $zmq_version = FFI::Raw->new(
                $soname => 'zmq_version',
                FFI::Raw::void,
                FFI::Raw::ptr,  # major
                FFI::Raw::ptr,  # minor
                FFI::Raw::ptr   # patch
            );
        }
        catch {
            undef $soname;
        };

        last FIND_SONAME if $soname;
    }

    if ( !$soname && $die ) {
        croak
            qq(Could not load libzmq, tried:\n),
            join(', ', @sonames),"\n",
            q(Is libzmq on your ld path?);
    }

    return $soname;
}

sub zmq_version {
    my $soname = shift;

    $soname //= zmq_soname();

    return unless $soname;

    my $zmq_version = FFI::Raw->new(
        $soname => 'zmq_version',
        FFI::Raw::void,
        FFI::Raw::ptr,  # major
        FFI::Raw::ptr,  # minor
        FFI::Raw::ptr   # patch
    );

    my ($major, $minor, $patch) = map { pack 'i!', $_ } (0, 0, 0);

    my @ptrs = map { unpack('L!', pack('P', $_)) } ($major, $minor, $patch);

    $zmq_version->(@ptrs);

    return map { unpack 'i!', $_ } ($major, $minor, $patch);
}

1;

__END__