static void
perl_pref_cb(const char *name, PurplePrefType type, gconstpointer value,
gpointer data)
{
PurplePerlPrefsHandler *handler = data;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVpv(name, 0)));
XPUSHs(sv_2mortal(newSViv(type)));
switch(type) {
case PURPLE_PREF_INT:
XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(value))));
break;
case PURPLE_PREF_BOOLEAN:
XPUSHs((GPOINTER_TO_INT(value) == FALSE) ? &PL_sv_no : &PL_sv_yes);
break;
case PURPLE_PREF_STRING:
case PURPLE_PREF_PATH:
XPUSHs(sv_2mortal(newSVGChar(value)));
break;
case PURPLE_PREF_STRING_LIST:
case PURPLE_PREF_PATH_LIST:
{
AV* av = newAV();
const GList *l = value;
/* Append stuff backward to preserve order */
while (l && l->next) l = l->next;
while (l) {
av_push(av, sv_2mortal(newSVGChar(l->data)));
l = l->prev;
}
XPUSHs(sv_2mortal(newRV_noinc((SV *) av)));
} break;
default:
case PURPLE_PREF_NONE:
XPUSHs(&PL_sv_undef);
break;
}
XPUSHs((SV *)handler->data);
PUTBACK;
call_sv(handler->callback, G_EVAL | G_VOID | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl prefs callback function exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
PUTBACK;
FREETMPS;
LEAVE;
}
static SV *
newSVGtkStockItem (GtkStockItem * item)
{
HV * hv = newHV();
gperl_hv_take_sv_s (hv, "stock_id", newSVGChar (item->stock_id));
gperl_hv_take_sv_s (hv, "label", newSVGChar (item->label));
gperl_hv_take_sv_s (hv, "modifier", newSVGdkModifierType (item->modifier));
gperl_hv_take_sv_s (hv, "keyval", newSVuv (item->keyval));
if (item->translation_domain)
gperl_hv_take_sv_s (hv, "translation_domain", newSVGChar (item->translation_domain));
return newRV_noinc ((SV *) hv);
}
static void
gtk2perl_cell_layout_add_attribute (GtkCellLayout *cell_layout,
GtkCellRenderer *cell,
const gchar *attribute,
gint column)
{
GET_METHOD_OR_DIE (cell_layout, "ADD_ATTRIBUTE");
{
PREP (cell_layout);
XPUSHs (sv_2mortal (newSVGtkCellRenderer (cell)));
XPUSHs (sv_2mortal (newSVGChar (attribute)));
XPUSHs (sv_2mortal (newSViv (column)));
CALL;
FINISH;
}
}
static SV *
arg_to_sv (GIArgument * arg,
GITypeInfo * info,
GITransfer transfer,
GPerlI11nInvocationInfo *iinfo)
{
GITypeTag tag = g_type_info_get_tag (info);
gboolean own = transfer >= GI_TRANSFER_CONTAINER;
dwarn (" arg_to_sv: info %p with type tag %d (%s)\n",
info, tag, g_type_tag_to_string (tag));
switch (tag) {
case GI_TYPE_TAG_VOID:
{
SV *sv = callback_data_to_sv (arg->v_pointer, iinfo);
dwarn (" argument with no type information -> %s\n",
sv ? "callback data" : "undef");
return sv ? SvREFCNT_inc (sv) : &PL_sv_undef;
}
case GI_TYPE_TAG_BOOLEAN:
return boolSV (arg->v_boolean);
case GI_TYPE_TAG_INT8:
return newSViv (arg->v_int8);
case GI_TYPE_TAG_UINT8:
return newSVuv (arg->v_uint8);
case GI_TYPE_TAG_INT16:
return newSViv (arg->v_int16);
case GI_TYPE_TAG_UINT16:
return newSVuv (arg->v_uint16);
case GI_TYPE_TAG_INT32:
return newSViv (arg->v_int32);
case GI_TYPE_TAG_UINT32:
return newSVuv (arg->v_uint32);
case GI_TYPE_TAG_INT64:
return newSVGInt64 (arg->v_int64);
case GI_TYPE_TAG_UINT64:
return newSVGUInt64 (arg->v_uint64);
case GI_TYPE_TAG_FLOAT:
return newSVnv (arg->v_float);
case GI_TYPE_TAG_DOUBLE:
return newSVnv (arg->v_double);
case GI_TYPE_TAG_UNICHAR:
{
SV *sv;
gchar buffer[6];
gint length = g_unichar_to_utf8 (arg->v_uint32, buffer);
sv = newSVpv (buffer, length);
SvUTF8_on (sv);
return sv;
}
case GI_TYPE_TAG_GTYPE: {
/* GType == gsize */
const char *package = gperl_package_from_type (arg->v_size);
if (!package)
package = g_type_name (arg->v_size);
return newSVpv (package, PL_na);
}
case GI_TYPE_TAG_ARRAY:
return array_to_sv (info, arg->v_pointer, transfer, iinfo);
case GI_TYPE_TAG_INTERFACE:
return interface_to_sv (info, arg, own, iinfo);
case GI_TYPE_TAG_GLIST:
case GI_TYPE_TAG_GSLIST:
return glist_to_sv (info, arg->v_pointer, transfer);
case GI_TYPE_TAG_GHASH:
return ghash_to_sv (info, arg->v_pointer, transfer);
case GI_TYPE_TAG_ERROR:
ccroak ("FIXME - GI_TYPE_TAG_ERROR");
break;
case GI_TYPE_TAG_UTF8:
{
SV *sv = newSVGChar (arg->v_string);
if (own)
g_free (arg->v_string);
return sv;
}
case GI_TYPE_TAG_FILENAME:
{
SV *sv = newSVpv (arg->v_string, PL_na);
if (own)
g_free (arg->v_string);
return sv;
}
default:
ccroak ("Unhandled info tag %d in arg_to_sv", tag);
}
return NULL;
}
