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