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