/* -*- mode: c; indent-tabs-mode: t; c-basic-offset: 8; -*- */
static void _prepare_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo,
                                           GICallableInfo *info,
                                           gpointer *args);
static void _clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo);
static void _fill_ffi_return_value (GITypeInfo *return_info,
                                    gpointer resp,
                                    GIArgument *arg);
static void
invoke_perl_code (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
{
        GPerlI11nPerlCallbackInfo *info;
        GICallableInfo *cb_interface;
        GPerlI11nPerlInvocationInfo iinfo;
        guint args_offset = 0, i;
        guint in_inout;
        guint n_return_values;
        I32 n_returned;
        I32 context;
        SV *first_sv = NULL, *last_sv = NULL;
        dGPERL_CALLBACK_MARSHAL_SP;
        PERL_UNUSED_VAR (cif);
        /* unwrap callback info struct from userdata */
        info = (GPerlI11nPerlCallbackInfo *) userdata;
        cb_interface = (GICallableInfo *) info->interface;
        /* set perl context */
        GPERL_CALLBACK_MARSHAL_INIT (info);
        ENTER;
        SAVETMPS;
        _prepare_perl_invocation_info (&iinfo, cb_interface, args);
        PUSHMARK (SP);
        if (info->args_converter) {
                /* if we are given an args converter, we will call it directly
                 * after we pushed the original args onto the stack.  we then
                 * want to invoke the Perl code with whatever the args
                 * converter returned.  to achieve this, we do a double
                 * PUSHMARK, which puts on the markstack two pointers to the
                 * same place on the stack.  after the args converter returns,
                 * the markstack pointer is decremented, and the invocation of
                 * the normal Perl code then sees the other entry we put on the
                 * markstack. */
                PUSHMARK (SP);
        }
        /* convert the implicit instance argument and push the first SV onto
         * the stack; depending on the "swap" setting, this might be the
         * instance or the user data.  this is only relevant for signals. */
        if (iinfo.base.is_signal) {
                SV *instance_sv, *data_sv;
                args_offset = 1;
                instance_sv = SAVED_STACK_SV (instance_pointer_to_sv (
                                                cb_interface,
                                                CAST_RAW (args[0], gpointer)));
                data_sv = info->data ? SvREFCNT_inc (info->data) : NULL;
                first_sv = info->swap_data ? data_sv     : instance_sv;
                last_sv  = info->swap_data ? instance_sv : data_sv;
                dwarn ("info->data = %p, info->swap_data = %d\n",
                       info->data, info->swap_data);
                dwarn ("instance = %p, data = %p, first = %p, last = %p\n",
                       instance_sv, data_sv, first_sv, last_sv);
                if (first_sv)
                        XPUSHs (sv_2mortal (first_sv));
        }
        /* find arguments; use type information from interface to find in and
         * in-out args and their types, count in-out and out args, and find
         * suitable converters; push in and in-out arguments onto the perl
         * stack */
        in_inout = 0;
        for (i = 0; i < iinfo.base.n_args; i++) {
                GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]);
                GITypeInfo *arg_type = &(iinfo.base.arg_types[i]);
                GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
                GIDirection direction = g_arg_info_get_direction (arg_info);
                iinfo.base.current_pos = i;
                dwarn ("arg %d: info = %p (%s)\n",
                       i, arg_info, g_base_info_get_name (arg_info));
                dwarn ("  dir = %d, is retval = %d, is optional = %d, may be null = %d, transfer = %d\n",
                       direction,
                       g_arg_info_is_return_value (arg_info),
                       g_arg_info_is_optional (arg_info),
                       g_arg_info_may_be_null (arg_info),
                       transfer);
                dwarn ("  arg type = %p, is pointer = %d, tag = %d (%s)\n",
                       arg_type,
                       g_type_info_is_pointer (arg_type),
                       g_type_info_get_tag (arg_type),
                       g_type_tag_to_string (g_type_info_get_tag (arg_type)));
                if (direction == GI_DIRECTION_IN ||
                    direction == GI_DIRECTION_INOUT)
                {
                        gpointer raw;
                        GIArgument arg;
                        SV *sv;
                        /* If the arg is in-out, then the ffi arg is a pointer
                         * to a pointer to a value, so we need to dereference
                         * it once. */
                        raw = direction == GI_DIRECTION_INOUT
                                ? *((gpointer *) args[i+args_offset])
                                : args[i+args_offset];
                        raw_to_arg (raw, &arg, arg_type);
                        sv = SAVED_STACK_SV (arg_to_sv (&arg,
                                                        arg_type,
                                                        transfer,
                                                        GPERL_I11N_MEMORY_SCOPE_IRRELEVANT,
                                                        &iinfo.base));
                        /* If arg_to_sv returns NULL, we take that as 'skip
                         * this argument'; happens for GDestroyNotify, for
                         * example. */
                        if (sv)
                                XPUSHs (sv_2mortal (sv));
                }
                if (direction == GI_DIRECTION_INOUT ||
                    direction == GI_DIRECTION_OUT)
                {
                        in_inout++;
                }
        }
        /* push the last SV onto the stack; this might be the user data or the
         * instance.  this is only relevant for signals. */
        if (last_sv)
                XPUSHs (sv_2mortal (last_sv));
        PUTBACK;
        /* invoke the args converter with the original args on the stack.
         * since we created two identical entries on the markstack, the
         * call_method or call_sv below will invoke the Perl code with whatever
         * the args converter returned. */
        if (info->args_converter) {
                call_sv (info->args_converter, G_ARRAY);
                SPAGAIN;
        }
        /* determine suitable Perl call context */
        context = G_VOID | G_DISCARD;
        if (iinfo.base.has_return_value) {
                context = in_inout > 0
                  ? G_ARRAY
                  : G_SCALAR;
        } else {
                if (in_inout == 1) {
                        context = G_SCALAR;
                } else if (in_inout > 1) {
                        context = G_ARRAY;
                }
        }
        /* do the call, demand #in-out+#out+#return-value return values */
        n_return_values = iinfo.base.has_return_value
          ? in_inout + 1
          : in_inout;
        n_returned = info->sub_name
                ? call_method (info->sub_name, context)
                : call_sv (info->code, context);
        if (n_return_values != 0 && (n_returned < 0 || ((guint) n_returned) != n_return_values)) {
                ccroak ("callback returned %d values "
                        "but is supposed to return %u values",
                        n_returned, n_return_values);
        }
        /* call-scoped callback infos are freed by
         * Glib::Object::Introspection::_FuncWrapper::DESTROY */
        SPAGAIN;
        /* convert in-out and out values and stuff them back into args */
        if (in_inout > 0) {
                SV **returned_values;
                int out_index;
                returned_values = g_new0 (SV *, in_inout);
                /* pop scalars off the stack and put them into the array;
                 * reverse the order since POPs pops items off of the end of
                 * the stack. */
                for (i = 0; i < in_inout; i++) {
                        returned_values[in_inout - i - 1] = POPs;
                }
                out_index = 0;
                for (i = 0; i < iinfo.base.n_args; i++) {
                        GIArgInfo *arg_info = &(iinfo.base.arg_infos[i]);
                        GITypeInfo *arg_type = &(iinfo.base.arg_types[i]);
                        GIDirection direction = g_arg_info_get_direction (arg_info);
                        gpointer out_pointer = * (gpointer *) args[i+args_offset];
                        if (!out_pointer) {
                                dwarn ("skipping out arg %d\n", i);
                                continue;
                        }
                        if (direction == GI_DIRECTION_INOUT ||
                            direction == GI_DIRECTION_OUT)
                        {
                                GIArgument tmp_arg;
                                GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
                                /* g_arg_info_may_be_null (arg_info) is not
                                 * appropriate here as it describes whether the
                                 * out/inout arg itself may be NULL.  But we're
                                 * asking here whether it is OK store NULL
                                 * inside the out/inout arg.  This information
                                 * does not seem to be present in the typelib
                                 * (nor is there an annotation for it). */
                                gboolean may_be_null = TRUE;
                                gboolean is_caller_allocated = g_arg_info_is_caller_allocates (arg_info);
                                dwarn ("out/inout arg, pos = %d, is_caller_allocated = %d\n",
                                       i, is_caller_allocated);
                                if (is_caller_allocated) {
                                        tmp_arg.v_pointer = out_pointer;
                                }
                                sv_to_arg (returned_values[out_index], &tmp_arg,
                                           arg_info, arg_type,
                                           transfer, may_be_null, &iinfo.base);
                                if (!is_caller_allocated) {
                                        arg_to_raw (&tmp_arg, out_pointer, arg_type);
                                }
                                out_index++;
                        }
                }
                g_free (returned_values);
        }
        /* store return value in resp, if any */
        if (iinfo.base.has_return_value) {
                GIArgument arg;
                GITypeInfo *type_info;
                GITransfer transfer;
                gboolean may_be_null;
                type_info = &iinfo.base.return_type_info;
                transfer = iinfo.base.return_type_transfer;
                may_be_null = g_callable_info_may_return_null (cb_interface); /* FIXME */
                dwarn ("return value: type = %p\n", type_info);
                dwarn ("  is pointer = %d, tag = %d (%s), transfer = %d\n",
                       g_type_info_is_pointer (type_info),
                       g_type_info_get_tag (type_info),
                       g_type_tag_to_string (g_type_info_get_tag (type_info)),
                       transfer);
                sv_to_arg (POPs, &arg, NULL, type_info,
                           transfer, may_be_null, &iinfo.base);
                _fill_ffi_return_value (type_info, resp, &arg);
        }
        PUTBACK;
        _clear_perl_invocation_info (&iinfo);
        FREETMPS;
        LEAVE;
        /* FIXME: We can't just free everything here because ffi will use parts
         * of this after we've returned.
         *
         * if (info->free_after_use) {
         *      release_callback (info);
         * }
         *
         * Gjs uses a global list of callback infos instead and periodically
         * frees unused ones.
         */
}
/* ------------------------------------------------------------------------- */
#if GI_CHECK_VERSION (1, 33, 10)
static void
invoke_perl_signal_handler (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
{
        GClosure *closure = CAST_RAW (args[0], GClosure*);
        GValue *return_value = CAST_RAW (args[1], GValue*);
        guint n_param_values = CAST_RAW (args[2], guint);
        const GValue *param_values = CAST_RAW (args[3], const GValue*);
        gpointer invocation_hint = CAST_RAW (args[4], gpointer);
        gpointer marshal_data = CAST_RAW (args[5], gpointer);
        GPerlI11nPerlSignalInfo *signal_info = userdata;
        GPerlClosure *perl_closure = (GPerlClosure *) closure;
        GPerlI11nPerlCallbackInfo *cb_info;
        GCClosure c_closure;
        PERL_UNUSED_VAR (cif);
        PERL_UNUSED_VAR (resp);
        PERL_UNUSED_VAR (marshal_data);
        dwarn ("%s, n_args = %d\n",
               g_base_info_get_name (signal_info->interface),
               g_callable_info_get_n_args (signal_info->interface));
        cb_info = create_perl_callback_closure (signal_info->interface,
                                                perl_closure->callback);
        attach_perl_callback_data (cb_info, perl_closure->data);
        cb_info->swap_data = GPERL_CLOSURE_SWAP_DATA (perl_closure);
        if (signal_info->args_converter)
                cb_info->args_converter = SvREFCNT_inc (signal_info->args_converter);
        c_closure.closure = *closure;
#if GI_CHECK_VERSION (1, 72, 0)
        c_closure.callback = g_callable_info_get_closure_native_address (signal_info->interface, cb_info->closure);
#else
        c_closure.callback = cb_info->closure;
#endif
        /* If marshal_data is non-NULL, gi_cclosure_marshal_generic uses it as
         * the callback.  Hence we pass NULL so that c_closure.callback is
         * used. */
        gi_cclosure_marshal_generic ((GClosure *) &c_closure,
                                     return_value,
                                     n_param_values, param_values,
                                     invocation_hint,
                                     NULL /* instead of marshal_data */);
        release_perl_callback (cb_info);
}
#endif
/* -------------------------------------------------------------------------- */
static void
_prepare_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo,
                               GICallableInfo *info,
                               gpointer *args)
{
        guint i;
        prepare_invocation_info ((GPerlI11nInvocationInfo *) iinfo, info);
        dwarn ("%s, n_args = %d\n",
               g_base_info_get_name (info),
               g_callable_info_get_n_args (info));
        /* When invoking Perl code, we currently always use a complete
         * description of the callable (from a record field or some callback
         * typedef) for functions, vfuncs and calllbacks.  This implies that
         * there is no implicit invocant; it always appears explicitly in the
         * arg list.  For signals, however, the invocant is implicit. */
        /* FIXME: 'throws'? */
        /* Find array length arguments and store their value in aux_args so
         * that array_to_sv can later fetch them. */
        for (i = 0 ; i < iinfo->base.n_args ; i++) {
                GITypeInfo *arg_type = &(iinfo->base.arg_types[i]);
                GITypeTag arg_tag = g_type_info_get_tag (arg_type);
                if (arg_tag == GI_TYPE_TAG_ARRAY) {
                        gint pos = g_type_info_get_array_length (arg_type);
                        if (pos >= 0) {
                                GITypeInfo *length_arg_type;
                                guint args_pos = iinfo->base.is_signal ? pos+1 : pos;
                                length_arg_type = &(iinfo->base.arg_types[pos]);
                                raw_to_arg (args[args_pos], &iinfo->base.aux_args[pos], length_arg_type);
                                dwarn ("  pos %d is array length => %"G_GSIZE_FORMAT"\n",
                                       pos, iinfo->base.aux_args[pos].v_size);
                        }
                }
        }
}
static void
_clear_perl_invocation_info (GPerlI11nPerlInvocationInfo *iinfo)
{
        clear_invocation_info ((GPerlI11nInvocationInfo *) iinfo);
}
/* ------------------------------------------------------------------------- */
/* Copied from pygobject's pygi-closure.c. */
static void
_fill_ffi_return_value (GITypeInfo *return_info,
                        gpointer resp,
                        GIArgument *arg)
{
        if (!resp)
                return;
        switch (g_type_info_get_tag (return_info)) {
            case GI_TYPE_TAG_BOOLEAN:
                *((ffi_sarg *) resp) = arg->v_boolean;
                break;
            case GI_TYPE_TAG_INT8:
                *((ffi_sarg *) resp) = arg->v_int8;
                break;
            case GI_TYPE_TAG_UINT8:
                *((ffi_arg *) resp) = arg->v_uint8;
                break;
            case GI_TYPE_TAG_INT16:
                *((ffi_sarg *) resp) = arg->v_int16;
                break;
            case GI_TYPE_TAG_UINT16:
                *((ffi_arg *) resp) = arg->v_uint16;
                break;
            case GI_TYPE_TAG_INT32:
                *((ffi_sarg *) resp) = arg->v_int32;
                break;
            case GI_TYPE_TAG_UINT32:
                *((ffi_arg *) resp) = arg->v_uint32;
                break;
            case GI_TYPE_TAG_INT64:
                *((ffi_sarg *) resp) = arg->v_int64;
                break;
            case GI_TYPE_TAG_UINT64:
                *((ffi_arg *) resp) = arg->v_uint64;
                break;
            case GI_TYPE_TAG_FLOAT:
                *((gfloat *) resp) = arg->v_float;
                break;
            case GI_TYPE_TAG_DOUBLE:
                *((gdouble *) resp) = arg->v_double;
                break;
            case GI_TYPE_TAG_GTYPE:
                *((ffi_arg *) resp) = arg->v_size;
                break;
            case GI_TYPE_TAG_UNICHAR:
                *((ffi_arg *) resp) = arg->v_uint32;
                break;
            case GI_TYPE_TAG_INTERFACE:
                {
                        GIBaseInfo *interface_info;
                        interface_info = g_type_info_get_interface (return_info);
                        switch (g_base_info_get_type (interface_info)) {
                            case GI_INFO_TYPE_ENUM:
                                *(ffi_sarg *) resp = arg->v_int;
                                break;
                            case GI_INFO_TYPE_FLAGS:
                                *(ffi_arg *) resp = arg->v_uint;
                                break;
                            default:
                                *(ffi_arg *) resp = (ffi_arg) arg->v_pointer;
                                break;
                        }
                        g_base_info_unref (interface_info);
                        break;
                }
            default:
                *(ffi_arg *) resp = (ffi_arg) arg->v_pointer;
                break;
        }
}