view release on metacpan or  search on metacpan

Gtk/GtkTypes.c  view on Meta::CPAN

		hv_store(h, "_gtk", 4, s, 0);
		dump_object ("Creating new 1", (SV*)h, object);
		result = newRV((SV*)h);
		dump_object ("Creating new 2", (SV*)h, object);
		/*if (!GTK_OBJECT_FLOATING(object))*/
			RegisterGtkObject((SV*)h, object);
		/*SvREFCNT_dec(h);*/
		dump_object ("Creating new 3", (SV*)h, object);
		/*if (!GTK_OBJECT_FLOATING(object))*/
			gtk_object_ref(object);
		dump_object ("Creating new 4", (SV*)h, object);
		gtk_signal_connect(object, "destroy", (GtkSignalFunc)DestroyGtkObject, (gpointer)h);
		if (gtk_object_get_data(object, "_perl"))
			croak("Object %p halready has data\n", object);
		gtk_object_set_data_full(object, "_perl", h, FreeGtkObject);
		sv_bless(result, gv_stashpv(classname, FALSE));
		dump_object ("Creating new 5", (SV*)h, object);
		SvREFCNT_dec(h);
		GCAfterTimeout();
		dump_object ("Creating new", (SV*)h, object);
	}
	return result;
}

GtkObject * SvGtkObjectRef(SV * o, char * name)
{
	HV * q;
	SV ** r;
	if (!o || !SvROK(o) || !(q=(HV*)SvRV(o)) || (SvTYPE(q) != SVt_PVHV))
		return 0;
	if (name && !PerlGtk_sv_derived_from(o, name))
		croak("variable is not of type %s", name);
	r = hv_fetch(q, "_gtk", 4, 0);
	if (!r || !SvIV(*r))
		croak("variable is damaged %s", name);
	dump_object ("Access pointer", (SV*)q, (GtkObject*)SvIV(*r));
	return (GtkObject*)SvIV(*r);
}

void pgtk_menu_callback (GtkWidget *widget, gpointer user_data)
{
	SV * handler = (SV*)user_data;
	int i;
	dSP;

	PUSHMARK(SP);
	
	if (SvRV(handler) && (SvTYPE(SvRV(handler)) == SVt_PVAV)) {
		AV * args = (AV*)SvRV(handler);
		handler = *av_fetch(args, 0, 0);
		for(i=1;i<=av_len(args);i++)
			XPUSHs(sv_2mortal(newSVsv(*av_fetch(args,i,0))));
	}

	XPUSHs(sv_2mortal(newSVGtkObjectRef(GTK_OBJECT(widget), 0)));
	PUTBACK;

	i = perl_call_sv(handler, G_DISCARD);
}

GtkMenuEntry * SvGtkMenuEntry(SV * data, GtkMenuEntry * e)
{
	dTHR;

	HV * h;
	SV ** s;

	if ((!data) || (!SvOK(data)) || (!SvRV(data)) || (SvTYPE(SvRV(data)) != SVt_PVHV))
		return 0;
	
	if (!e)
		e = pgtk_alloc_temp(sizeof(GtkMenuEntry));

	h = (HV*)SvRV(data);
	
	if ((s=hv_fetch(h, "path", 4, 0)) && SvOK(*s))
		e->path = SvPV(*s,PL_na);
	else
		e->path = 0;
		/*croak("menu entry must contain path");*/
	if ((s=hv_fetch(h, "accelerator", 11, 0)) && SvOK(*s))
		e->accelerator = SvPV(*s, PL_na);
	else
		e->accelerator = 0;
		/*croak("menu entry must contain accelerator");*/
	if ((s=hv_fetch(h, "widget", 6, 0)) && SvOK(*s))
		e->widget =  (s && SvOK(*s)) ? GTK_WIDGET(SvGtkObjectRef(*s, "Gtk::Widget")) : NULL;
	else
		e->widget = 0;
		/*croak("menu entry must contain widget");*/
	if ((s=hv_fetch(h, "callback", 8, 0)) && SvOK(*s)) {
		e->callback = pgtk_menu_callback;
		e->callback_data = newSVsv(*s);
	}
	else {
		e->callback = 0;
		e->callback_data = 0;
		/*croak("menu entry must contain callback");*/
	}

	return e;
}

SV * newSVGtkMenuEntry(GtkMenuEntry * e)
{
	dTHR;

	HV * h;
	SV * r;
	
	if (!e)
		return &PL_sv_undef;
		
	h = newHV();
	r = newRV((SV*)h);
	SvREFCNT_dec(h);
	
	hv_store(h, "path", 4, e->path ? newSVpv(e->path,0) : newSVsv(&PL_sv_undef), 0);
	hv_store(h, "accelerator", 11, e->accelerator ? newSVpv(e->accelerator,0) : newSVsv(&PL_sv_undef), 0);
	hv_store(h, "widget", 6, e->widget ? newSVGtkObjectRef(GTK_OBJECT(e->widget), 0) : newSVsv(&PL_sv_undef), 0);
	hv_store(h, "callback", 8, 
		((e->callback == pgtk_menu_callback) && e->callback_data) ?
		newSVsv(e->callback_data) :
		newSVsv(&PL_sv_undef)
		, 0);
	
	return r;
}

SV * newSVGtkSelectionDataRef(GtkSelectionData * w) { return newSVMiscRef(w, "Gtk::SelectionData",0); }
GtkSelectionData * SvGtkSelectionDataRef(SV * data) { return SvMiscRef(data, "Gtk::SelectionData"); }

GtkType FindArgumentTypeWithObject(GtkObject * object, SV * name, GtkArg * result) {
	return FindArgumentTypeWithClass(object->klass, name, result);
}

GtkType FindArgumentTypeWithClass(GtkObjectClass * klass, SV * name, GtkArg * result) {
	dTHR;
	char * argname = SvPV(name, PL_na);
	GtkType t = GTK_TYPE_INVALID;

	/* Strip the ticklish dash:
	
	   -foo => foo
	 */
	if (argname[0] == '-')
		argname++;
	
	/* Convert Perl naming convention to Gtk:
	 
	   Gtk::... => Gtk...
	 */
	if (strncmp(argname, "Gtk::", 5) == 0) {
		SV * work = sv_2mortal(newSVpv("Gtk", 3)); 
		sv_catpv(work, argname+5);
		argname = SvPV(work, PL_na);
	}

	/* Fix something that's hard to deal with, otherwise:
	
	   signal::... => GtkObject::signal:... 
	 */
	if (strncmp(argname, "signal::", 8) ==0) {
		SV * work = sv_2mortal(newSVpv("GtkObject::", 11));