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

Question

我正在为GNU科学库中的某些函数开发XS包装模块。我没有直接在这里使用库，而是通过创建自己的库来简化问题：

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 = %dn", s->foo);
printf( "use_struct: bar = %gn", s->bar);
}

这是使用以下命令编译到共享库中的：

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

所以我将以mylib.so为例，而不是libgsl.so.现在我想引用 Perl 脚本中my_symbol1和my_symbol2的 C 符号。首先，我创建了一个XS文件：

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;

然后为了编译扩展，我使用了一个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 <[e-mail]>',
OPTIMIZE      => '-g3 -O0',
LICENSE       => 'perl',
LIBS          => ["-L$lib_dir -lmylib"],
INC           => "-I$lib_dir",
);

然后编译：

$ perl Makefile.PL
$ make

最后，我用一个Perl脚本测试了这个模块：

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);

输出：

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

所以这有效，但它并不漂亮。如何改进此代码并避免符号名称的所有重复，尤其是在文件lib/My/XsTest.pm中？

Answer 1

您可以使用newCONSTSUB在 XSBOOT部分中注册常量(实际上是子例程(。.pm文件中不需要子定义或our变量：

BOOT:
{
HV *stash = gv_stashpv("My::XsTest", 0);
newCONSTSUB(stash, "STRUCT_TYPE1", newSViv(STRUCT_TYPE1));
newCONSTSUB(stash, "STRUCT_TYPE2", newSViv(STRUCT_TYPE2));
}

Answer 2

你可以改变

sub STRUCT_TYPE1 {
return $STRUCT_TYPE1;
}
...

对此。

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 3

这是避免不同文件中符号名称重复的方法，并希望使事情更容易维护。首先，我生成了一个 JSON 文件：

symbols.json：

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

然后我创建了一个 perl 脚本gensymbols.pl，它基于之前的 JSON 文件生成了三个文件：

mysymbols.h(生成(：

#include "mylib.h"
#define MY_SYMBOLS_MIN 0
#define MY_SYMBOLS_MAX 1
static my_struct_type * my_symbols[2];

my_setup_array.h(生成(：

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

lib/My/Symbols.pm(生成(：

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 }

然后我将XS文件更改为：

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]);
}

和 Perl 模块：

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;

通过这种方式，我可以将有关符号的所有信息移动到 JSON 文件中，维护者只需要关心这个文件。如果他更改了文件，他必须记住运行gensymbols.plPerl脚本来重新生成这三个文件。以下是完整性的脚本：

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 %dn", $min_index;
printf $fh "#define MY_SYMBOLS_MAX %dn", $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};
}