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