use strict;
use File::Spec;
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
PerlLibzmq2_mg_free(pTHX_ SV * const sv, MAGIC *const mg ) {
PERL_UNUSED_VAR(sv);
Safefree(mg->mg_ptr);
return 0;
}
STATIC_INLINE
int
PerlLibzmq2_mg_dup(pTHX_ MAGIC* const mg, CLONE_PARAMS* const param) {
PERL_UNUSED_VAR(mg);
PERL_UNUSED_VAR(param);
return 0;
}
EOM
open my $src, '<', "xs/perl_libzmq2.xs";
my @perl_types = qw(
ZMQ::LibZMQ2::Context
ZMQ::LibZMQ2::Socket
ZMQ::LibZMQ2::Message
);
foreach my $perl_type (@perl_types) {
my $c_type = $perl_type;
$c_type =~ s/::/_/g;
$c_type =~ s/^ZMQ_LibZMQ2/PerlLibzmq2/;
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);
seek ($src, 0, 0);
while (<$src>) {
$has_free++ if /^${c_type}_mg_free\b/;
$has_dup++ if /^${c_type}_mg_dup\b/;
}
my $free = $has_free ? "${c_type}_mg_free" : "PerlLibzmq2_mg_free";
my $dup = $has_dup ? "${c_type}_mg_dup" : "PerlLibzmq2_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
}
}
sub write_typemap {
my $file = shift;
my @types = qw(
Context
Socket
Message
);
open( my $out, '>', $file ) or
die "Could not open $file for writing: $!";
my (@decl, @input, @output);
push @decl, "uint64_t T_UV";
push @decl, "int64_t T_IV";
foreach my $type (@types) {
push @decl, "PerlLibzmq2_$type * T_ZMQ_OBJECT";
}
my $closed_error = "\${ \$type =~ /Socket/ ? \\'ENOTSOCK' : \\'EFAULT'}";
my $ptrless_code = "\${ (my \$ptype = \$type) =~ s/\\s*\\*\$//; \\\$ptype}";
my $ptype_code = "\${ (my \$ptype = \$type) =~ s/^PerlLibzmq2_(\\S+)(?:\\s*\\*)/ZMQ::LibZMQ2::\$1/; \\\$ptype}";
push @input, <<EOM;
T_ZMQ_OBJECT
{
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 */
PerlLibzmq2_set_bang( aTHX_ $closed_error );
XSRETURN_EMPTY;
}
}
mg = ${ptrless_code}_mg_find(aTHX_ SvRV(\$arg), &${ptrless_code}_vtbl);
if (mg) {
\$var = (\$type) mg->mg_ptr;
}
if (\$var == NULL)
croak(\\"Invalid $ptype_code object (perhaps you've already freed it?)\\");
}
EOM
push @output, <<EOM;
T_ZMQ_OBJECT
{
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 = \\"$ptype_code\\";
/* 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, &${ptrless_code}_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;
}