如何使用XS将C库中定义的符号导出为Perl常量？

Question

I am working on an XS wrapper module for some functions in the GNU scientific library. Instead of using the library directly here, I have simpilfied the problem by creating my own library:

mylib/mylib.h :

typedef struct {
    int foo;
    double bar;
} my_struct_type;
extern my_struct_type *my_symbol1;
extern my_struct_type *my_symbol2;
void use_struct( my_struct_type *s );

mylib/mylib.c :

#include "mylib.h"
#include <stdio.h>

static my_struct_type my_struct1 = { 3, 3.14 };
static my_struct_type my_struct2 = { 2, 1.06 };

my_struct_type *my_symbol1 = &my_struct1;
my_struct_type *my_symbol2 = &my_struct2;

void use_struct( my_struct_type *s ) {
    printf( "use_struct: foo = %d\n", s->foo);
    printf( "use_struct: bar = %g\n", s->bar);
}

This is compiled into a shared library using:

$ gcc -c -o mylib.o mylib.c
$ gcc -shared -o libmylib.so mylib.o

So I will use mylib.so as an example instead of libgsl.so . Now I would like to refer to the C symbols my_symbol1 and my_symbol2 from a Perl script. First I created an XS file:

XsTest.xs :

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "mylib.h"

/* These definition are created ad hoc to provide an interface to the perl module */
#define STRUCT_TYPE1 1
#define STRUCT_TYPE2 2

MODULE = My::XsTest  PACKAGE = My::XsTest
PROTOTYPES: DISABLE

 # export STRUCT_TYPE1, STRUCT_TYPE2, ... to My::XsTest
 # NOTE: I would like to avoid having to repeat the string, e.g. "STRUCT_TYPE1"
 #  in the lines below (if possible?)
BOOT:
{   
    SV* const_sv = get_sv( "My::XsTest::STRUCT_TYPE1", GV_ADD );
    sv_setiv( const_sv, STRUCT_TYPE1 );
    SvREADONLY_on( const_sv );
    SV* const_sv2 = get_sv( "My::XsTest::STRUCT_TYPE2", GV_ADD );
    sv_setiv( const_sv2, STRUCT_TYPE2 );
    SvREADONLY_on( const_sv2 );
}

void
use_struct(type)
    int type

    CODE:
        if (type == STRUCT_TYPE1 ) {
            use_struct(my_symbol1);
        }
        else if (type == STRUCT_TYPE2) {
            use_struct(my_symbol2);
        }
        else {
            croak("Unknown struct type");
        }

lib/My/XsTest.pm :

package My::XsTest;
our $VERSION = '0.01';
use strict;
use warnings;
use Exporter qw(import);
# NOTE: I would like to avoid having to define the line below here,
#  it would be better if it was enough to define them in XsTest.xs
our %EXPORT_TAGS = ( 'symbols' => [ qw( STRUCT_TYPE1 STRUCT_TYPE2 ) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{symbols} } );
our @EXPORT = qw(use_struct);

# NOTE: I would like to avoid having to declare here the two line below.
#  this should be done automatically from the .xs file
our $STRUCT_TYPE1;
our $STRUCT_TYPE2;

require XSLoader;
XSLoader::load();


# NOTE: I would like to avoid having to define the subs below.
#  This should be done automatically from the .xs file
sub STRUCT_TYPE1 {
    return $STRUCT_TYPE1;
}

sub STRUCT_TYPE2 {
    return $STRUCT_TYPE2;
}

1;

Then to compile the extension, I used a ExtUtils::MakeMaker :

Makefile.PL :

use strict;
use warnings;
use utf8;
use ExtUtils::MakeMaker;

my $lib_dir = 'mylib';

WriteMakefile(
  NAME          => 'My::XsTest',
  VERSION_FROM  => 'lib/My/XsTest.pm',
  PREREQ_PM     => { 'ExtUtils::MakeMaker' => 0 },
  ABSTRACT_FROM => 'lib/My/XsTest.pm',
  AUTHOR        => 'Håkon Hægland <hakon.hagland@gmail.com>',
  OPTIMIZE      => '-g3 -O0',
  LICENSE       => 'perl',
  LIBS          => ["-L$lib_dir -lmylib"],
  INC           => "-I$lib_dir",
);

and then compiling:

$ perl Makefile.PL
$ make

Finally, I tested the module from a Perl script:

p.pl :

#! /usr/bin/env perl

use feature qw(say);
use strict;
use warnings;
use ExtUtils::testlib;
use My::XsTest qw(use_struct :symbols);

use_struct(STRUCT_TYPE1);
use_struct(STRUCT_TYPE2);

Output :

use_struct: foo = 3
use_struct: bar = 3.14
use_struct: foo = 2
use_struct: bar = 1.06

So this works, but it is not pretty. How can I improve this code and avoid all the repetition of the symbol names especially in the file lib/My/XsTest.pm ?

Answer 1

You can change

sub STRUCT_TYPE1 {
    return $STRUCT_TYPE1;
}

...

To this.

for my $id ( 1 .. $MAX_SUB ) { # Max sub is the number of exported symbles
    no strict 'refs';
    my $struct = 'STRUCT_TYPE' . $id;
    *{ $struct } = sub { $$struct };
}

Answer 2

You can register constants (actually subroutines) in the XS BOOT section with newCONSTSUB . No sub definitions or our variables are required in the .pm file:

BOOT:
    {
        HV *stash = gv_stashpv("My::XsTest", 0);

        newCONSTSUB(stash, "STRUCT_TYPE1", newSViv(STRUCT_TYPE1));
        newCONSTSUB(stash, "STRUCT_TYPE2", newSViv(STRUCT_TYPE2));
    }

Answer 3

Here is way to avoid repetition of the symbol names in different files, and make hopefully make things easier to maintain. First I generated a JSON file:

symbols.json :

{
   "symbols" : ["my_symbol1", "my_symbol2"],
   "perl_names" : ["STRUCT_TYPE1", "STRUCT_TYPE2"]
}

Then I created a perl script gensymbols.pl that generated three files based on the previous JSON file:

mysymbols.h (generated):

#include "mylib.h"

#define MY_SYMBOLS_MIN 0
#define MY_SYMBOLS_MAX 1

static my_struct_type * my_symbols[2];

my_setup_array.h (generated):

my_symbols[0] = my_symbol1;
my_symbols[1] = my_symbol2;

lib/My/Symbols.pm (generated):

package My::Symbols;
use strict;
use warnings;
use Exporter qw(import);

our $symbols = [
    "STRUCT_TYPE1",
    "STRUCT_TYPE2"
];
our @EXPORT = @$symbols;

sub STRUCT_TYPE1 { 0 }
sub STRUCT_TYPE2 { 1 }

Then I changed the XS file to:

XsTest.xs :

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "mylib.h"
#include "mysymbols.h"

MODULE = My::XsTest  PACKAGE = My::XsTest
PROTOTYPES: DISABLE

BOOT:
#include "my_setup_array.h"

void
use_struct(type)
    int type

    CODE:
        if ( (type < MY_SYMBOLS_MIN) || (type >MY_SYMBOLS_MAX) ) {
            croak("Unknown symbol type");
        }
        else {
            use_struct(my_symbols[type]);
        }

and the perl module to:

lib/My/XsTest.pm :

package My::XsTest;
our $VERSION = '0.01';
use strict;
use warnings;
use Exporter qw(import);
use My::Symbols;
our %EXPORT_TAGS = ( 'symbols' => $My::Symbols::symbols );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{symbols} } );
our @EXPORT = qw(use_struct);

require XSLoader;
XSLoader::load();
1;

In this way I could move all information about the symbols to the JSON file, and the maintainer only has to care about this file. If he changes the file, he must remember to run the gensymbols.pl Perl script to regenerate the three files. Here is the script for completeness:

gensymbols.pl

     #! /usr/bin/env perl

{
    GenSymbols->new(
        c_symbol_array_name   => 'my_symbols',
        perl_symbol_module_fn => 'lib/My/Symbols.pm',
        symbols_fn            => 'symbols.json',
        xs_include            => {
            my_symbols_fn      => 'mysymbols.h',
            my_setup_array_fn => 'my_setup_array.h'
        },
    );
}

package GenSymbols;
use feature qw(say);
use strict;
use warnings;

use Data::Printer;
use JSON::XS;
use Clone qw(clone);

sub new {
    my ( $class, %temp ) = @_;

    my $args = clone \%temp;
    my $self = bless $args, $class;

    $self->read_json();
    $self->write_xs_include_mysymbols();
    $self->write_xs_include_my_setup_array();
    $self->write_perl_symbol_module();
}

sub write_perl_symbol_module {
    my ( $self ) = @_;

    my $fn = $self->{perl_symbol_module_fn};
    open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!";
    say $fh 'package My::Symbols;';
    say $fh 'use strict;';
    say $fh 'use warnings;';
    say $fh 'use Exporter qw(import);';
    print $fh "\n";
    my $names = $self->{perl_names_array};
    say $fh 'our $symbols = [';
    for my $i ( 0..$#$names ) {
        my $name = $names->[$i];
        $name = '    "' . $name . '"';
        $name .= "," if $i < $#$names;
        say $fh $name;
    }
    say $fh '];';
    say $fh 'our @EXPORT = @$symbols;';
    print $fh "\n";
    for my $i ( 0..$#$names ) {
        printf $fh ('sub %s { %d }' . "\n"), $names->[$i], $i;
    }
    say $fh '1;';
    close $fh;
}

sub write_xs_include_my_setup_array {
    my ( $self ) = @_;

    my $fn = $self->{xs_include}{my_setup_array_fn};
    my $syms = $self->{sym_array};
    open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!";
    my $sym_arr_name = $self->{c_symbol_array_name};
    for my $i (0..$#$syms) {
        my $sym = $syms->[$i];
        printf $fh "%s[%d] = %s;\n", $sym_arr_name, $i, $sym;
    }
    close $fh;
}

sub write_xs_include_mysymbols {
    my ( $self ) = @_;

    my $fn = $self->{xs_include}{my_symbols_fn};
    my $syms = $self->{sym_array};
    open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!";
    my $min_index = 0;
    my $max_index = $#$syms;
    my $sym_arr_name = $self->{c_symbol_array_name};
    say $fh '#include "mylib.h"';
    print $fh "\n";
    printf $fh "#define MY_SYMBOLS_MIN %d\n", $min_index;
    printf $fh "#define MY_SYMBOLS_MAX %d\n", $max_index;
    print $fh "\n";
    printf $fh "static my_struct_type * %s[%d];\n", $sym_arr_name, $max_index + 1;
    close $fh;
}


sub read_json {
    my ( $self ) = @_;

    my $fn = $self->{symbols_fn};
    open ( my $fh, '<', $fn ) or die "Could not open file '$fn': $!";
    my $str = do { local $/; <$fh> };
    close $fh;
    my $hash = JSON::XS->new->decode( $str );
    $self->{sym_array} = $hash->{symbols};
    $self->{perl_names_array} = $hash->{perl_names};
}