use strict;
use Config;
use File::Spec;
use File::Basename qw(dirname);
use List::Util qw(first);
my @perl_types = qw(
ZMQ::CZMQ::zctx
ZMQ::CZMQ::zsocket
ZMQ::CZMQ::zframe
ZMQ::CZMQ::zmsg
);
# write_constants_file( File::Spec->catfile('xs', 'const-xs.inc') );
write_typemap( File::Spec->catfile('xs', 'typemap') );
write_magic_file( File::Spec->catfile('xs', 'mg-xs.inc') );
sub write_magic_file {
my $file = shift;
open my $fh, '>', $file or
die "Could not open objects file $file: $!";
print $fh <<EOM;
STATIC_INLINE
int
PerlCZMQ_mg_free(pTHX_ SV * const sv, MAGIC *const mg ) {
PERL_UNUSED_VAR(sv);
Safefree(mg->mg_ptr);
return 0;
}
STATIC_INLINE
int
PerlCZMQ_mg_dup(pTHX_ MAGIC* const mg, CLONE_PARAMS* const param) {
PERL_UNUSED_VAR(mg);
PERL_UNUSED_VAR(param);
return 0;
}
STATIC_INLINE MAGIC*
PerlCZMQ_mg_find(pTHX_ SV* const sv, const MGVTBL* const vtbl){
MAGIC* mg;
assert(sv != NULL);
assert(vtbl != NULL);
for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic){
if(mg->mg_virtual == vtbl){
assert(mg->mg_type == PERL_MAGIC_ext);
return mg;
}
}
return NULL; /* not reached */
}
EOM
open my $src, '<', "xs/perl_czmq.xs";
foreach my $perl_type (@perl_types) {
my $c_type = $perl_type;
$c_type =~ s/::/_/g;
$c_type =~ s/^ZMQ_CZMQ/PerlCZMQ/;
my $vtablename = sprintf '%s_vtbl', $c_type;
# check if we have a function named ${c_type}_free and ${c_type}_mg_dup
my ($has_free, $has_dup, $has_find);
seek ($src, 0, 0);
while (<$src>) {
$has_free++ if /^${c_type}_mg_free\b/;
$has_dup++ if /^${c_type}_mg_dup\b/;
$has_find++ if /^${c_type}_mg_find\b/;
}
my $free = $has_free ? "${c_type}_mg_free" : "PerlCZMQ_mg_free";
my $dup = $has_dup ? "${c_type}_mg_dup" : "PerlCZMQ_mg_dup";
print $fh <<EOM;
static MGVTBL $vtablename = { /* for identity */
NULL, /* get */
NULL, /* set */
NULL, /* len */
NULL, /* clear */
$free, /* free */
NULL, /* copy */
$dup, /* dup */
#ifdef MGf_LOCAL
NULL /* local */
#endif
};
EOM
if (! $has_find) {
print $fh <<EOM;
STATIC_INLINE MAGIC *
${c_type}_mg_find( pTHX_ SV* const sv ) {
MAGIC *mg;
PerlCZMQ_trace( "START mg_find (${perl_type})" );
PerlCZMQ_trace( " + SV %p", sv )
mg = PerlCZMQ_mg_find( aTHX_ sv, &$vtablename );
if (mg == NULL) {
croak("${perl_type}: Invalid ${perl_type} object was passed to mg_find");
}
return mg;
}
EOM
}
}
}
sub write_constants_file {
my $file = shift;
my $header = first { -f $_ } (
$ENV{ZMQ_H},
map { File::Spec->catfile( $_, 'include', 'zmq.h' ) }
('/usr/local', '/usr',
File::Spec->catdir( dirname($Config{perlpath}),
File::Spec->updir )
)
);
if (! $header) {
die "Could not find zmq.h anywhere.";
}
print STDERR " + Using zmq.h from $header\n";
open( my $in, '<', $header ) or
die "Could not open file $header for reading: $!";
open( my $out, '>', $file ) or
die "Could not open file $file for writing: $!";
print $out
"# Do NOT edit this file! This file was automatically generated\n",
"# by Makefile.PL on @{[scalar localtime]}. If you want to\n",
"# regenerate it, remove this file and re-run Makefile.PL\n",
"\n",
"IV\n",
"_constant()\n",
" ALIAS:\n",
;
while (my $ln = <$in>) {
if ($ln =~ /^\#define\s+(ZMQ_[A-Z0-9_]+)\s+/) {
print $out " $1 = $1\n";
}
}
close $in;
print $out
" CODE:\n",
" RETVAL = ix;\n",
" OUTPUT:\n",
" RETVAL\n"
;
close $out;
}
sub write_typemap {
my $file = shift;
open( my $out, '>', $file ) or
die "Could not open $file for writing: $!";
my (@decl, @input, @output);
push @decl, "const void * T_PV";
push @decl, "Bool T_BOOL";
push @decl, "byte * T_PV";
push @decl, "PerlCZMQ_zsocket_raw* PERLCZMQ_ZSOCKET_RAW";
push @input, <<EOM;
PERLCZMQ_ZSOCKET_RAW
{
MAGIC *mg;
\$var = NULL;
if (! sv_isobject(\$arg)) {
croak(\\"Argument is not an object\\");
}
/* if it got here, it's a blessed reference. better be an HV */
{
SV *svr;
SV **closed;
svr = SvRV(\$arg);
if (! svr ) {
croak(\\"PANIC: Could not get reference from blessed object.\\");
}
if (SvTYPE(svr) != SVt_PVHV) {
croak(\\"PANIC: Underlying storage of blessed reference is not a hash.\\");
}
closed = hv_fetchs( (HV *) svr, \\"_closed\\", 0 );
if (closed != NULL && SvTRUE(*closed)) {
/* if it's already closed, just return */
XSRETURN_EMPTY;
}
}
mg = PerlCZMQ_zsocket_mg_find(aTHX_ SvRV(\$arg));
if (mg) {
if (mg->mg_ptr == NULL)
croak(\\"Invalid ZMQ::CZMQ::zsocket object (perhaps you've already freed it?)\\");
\$var = ((PerlCZMQ_zsocket *) mg->mg_ptr)->socket;
}
if (\$var == NULL)
croak(\\"Invalid ZMQ::CZMQ::zsocket object (perhaps you've already freed it?)\\");
}
EOM
foreach my $perl_type (@perl_types) {
my $c_type = $perl_type;
$c_type =~ s/::/_/g;
$c_type =~ s/^ZMQ_CZMQ_/PerlCZMQ_/;
my $typemap_type = 'T_' . uc $c_type;
push @decl, "$c_type* $typemap_type";
push @input, <<EOM;
$typemap_type
{
MAGIC *mg;
\$var = NULL;
if (! sv_isobject(\$arg)) {
croak(\\"Argument is not an object\\");
}
/* if it got here, it's a blessed reference. better be an HV */
{
SV *svr;
SV **closed;
svr = SvRV(\$arg);
if (! svr ) {
croak(\\"PANIC: Could not get reference from blessed object.\\");
}
if (SvTYPE(svr) != SVt_PVHV) {
croak(\\"PANIC: Underlying storage of blessed reference is not a hash.\\");
}
closed = hv_fetchs( (HV *) svr, \\"_closed\\", 0 );
if (closed != NULL && SvTRUE(*closed)) {
/* if it's already closed, just return */
XSRETURN_EMPTY;
}
}
mg = ${c_type}_mg_find(aTHX_ SvRV(\$arg));
if (mg) {
\$var = ($c_type *) mg->mg_ptr;
}
if (\$var == NULL)
croak(\\"Invalid $perl_type object (perhaps you've already freed it?)\\");
}
EOM
push @output, <<EOM;
$typemap_type
if (!\$var) /* if null */
SvOK_off(\$arg); /* then return as undef instead of reaf to undef */
else {
/* setup \$arg as a ref to a blessed hash hv */
MAGIC *mg;
HV *hv = newHV();
const char *classname = \\"$perl_type\\";
/* take (sub)class name to use from class_sv if appropriate */
if (SvMAGICAL(class_sv))
mg_get(class_sv);
if (SvOK( class_sv ) && sv_derived_from(class_sv, classname ) ) {
if(SvROK(class_sv) && SvOBJECT(SvRV(class_sv))) {
classname = sv_reftype(SvRV(class_sv), TRUE);
} else {
classname = SvPV_nolen(class_sv);
}
}
sv_setsv(\$arg, sv_2mortal(newRV_noinc((SV*)hv)));
(void)sv_bless(\$arg, gv_stashpv(classname, TRUE));
mg = sv_magicext((SV*)hv, NULL, PERL_MAGIC_ext, &${c_type}_vtbl, (char*) \$var, 0);
mg->mg_flags |= MGf_DUP;
}
EOM
}
print $out
"# Do NOT edit this file! This file was automatically generated\n",
"# by Makefile.PL on @{[scalar localtime]}. If you want to\n",
"# regenerate it, remove this file and re-run Makefile.PL\n",
"\n"
;
print $out join( "\n",
"TYPEMAP\n",
join("\n", @decl),
"\n",
"INPUT\n",
join("\n", @input),
"\n",
"OUTPUT\n",
join("\n", @output),
"\n",
);
close $out;
}