TDE
/
libtqt-perl
mirror of https://mirror.git.trinitydesktop.org/gitea/TDE/libtqt-perl
0
0
Fork 0
Code Issues Releases Wiki Activity
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '3900173dc8'
${ noResults }
libtqt-perl/PerlTQt/TQt.xs

2199 lines
55 KiB
Raw Blame History

#include <stdio.h>
#include <ntqglobal.h>
#include <ntqstring.h>
#include <ntqapplication.h>
#include <ntqmetaobject.h>
#include <private/qucomextra_p.h>
#include "smoke.h"
#undef DEBUG
#ifndef _GNU_SOURCE
#define _GNU_SOURCE
#endif
#ifndef __USE_POSIX
#define __USE_POSIX
#endif
#ifndef __USE_XOPEN
#define __USE_XOPEN
#endif
#ifdef _BOOL
#define HAS_BOOL
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifndef TQT_VERSION_STR
#define TQT_VERSION_STR "Unknown"
#endif
#undef free
#undef malloc
#include "marshall.h"
#include "perlqt.h"
#include "smokeperl.h"
#ifndef IN_BYTES
#define IN_BYTES IN_BYTE
#endif
#ifndef IN_LOCALE
#define IN_LOCALE (PL_curcop->op_private & HINT_LOCALE)
#endif
extern Smoke *qt_Smoke;
extern void init_qt_Smoke();
int do_debug = qtdb_none;
HV *pointer_map = 0;
SV *sv_qapp = 0;
int object_count = 0;
void *_current_object = 0; // TODO: ask myself if this is stupid
bool temporary_virtual_function_success = false;
static TQAsciiDict<Smoke::Index> *methcache = 0;
static TQAsciiDict<Smoke::Index> *classcache = 0;
SV *sv_this = 0;
Smoke::Index _current_object_class = 0;
Smoke::Index _current_method = 0;
/*
* Type handling by moc is simple.
*
* If the type name matches /^(?:const\s+)?\Q$types\E&?$/, use the
* static_TQUType, where $types is join('|', qw(bool int double char* TQString);
*
* Everything else is passed as a pointer! There are types which aren't
* Smoke::tf_ptr but will have to be passed as a pointer. Make sure to keep
* track of what's what.
*/
/*
* Simply using typeids isn't enough for signals/slots. It will be possible
* to declare signals and slots which use arguments which can't all be
* found in a single smoke object. Instead, we need to store smoke => typeid
* pairs. We also need additional informatation, such as whether we're passing
* a pointer to the union element.
*/
enum MocArgumentType {
xmoc_ptr,
xmoc_bool,
xmoc_int,
xmoc_double,
xmoc_charstar,
xmoc_TQString
};
struct MocArgument {
// smoke object and associated typeid
SmokeType st;
MocArgumentType argType;
};
extern TypeHandler TQt_handlers[];
void install_handlers(TypeHandler *);
void *sv_to_ptr(SV *sv) { // ptr on success, null on fail
smokeperl_object *o = sv_obj_info(sv);
return o ? o->ptr : 0;
}
bool isTQObject(Smoke *smoke, Smoke::Index classId) {
if(!strcmp(smoke->classes[classId].className, "TQObject"))
return true;
for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents;
*p;
p++) {
if(isTQObject(smoke, *p))
return true;
}
return false;
}
int isDerivedFrom(Smoke *smoke, Smoke::Index classId, Smoke::Index baseId, int cnt) {
if(classId == baseId)
return cnt;
cnt++;
for(Smoke::Index *p = smoke->inheritanceList + smoke->classes[classId].parents;
*p;
p++) {
if(isDerivedFrom(smoke, *p, baseId, cnt) != -1)
return cnt;
}
return -1;
}
int isDerivedFrom(Smoke *smoke, const char *className, const char *baseClassName, int cnt) {
if(!smoke || !className || !baseClassName)
return -1;
Smoke::Index idClass = smoke->idClass(className);
Smoke::Index idBase = smoke->idClass(baseClassName);
return isDerivedFrom(smoke, idClass, idBase, cnt);
}
SV *getPointerObject(void *ptr) {
HV *hv = pointer_map;
SV *keysv = newSViv((IV)ptr);
STRLEN len;
char *key = SvPV(keysv, len);
SV **svp = hv_fetch(hv, key, len, 0);
if(!svp){
SvREFCNT_dec(keysv);
return 0;
}
if(!SvOK(*svp)){
hv_delete(hv, key, len, G_DISCARD);
SvREFCNT_dec(keysv);
return 0;
}
return *svp;
}
void unmapPointer(smokeperl_object *o, Smoke::Index classId, void *lastptr) {
HV *hv = pointer_map;
void *ptr = o->smoke->cast(o->ptr, o->classId, classId);
if(ptr != lastptr) {
lastptr = ptr;
SV *keysv = newSViv((IV)ptr);
STRLEN len;
char *key = SvPV(keysv, len);
if(hv_exists(hv, key, len))
hv_delete(hv, key, len, G_DISCARD);
SvREFCNT_dec(keysv);
}
for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents;
*i;
i++) {
unmapPointer(o, *i, lastptr);
}
}
// Store pointer in pointer_map hash : "pointer_to_TQt_object" => weak ref to associated Perl object
// Recurse to store it also as casted to its parent classes.
void mapPointer(SV *obj, smokeperl_object *o, HV *hv, Smoke::Index classId, void *lastptr) {
void *ptr = o->smoke->cast(o->ptr, o->classId, classId);
if(ptr != lastptr) {
lastptr = ptr;
SV *keysv = newSViv((IV)ptr);
STRLEN len;
char *key = SvPV(keysv, len);
SV *rv = newSVsv(obj);
sv_rvweaken(rv); // weak reference!
hv_store(hv, key, len, rv, 0);
SvREFCNT_dec(keysv);
}
for(Smoke::Index *i = o->smoke->inheritanceList + o->smoke->classes[classId].parents;
*i;
i++) {
mapPointer(obj, o, hv, *i, lastptr);
}
}
Marshall::HandlerFn getMarshallFn(const SmokeType &type);
class VirtualMethodReturnValue : public Marshall {
Smoke *_smoke;
Smoke::Index _method;
Smoke::Stack _stack;
SmokeType _st;
SV *_retval;
public:
const Smoke::Method &method() { return _smoke->methods[_method]; }
SmokeType type() { return _st; }
Marshall::Action action() { return Marshall::FromSV; }
Smoke::StackItem &item() { return _stack[0]; }
SV *var() { return _retval; }
void unsupported() {
croak("Cannot handle '%s' as return-type of virtual method %s::%s",
type().name(),
_smoke->className(method().classId),
_smoke->methodNames[method().name]);
}
Smoke *smoke() { return _smoke; }
void next() {}
bool cleanup() { return false; }
VirtualMethodReturnValue(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *retval) :
_smoke(smoke), _method(meth), _stack(stack), _retval(retval) {
_st.set(_smoke, method().ret);
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
}
};
class VirtualMethodCall : public Marshall {
Smoke *_smoke;
Smoke::Index _method;
Smoke::Stack _stack;
GV *_gv;
int _cur;
Smoke::Index *_args;
SV **_sp;
bool _called;
SV *_savethis;
public:
SmokeType type() { return SmokeType(_smoke, _args[_cur]); }
Marshall::Action action() { return Marshall::ToSV; }
Smoke::StackItem &item() { return _stack[_cur + 1]; }
SV *var() { return _sp[_cur]; }
const Smoke::Method &method() { return _smoke->methods[_method]; }
void unsupported() {
croak("Cannot handle '%s' as argument of virtual method %s::%s",
type().name(),
_smoke->className(method().classId),
_smoke->methodNames[method().name]);
}
Smoke *smoke() { return _smoke; }
void callMethod() {
dSP;
if(_called) return;
_called = true;
SP = _sp + method().numArgs - 1;
PUTBACK;
int count = call_sv((SV*)GvCV(_gv), G_SCALAR);
SPAGAIN;
VirtualMethodReturnValue r(_smoke, _method, _stack, POPs);
PUTBACK;
FREETMPS;
LEAVE;
}
void next() {
int oldcur = _cur;
_cur++;
while(!_called && _cur < method().numArgs) {
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
_cur++;
}
callMethod();
_cur = oldcur;
}
bool cleanup() { return false; } // is this right?
VirtualMethodCall(Smoke *smoke, Smoke::Index meth, Smoke::Stack stack, SV *obj, GV *gv) :
_smoke(smoke), _method(meth), _stack(stack), _gv(gv), _cur(-1), _sp(0), _called(false) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, method().numArgs);
_savethis = sv_this;
sv_this = newSVsv(obj);
_sp = SP + 1;
for(int i = 0; i < method().numArgs; i++)
_sp[i] = sv_newmortal();
_args = _smoke->argumentList + method().args;
}
~VirtualMethodCall() {
SvREFCNT_dec(sv_this);
sv_this = _savethis;
}
};
class MethodReturnValue : public Marshall {
Smoke *_smoke;
Smoke::Index _method;
SV *_retval;
Smoke::Stack _stack;
public:
MethodReturnValue(Smoke *smoke, Smoke::Index method, Smoke::Stack stack, SV *retval) :
_smoke(smoke), _method(method), _retval(retval), _stack(stack) {
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
}
const Smoke::Method &method() { return _smoke->methods[_method]; }
SmokeType type() { return SmokeType(_smoke, method().ret); }
Marshall::Action action() { return Marshall::ToSV; }
Smoke::StackItem &item() { return _stack[0]; }
SV *var() { return _retval; }
void unsupported() {
croak("Cannot handle '%s' as return-type of %s::%s",
type().name(),
_smoke->className(method().classId),
_smoke->methodNames[method().name]);
}
Smoke *smoke() { return _smoke; }
void next() {}
bool cleanup() { return false; }
};
class MethodCall : public Marshall {
int _cur;
Smoke *_smoke;
Smoke::Stack _stack;
Smoke::Index _method;
Smoke::Index *_args;
SV **_sp;
int _items;
SV *_retval;
bool _called;
public:
MethodCall(Smoke *smoke, Smoke::Index method, SV **sp, int items) :
_smoke(smoke), _method(method), _sp(sp), _items(items), _cur(-1), _called(false) {
_args = _smoke->argumentList + _smoke->methods[_method].args;
_items = _smoke->methods[_method].numArgs;
_stack = new Smoke::StackItem[items + 1];
_retval = newSV(0);
}
~MethodCall() {
delete[] _stack;
SvREFCNT_dec(_retval);
}
SmokeType type() { return SmokeType(_smoke, _args[_cur]); }
Marshall::Action action() { return Marshall::FromSV; }
Smoke::StackItem &item() { return _stack[_cur + 1]; }
SV *var() {
if(_cur < 0) return _retval;
SvGETMAGIC(*(_sp + _cur));
return *(_sp + _cur);
}
inline const Smoke::Method &method() { return _smoke->methods[_method]; }
void unsupported() {
croak("Cannot handle '%s' as argument to %s::%s",
type().name(),
_smoke->className(method().classId),
_smoke->methodNames[method().name]);
}
Smoke *smoke() { return _smoke; }
inline void callMethod() {
if(_called) return;
_called = true;
Smoke::ClassFn fn = _smoke->classes[method().classId].classFn;
void *ptr = _smoke->cast(
_current_object,
_current_object_class,
method().classId
);
_items = -1;
(*fn)(method().method, ptr, _stack);
MethodReturnValue r(_smoke, _method, _stack, _retval);
}
void next() {
int oldcur = _cur;
_cur++;
while(!_called && _cur < _items) {
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
_cur++;
}
callMethod();
_cur = oldcur;
}
bool cleanup() { return true; }
};
class UnencapsulatedTQObject : public TQObject {
public:
TQConnectionList *public_receivers(int signal) const { return receivers(signal); }
void public_activate_signal(TQConnectionList *clist, TQUObject *o) { activate_signal(clist, o); }
};
class EmitSignal : public Marshall {
UnencapsulatedTQObject *_qobj;
int _id;
MocArgument *_args;
SV **_sp;
int _items;
int _cur;
Smoke::Stack _stack;
bool _called;
public:
EmitSignal(TQObject *qobj, int id, int items, MocArgument *args, SV **sp) :
_qobj((UnencapsulatedTQObject*)qobj), _id(id), _items(items), _args(args),
_sp(sp), _cur(-1), _called(false) {
_stack = new Smoke::StackItem[_items];
}
~EmitSignal() {
delete[] _stack;
}
const MocArgument &arg() { return _args[_cur]; }
SmokeType type() { return arg().st; }
Marshall::Action action() { return Marshall::FromSV; }
Smoke::StackItem &item() { return _stack[_cur]; }
SV *var() { return _sp[_cur]; }
void unsupported() {
croak("Cannot handle '%s' as signal argument", type().name());
}
Smoke *smoke() { return type().smoke(); }
void emitSignal() {
if(_called) return;
_called = true;
TQConnectionList *clist = _qobj->public_receivers(_id);
if(!clist) return;
TQUObject *o = new TQUObject[_items + 1];
for(int i = 0; i < _items; i++) {
TQUObject *po = o + i + 1;
Smoke::StackItem *si = _stack + i;
switch(_args[i].argType) {
case xmoc_bool:
static_TQUType_bool.set(po, si->s_bool);
break;
case xmoc_int:
static_TQUType_int.set(po, si->s_int);
break;
case xmoc_double:
static_QUType_double.set(po, si->s_double);
break;
case xmoc_charstar:
static_TQUType_charstar.set(po, (char*)si->s_voidp);
break;
case xmoc_TQString:
static_TQUType_TQString.set(po, *(TQString*)si->s_voidp);
break;
default:
{
const SmokeType &t = _args[i].st;
void *p;
switch(t.elem()) {
case Smoke::t_bool:
p = &si->s_bool;
break;
case Smoke::t_char:
p = &si->s_char;
break;
case Smoke::t_uchar:
p = &si->s_uchar;
break;
case Smoke::t_short:
p = &si->s_short;
break;
case Smoke::t_ushort:
p = &si->s_ushort;
break;
case Smoke::t_int:
p = &si->s_int;
break;
case Smoke::t_uint:
p = &si->s_uint;
break;
case Smoke::t_long:
p = &si->s_long;
break;
case Smoke::t_ulong:
p = &si->s_ulong;
break;
case Smoke::t_float:
p = &si->s_float;
break;
case Smoke::t_double:
p = &si->s_double;
break;
case Smoke::t_enum:
{
// allocate a new enum value
Smoke::EnumFn fn = SmokeClass(t).enumFn();
if(!fn) {
warn("Unknown enumeration %s\n", t.name());
p = new int((int)si->s_enum);
break;
}
Smoke::Index id = t.typeId();
(*fn)(Smoke::EnumNew, id, p, si->s_enum);
(*fn)(Smoke::EnumFromLong, id, p, si->s_enum);
// FIXME: MEMORY LEAK
}
break;
case Smoke::t_class:
case Smoke::t_voidp:
p = si->s_voidp;
break;
default:
p = 0;
break;
}
static_TQUType_ptr.set(po, p);
}
}
}
_qobj->public_activate_signal(clist, o);
delete[] o;
}
void next() {
int oldcur = _cur;
_cur++;
while(!_called && _cur < _items) {
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
_cur++;
}
emitSignal();
_cur = oldcur;
}
bool cleanup() { return true; }
};
class InvokeSlot : public Marshall {
TQObject *_qobj;
GV *_gv;
int _items;
MocArgument *_args;
TQUObject *_o;
int _cur;
bool _called;
SV **_sp;
Smoke::Stack _stack;
public:
const MocArgument &arg() { return _args[_cur]; }
SmokeType type() { return arg().st; }
Marshall::Action action() { return Marshall::ToSV; }
Smoke::StackItem &item() { return _stack[_cur]; }
SV *var() { return _sp[_cur]; }
Smoke *smoke() { return type().smoke(); }
bool cleanup() { return false; }
void unsupported() {
croak("Cannot handle '%s' as slot argument\n", type().name());
}
void copyArguments() {
for(int i = 0; i < _items; i++) {
TQUObject *o = _o + i + 1;
switch(_args[i].argType) {
case xmoc_bool:
_stack[i].s_bool = static_TQUType_bool.get(o);
break;
case xmoc_int:
_stack[i].s_int = static_TQUType_int.get(o);
break;
case xmoc_double:
_stack[i].s_double = static_QUType_double.get(o);
break;
case xmoc_charstar:
_stack[i].s_voidp = static_TQUType_charstar.get(o);
break;
case xmoc_TQString:
_stack[i].s_voidp = &static_TQUType_TQString.get(o);
break;
default: // case xmoc_ptr:
{
const SmokeType &t = _args[i].st;
void *p = static_TQUType_ptr.get(o);
switch(t.elem()) {
case Smoke::t_bool:
_stack[i].s_bool = *(bool*)p;
break;
case Smoke::t_char:
_stack[i].s_char = *(char*)p;
break;
case Smoke::t_uchar:
_stack[i].s_uchar = *(unsigned char*)p;
break;
case Smoke::t_short:
_stack[i].s_short = *(short*)p;
break;
case Smoke::t_ushort:
_stack[i].s_ushort = *(unsigned short*)p;
break;
case Smoke::t_int:
_stack[i].s_int = *(int*)p;
break;
case Smoke::t_uint:
_stack[i].s_uint = *(unsigned int*)p;
break;
case Smoke::t_long:
_stack[i].s_long = *(long*)p;
break;
case Smoke::t_ulong:
_stack[i].s_ulong = *(unsigned long*)p;
break;
case Smoke::t_float:
_stack[i].s_float = *(float*)p;
break;
case Smoke::t_double:
_stack[i].s_double = *(double*)p;
break;
case Smoke::t_enum:
{
Smoke::EnumFn fn = SmokeClass(t).enumFn();
if(!fn) {
warn("Unknown enumeration %s\n", t.name());
_stack[i].s_enum = *(int*)p;
break;
}
Smoke::Index id = t.typeId();
(*fn)(Smoke::EnumToLong, id, p, _stack[i].s_enum);
}
break;
case Smoke::t_class:
case Smoke::t_voidp:
_stack[i].s_voidp = p;
break;
}
}
}
}
}
void invokeSlot() {
dSP;
if(_called) return;
_called = true;
SP = _sp + _items - 1;
PUTBACK;
int count = call_sv((SV*)GvCV(_gv), G_SCALAR);
SPAGAIN;
SP -= count;
PUTBACK;
FREETMPS;
LEAVE;
}
void next() {
int oldcur = _cur;
_cur++;
while(!_called && _cur < _items) {
Marshall::HandlerFn fn = getMarshallFn(type());
(*fn)(this);
_cur++;
}
invokeSlot();
_cur = oldcur;
}
InvokeSlot(TQObject *qobj, GV *gv, int items, MocArgument *args, TQUObject *o) :
_qobj(qobj), _gv(gv), _items(items), _args(args), _o(o), _cur(-1), _called(false) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, items);
PUTBACK;
_sp = SP + 1;
for(int i = 0; i < _items; i++)
_sp[i] = sv_newmortal();
_stack = new Smoke::StackItem[_items];
copyArguments();
}
~InvokeSlot() {
delete[] _stack;
}
};
class TQtSmokeBinding : public SmokeBinding {
public:
TQtSmokeBinding(Smoke *s) : SmokeBinding(s) {}
void deleted(Smoke::Index classId, void *ptr) {
SV *obj = getPointerObject(ptr);
smokeperl_object *o = sv_obj_info(obj);
if(do_debug && (do_debug & qtdb_gc)) {
fprintf(stderr, "%p->~%s()\n", ptr, smoke->className(classId));
}
if(!o || !o->ptr) {
return;
}
unmapPointer(o, o->classId, 0);
o->ptr = 0;
}
bool callMethod(Smoke::Index method, void *ptr, Smoke::Stack args, bool isAbstract) {
SV *obj = getPointerObject(ptr);
smokeperl_object *o = sv_obj_info(obj);
if(do_debug && (do_debug & qtdb_virtual)) fprintf(stderr, "virtual %p->%s::%s() called\n", ptr,
smoke->classes[smoke->methods[method].classId].className,
smoke->methodNames[smoke->methods[method].name]
);
if(!o) {
if(!PL_dirty && (do_debug && (do_debug & qtdb_virtual)) ) // if not in global destruction
fprintf(stderr, "Cannot find object for virtual method\n");
return false;
}
HV *stash = SvSTASH(SvRV(obj));
if(*HvNAME(stash) == ' ')
stash = gv_stashpv(HvNAME(stash) + 1, TRUE);
const char *methodName = smoke->methodNames[smoke->methods[method].name];
GV *gv = gv_fetchmethod_autoload(stash, methodName, 0);
if(!gv) return false;
VirtualMethodCall c(smoke, method, args, obj, gv);
// exception variable, just temporary
temporary_virtual_function_success = true;
c.next();
bool ret = temporary_virtual_function_success;
temporary_virtual_function_success = true;
return ret;
}
char *className(Smoke::Index classId) {
const char *className = smoke->className(classId);
char *buf = new char[strlen(className) + 6];
strcpy(buf, " TQt::");
strcat(buf, className + 1);
return buf;
}
};
// ---------------- Helpers -------------------
SV *catArguments(SV** sp, int n)
{
SV* r=newSVpvf("");
for(int i = 0; i < n; i++) {
if(i) sv_catpv(r, ", ");
if(!SvOK(sp[i])) {
sv_catpv(r, "undef");
} else if(SvROK(sp[i])) {
smokeperl_object *o = sv_obj_info(sp[i]);
if(o)
sv_catpv(r, o->smoke->className(o->classId));
else
sv_catsv(r, sp[i]);
} else {
bool isString = SvPOK(sp[i]);
STRLEN len;
char *s = SvPV(sp[i], len);
if(isString) sv_catpv(r, "'");
sv_catpvn(r, s, len > 10 ? 10 : len);
if(len > 10) sv_catpv(r, "...");
if(isString) sv_catpv(r, "'");
}
}
return r;
}
Smoke::Index package_classid(const char *p)
{
Smoke::Index *item = classcache->find(p);
if(item)
return *item;
char *nisa = new char[strlen(p)+6];
strcpy(nisa, p);
strcat(nisa, "::ISA");
AV* isa=get_av(nisa, true);
delete[] nisa;
for(int i=0; i<=av_len(isa); i++) {
SV** np = av_fetch(isa, i, 0);
if(np) {
Smoke::Index ix = package_classid(SvPV_nolen(*np));
if(ix) {
classcache->insert(p, new Smoke::Index(ix));
return ix;
}
}
}
return (Smoke::Index) 0;
}
char *get_SVt(SV *sv)
{
char *r;
if(!SvOK(sv))
r = "u";
else if(SvIOK(sv))
r = "i";
else if(SvNOK(sv))
r = "n";
else if(SvPOK(sv))
r = "s";
else if(SvROK(sv)) {
smokeperl_object *o = sv_obj_info(sv);
if(!o) {
switch (SvTYPE(SvRV(sv))) {
case SVt_PVAV:
r = "a";
break;
// case SVt_PV:
// case SVt_PVMG:
// r = "p";
default:
r = "r";
}
}
else
r = (char*)o->smoke->className(o->classId);
}
else
r = "U";
return r;
}
SV *prettyPrintMethod(Smoke::Index id) {
SV *r = newSVpvf("");
Smoke::Method &meth = qt_Smoke->methods[id];
const char *tname = qt_Smoke->types[meth.ret].name;
if(meth.flags & Smoke::mf_static) sv_catpv(r, "static ");
sv_catpvf(r, "%s ", (tname ? tname:"void"));
sv_catpvf(r, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]);
for(int i = 0; i < meth.numArgs; i++) {
if(i) sv_catpv(r, ", ");
tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name;
sv_catpv(r, (tname ? tname:"void"));
}
sv_catpv(r, ")");
if(meth.flags & Smoke::mf_const) sv_catpv(r, " const");
return r;
}
// --------------- Unary Keywords && Attributes ------------------
// implements unary 'this'
XS(XS_this) {
dXSARGS;
ST(0) = sv_this;
XSRETURN(1);
}
// implements unary attributes: 'foo' means 'this->{foo}'
XS(XS_attr) {
dXSARGS;
char *key = GvNAME(CvGV(cv));
U32 klen = strlen(key);
SV **svp = 0;
if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv_this);
svp = hv_fetch(hv, key, klen, 1);
}
if(svp) {
ST(0) = *svp;
XSRETURN(1);
}
XSRETURN_UNDEF;
}
// implements unary SUPER attribute: 'SUPER' means ${(CopSTASH)::_INTERNAL_STATIC_}{SUPER}
XS(XS_super) {
dXSARGS;
char *key = "SUPER";
U32 klen = strlen(key);
SV **svp = 0;
if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) {
HV *cs = (HV*)CopSTASH(PL_curcop);
if(!cs) XSRETURN_UNDEF;
svp = hv_fetch(cs, "_INTERNAL_STATIC_", 17, 0);
if(!svp) XSRETURN_UNDEF;
cs = GvHV((GV*)*svp);
if(!cs) XSRETURN_UNDEF;
svp = hv_fetch(cs, "SUPER", 5, 0);
}
if(svp) {
ST(0) = *svp;
XSRETURN(1);
}
XSRETURN_UNDEF;
}
//---------- XS Autoload (for all functions except fully qualified statics & enums) ---------
static inline bool isTQt(char *p) {
return (p[0] == 'Q' && p[1] && p[1] == 't' && ((p[2] && p[2] == ':') || !p[2]));
}
bool avoid_fetchmethod = false;
XS(XS_AUTOLOAD) {
// Err, XS autoload is borked. Lets try...
dXSARGS;
SV *sv = get_sv("TQt::AutoLoad::AUTOLOAD", TRUE);
char *package = SvPV_nolen(sv);
char *method = 0;
for(char *s = package; *s ; s++)
if(*s == ':') method = s;
if(!method) XSRETURN_NO;
*(method++ - 1) = 0; // sorry for showing off. :)
int withObject = (*package == ' ') ? 1 : 0;
int isSuper = 0;
if(withObject) {
package++;
if(*package == ' ') {
isSuper = 1;
char *super = new char[strlen(package) + 7];
package++;
strcpy(super, package);
strcat(super, "::SUPER");
package = super;
}
} else if( isTQt(package) )
avoid_fetchmethod = true;
HV *stash = gv_stashpv(package, TRUE);
if(do_debug && (do_debug & qtdb_autoload))
warn("In XS Autoload for %s::%s()\n", package, method);
// check for user-defined methods in the REAL stash; skip prefix
GV *gv = 0;
if(avoid_fetchmethod)
avoid_fetchmethod = false;
else
gv = gv_fetchmethod_autoload(stash, method, 0);
// If we've made it here, we need to set sv_this
if(gv) {
if(do_debug && (do_debug & qtdb_autoload))
warn("\tfound in %s's Perl stash\n", package);
// call the defined Perl method with new 'this'
SV *old_this;
if(withObject && !isSuper) {
old_this = sv_this;
sv_this = newSVsv(ST(0));
}
ENTER;
SAVETMPS;
PUSHMARK(SP - items + withObject);
PUTBACK;
int count = call_sv((SV*)GvCV(gv), G_SCALAR|G_EVAL);
SPAGAIN;
SV *ret = newSVsv(TOPs);
SP -= count;
PUTBACK;
FREETMPS;
LEAVE;
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
else if(isSuper)
delete[] package;
if(SvTRUE(ERRSV))
croak("%s", SvPV_nolen(ERRSV));
ST(0) = sv_2mortal(ret);
XSRETURN(1);
}
else if(!strcmp(method, "DESTROY")) {
SV *old_this;
if(withObject && !isSuper) {
old_this = sv_this;
sv_this = newSVsv(ST(0));
}
smokeperl_object *o = sv_obj_info(sv_this);
if(!(o && o->ptr && (o->allocated || getPointerObject(o->ptr)))) {
if(isSuper)
delete[] package;
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
XSRETURN_YES;
}
const char *key = "has been hidden";
U32 klen = 15;
SV **svp = 0;
if(SvROK(sv_this) && SvTYPE(SvRV(sv_this)) == SVt_PVHV) {
HV *hv = (HV*)SvRV(sv_this);
svp = hv_fetch(hv, key, klen, 0);
}
if(svp) {
if(isSuper)
delete[] package;
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
XSRETURN_YES;
}
gv = gv_fetchmethod_autoload(stash, "ON_DESTROY", 0);
if( !gv )
croak( "Couldn't find ON_DESTROY method for %s=%p\n", package, o->ptr);
PUSHMARK(SP);
call_sv((SV*)GvCV(gv), G_SCALAR|G_NOARGS);
SPAGAIN;
int ret = POPi;
PUTBACK;
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
if( do_debug && ret && (do_debug & qtdb_gc) )
fprintf(stderr, "Increasing refcount in DESTROY for %s=%p (still has a parent)\n", package, o->ptr);
} else {
if( items > 18 ) XSRETURN_NO; // current max number of args in TQt is 13.
// save the stack -- we'll need it
SV **savestack = new SV*[items+1];
SV *saveobj = ST(0);
SV *old_this;
Copy(SP - items + 1 + withObject, savestack, items-withObject, SV*);
// Get the classid (eventually converting SUPER to the right TQt class)
Smoke::Index cid = package_classid(package);
// Look in the cache
char *cname = (char*)qt_Smoke->className(cid);
int lcname = strlen(cname);
int lmethod = strlen(method);
char mcid[256];
strncpy(mcid, cname, lcname);
char *ptr = mcid + lcname;
*(ptr++) = ';';
strncpy(ptr, method, lmethod);
ptr += lmethod;
for(int i=withObject ; i<items ; i++)
{
*(ptr++) = ';';
char *t = get_SVt(ST(i));
int tlen = strlen(t);
strncpy(ptr, t, tlen );
ptr += tlen;
}
*ptr = 0;
Smoke::Index *rcid = methcache->find(mcid);
if(rcid) {
// Got a hit
_current_method = *rcid;
if(withObject && !isSuper) {
old_this = sv_this;
sv_this = newSVsv(ST(0));
}
}
else {
// Find the C++ method to call. I'll do that from Perl for now
ENTER;
SAVETMPS;
PUSHMARK(SP - items + withObject);
EXTEND(SP, 3);
PUSHs(sv_2mortal(newSViv((IV)cid)));
PUSHs(sv_2mortal(newSVpv(method, 0)));
PUSHs(sv_2mortal(newSVpv(package, 0)));
PUTBACK;
if(withObject && !isSuper) {
old_this = sv_this;
sv_this = newSVsv(saveobj);
}
call_pv("TQt::_internal::do_autoload", G_DISCARD|G_EVAL);
FREETMPS;
LEAVE;
// Restore sv_this on error, so that eval{ } works
if(SvTRUE(ERRSV)) {
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
else if(isSuper)
delete[] package;
delete[] savestack;
croak("%s", SvPV_nolen(ERRSV));
}
// Success. Cache result.
methcache->insert(mcid, new Smoke::Index(_current_method));
}
// FIXME: I shouldn't have to set the current object
{
smokeperl_object *o = sv_obj_info(sv_this);
if(o && o->ptr) {
_current_object = o->ptr;
_current_object_class = o->classId;
} else {
_current_object = 0;
}
}
// honor debugging channels
if(do_debug && (do_debug & qtdb_calls)) {
warn("Calling method\t%s\n", SvPV_nolen(sv_2mortal(prettyPrintMethod(_current_method))));
if(do_debug & qtdb_verbose)
warn("with arguments (%s)\n", SvPV_nolen(sv_2mortal(catArguments(savestack, items-withObject))));
}
MethodCall c(qt_Smoke, _current_method, savestack, items-withObject);
c.next();
if(savestack)
delete[] savestack;
if(withObject && !isSuper) {
SvREFCNT_dec(sv_this);
sv_this = old_this;
}
else if(isSuper)
delete[] package;
SV *ret = c.var();
SvREFCNT_inc(ret);
ST(0) = sv_2mortal(ret);
XSRETURN(1);
}
if(isSuper)
delete[] package;
XSRETURN_YES;
}
//----------------- Sig/Slot ------------------
MocArgument *getmetainfo(GV *gv, const char *name, int &offset, int &index, int &argcnt) {
char *signalname = GvNAME(gv);
HV *stash = GvSTASH(gv);
// $meta = $stash->{META}
SV **svp = hv_fetch(stash, "META", 4, 0);
if(!svp) return 0;
HV *hv = GvHV((GV*)*svp);
if(!hv) return 0;
// $metaobject = $meta->{object}
// aka. Class->staticMetaObject
svp = hv_fetch(hv, "object", 6, 0);
if(!svp) return 0;
smokeperl_object *ometa = sv_obj_info(*svp);
if(!ometa) return 0;
TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr;
offset = metaobject->signalOffset();
// $signals = $meta->{signal}
U32 len = strlen(name);
svp = hv_fetch(hv, name, len, 0);
if(!svp) return 0;
HV *signalshv = (HV*)SvRV(*svp);
// $signal = $signals->{$signalname}
len = strlen(signalname);
svp = hv_fetch(signalshv, signalname, len, 0);
if(!svp) return 0;
HV *signalhv = (HV*)SvRV(*svp);
// $index = $signal->{index}
svp = hv_fetch(signalhv, "index", 5, 0);
if(!svp) return 0;;
index = SvIV(*svp);
// $argcnt = $signal->{argcnt}
svp = hv_fetch(signalhv, "argcnt", 6, 0);
if(!svp) return 0;
argcnt = SvIV(*svp);
// $mocargs = $signal->{mocargs}
svp = hv_fetch(signalhv, "mocargs", 7, 0);
if(!svp) return 0;
MocArgument *args = (MocArgument*)SvIV(*svp);
return args;
}
MocArgument *getslotinfo(GV *gv, int id, char *&slotname, int &index, int &argcnt, bool isSignal = false) {
HV *stash = GvSTASH(gv);
// $meta = $stash->{META}
SV **svp = hv_fetch(stash, "META", 4, 0);
if(!svp) return 0;
HV *hv = GvHV((GV*)*svp);
if(!hv) return 0;
// $metaobject = $meta->{object}
// aka. Class->staticMetaObject
svp = hv_fetch(hv, "object", 6, 0);
if(!svp) return 0;
smokeperl_object *ometa = sv_obj_info(*svp);
if(!ometa) return 0;
TQMetaObject *metaobject = (TQMetaObject*)ometa->ptr;
int offset = isSignal ? metaobject->signalOffset() : metaobject->slotOffset();
index = id - offset; // where we at
// FIXME: make slot inheritance work
if(index < 0) return 0;
// $signals = $meta->{signal}
const char *key = isSignal ? "signals" : "slots";
svp = hv_fetch(hv, key, strlen(key), 0);
if(!svp) return 0;
AV *signalsav = (AV*)SvRV(*svp);
svp = av_fetch(signalsav, index, 0);
if(!svp) return 0;
HV *signalhv = (HV*)SvRV(*svp);
// $argcnt = $signal->{argcnt}
svp = hv_fetch(signalhv, "argcnt", 6, 0);
if(!svp) return 0;
argcnt = SvIV(*svp);
// $mocargs = $signal->{mocargs}
svp = hv_fetch(signalhv, "mocargs", 7, 0);
if(!svp) return 0;
MocArgument *args = (MocArgument*)SvIV(*svp);
svp = hv_fetch(signalhv, "name", 4, 0);
if(!svp) return 0;
slotname = SvPV_nolen(*svp);
return args;
}
XS(XS_signal) {
dXSARGS;
smokeperl_object *o = sv_obj_info(sv_this);
TQObject *qobj = (TQObject*)o->smoke->cast(
o->ptr,
o->classId,
o->smoke->idClass("TQObject")
);
if(qobj->signalsBlocked()) XSRETURN_UNDEF;
int offset;
int index;
int argcnt;
MocArgument *args;
args = getmetainfo(CvGV(cv), "signal", offset, index, argcnt);
if(!args) XSRETURN_UNDEF;
// Okay, we have the signal info. *whew*
if(items < argcnt)
croak("Insufficient arguments to emit signal");
EmitSignal signal(qobj, offset + index, argcnt, args, &ST(0));
signal.next();
XSRETURN_UNDEF;
}
XS(XS_qt_invoke) {
dXSARGS;
// Arguments: int id, TQUObject *o
int id = SvIV(ST(0));
TQUObject *_o = (TQUObject*)SvIV(SvRV(ST(1)));
smokeperl_object *o = sv_obj_info(sv_this);
TQObject *qobj = (TQObject*)o->smoke->cast(
o->ptr,
o->classId,
o->smoke->idClass("TQObject")
);
// Now, I need to find out if this means me
int index;
char *slotname;
int argcnt;
MocArgument *args;
bool isSignal = !strcmp(GvNAME(CvGV(cv)), "qt_emit");
args = getslotinfo(CvGV(cv), id, slotname, index, argcnt, isSignal);
if(!args) {
// throw an exception - evil style
temporary_virtual_function_success = false;
XSRETURN_UNDEF;
}
HV *stash = GvSTASH(CvGV(cv));
GV *gv = gv_fetchmethod_autoload(stash, slotname, 0);
if(!gv) XSRETURN_UNDEF;
InvokeSlot slot(qobj, gv, argcnt, args, _o);
slot.next();
XSRETURN_UNDEF;
}
// ------------------- Tied types ------------------------
MODULE = TQt PACKAGE = TQt::_internal::TQString
PROTOTYPES: DISABLE
SV*
FETCH(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQString *s = (TQString*) tmp;
RETVAL = newSV(0);
if( s )
{
if(!(IN_BYTES))
{
sv_setpv_mg(RETVAL, (const char *)s->utf8());
SvUTF8_on(RETVAL);
}
else if(IN_LOCALE)
sv_setpv_mg(RETVAL, (const char *)s->local8Bit());
else
sv_setpv_mg(RETVAL, (const char *)s->latin1());
}
else
sv_setsv_mg(RETVAL, &PL_sv_undef);
OUTPUT:
RETVAL
void
STORE(obj,what)
SV* obj
SV* what
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQString *s = (TQString*) tmp;
s->truncate(0);
if(SvOK(what)) {
if(SvUTF8(what))
s->append(TQString::fromUtf8(SvPV_nolen(what)));
else if(IN_LOCALE)
s->append(TQString::fromLocal8Bit(SvPV_nolen(what)));
else
s->append(TQString::fromLatin1(SvPV_nolen(what)));
}
void
DESTROY(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQString *s = (TQString*) tmp;
delete s;
MODULE = TQt PACKAGE = TQt::_internal::TQByteArray
PROTOTYPES: DISABLE
SV*
FETCH(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQByteArray *s = (TQByteArray*) tmp;
RETVAL = newSV(0);
if( s )
{
sv_setpvn_mg(RETVAL, s->data(), s->size());
}
else
sv_setsv_mg(RETVAL, &PL_sv_undef);
OUTPUT:
RETVAL
void
STORE(obj,what)
SV* obj
SV* what
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQByteArray *s = (TQByteArray*) tmp;
if(SvOK(what)) {
STRLEN len;
char* tmp2 = SvPV(what, len);
s->resize(len);
Copy((void*)tmp2, (void*)s->data(), len, char);
} else
s->truncate(0);
void
DESTROY(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQByteArray *s = (TQByteArray*) tmp;
delete s;
MODULE = TQt PACKAGE = TQt::_internal::TQRgbStar
PROTOTYPES: DISABLE
SV*
FETCH(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQRgb *s = (TQRgb*) tmp;
AV* ar = newAV();
RETVAL = newRV_noinc((SV*)ar);
for(int i=0; s[i] ; i++)
{
SV *item = newSViv((IV)s[i]);
if(!av_store(ar, (I32)i, item))
SvREFCNT_dec( item );
}
OUTPUT:
RETVAL
void
STORE(obj,sv)
SV* obj
SV* sv
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQRgb *s = (TQRgb*) tmp;
if(!SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVAV ||
av_len((AV*)SvRV(sv)) < 0) {
s = new TQRgb[1];
s[0] = 0;
sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s);
return;
}
AV *list = (AV*)SvRV(sv);
int count = av_len(list);
s = new TQRgb[count + 2];
int i;
for(i = 0; i <= count; i++) {
SV **item = av_fetch(list, i, 0);
if(!item || !SvOK(*item)) {
s[i] = 0;
continue;
}
s[i] = SvIV(*item);
}
s[i] = 0;
sv_setref_pv(obj, "TQt::_internal::TQRgbStar", (void*)s);
void
DESTROY(obj)
SV* obj
CODE:
if (!SvROK(obj))
croak("?");
IV tmp = SvIV((SV*)SvRV(obj));
TQRgb *s = (TQRgb*) tmp;
delete[] s;
# --------------- XSUBS for TQt::_internal::* helpers ----------------
MODULE = TQt PACKAGE = TQt::_internal
PROTOTYPES: DISABLE
void
getMethStat()
PPCODE:
XPUSHs(sv_2mortal(newSViv((int)methcache->size())));
XPUSHs(sv_2mortal(newSViv((int)methcache->count())));
void
getClassStat()
PPCODE:
XPUSHs(sv_2mortal(newSViv((int)classcache->size())));
XPUSHs(sv_2mortal(newSViv((int)classcache->count())));
void
getIsa(classId)
int classId
PPCODE:
Smoke::Index *parents =
qt_Smoke->inheritanceList +
qt_Smoke->classes[classId].parents;
while(*parents)
XPUSHs(sv_2mortal(newSVpv(qt_Smoke->classes[*parents++].className, 0)));
void
dontRecurse()
CODE:
avoid_fetchmethod = true;
void *
sv_to_ptr(sv)
SV* sv
void *
allocateMocArguments(count)
int count
CODE:
RETVAL = (void*)new MocArgument[count + 1];
OUTPUT:
RETVAL
void
setMocType(ptr, idx, name, static_type)
void *ptr
int idx
char *name
char *static_type
CODE:
Smoke::Index typeId = qt_Smoke->idType(name);
if(!typeId) XSRETURN_NO;
MocArgument *arg = (MocArgument*)ptr;
arg[idx].st.set(qt_Smoke, typeId);
if(!strcmp(static_type, "ptr"))
arg[idx].argType = xmoc_ptr;
else if(!strcmp(static_type, "bool"))
arg[idx].argType = xmoc_bool;
else if(!strcmp(static_type, "int"))
arg[idx].argType = xmoc_int;
else if(!strcmp(static_type, "double"))
arg[idx].argType = xmoc_double;
else if(!strcmp(static_type, "char*"))
arg[idx].argType = xmoc_charstar;
else if(!strcmp(static_type, "TQString"))
arg[idx].argType = xmoc_TQString;
XSRETURN_YES;
void
installsignal(name)
char *name
CODE:
char *file = __FILE__;
newXS(name, XS_signal, file);
void
installqt_invoke(name)
char *name
CODE:
char *file = __FILE__;
newXS(name, XS_qt_invoke, file);
void
setDebug(on)
int on
CODE:
do_debug = on;
int
debug()
CODE:
RETVAL = do_debug;
OUTPUT:
RETVAL
char *
getTypeNameOfArg(method, idx)
int method
int idx
CODE:
Smoke::Method &m = qt_Smoke->methods[method];
Smoke::Index *args = qt_Smoke->argumentList + m.args;
RETVAL = (char*)qt_Smoke->types[args[idx]].name;
OUTPUT:
RETVAL
int
classIsa(className, base)
char *className
char *base
CODE:
RETVAL = isDerivedFrom(qt_Smoke, className, base, 0);
OUTPUT:
RETVAL
void
insert_pclassid(p, ix)
char *p
int ix
CODE:
classcache->insert(p, new Smoke::Index((Smoke::Index)ix));
int
find_pclassid(p)
char *p
CODE:
Smoke::Index *r = classcache->find(p);
if(r)
RETVAL = (int)*r;
else
RETVAL = 0;
OUTPUT:
RETVAL
void
insert_mcid(mcid, ix)
char *mcid
int ix
CODE:
methcache->insert(mcid, new Smoke::Index((Smoke::Index)ix));
int
find_mcid(mcid)
char *mcid
CODE:
Smoke::Index *r = methcache->find(mcid);
if(r)
RETVAL = (int)*r;
else
RETVAL = 0;
OUTPUT:
RETVAL
char *
getSVt(sv)
SV *sv
CODE:
RETVAL=get_SVt(sv);
OUTPUT:
RETVAL
void *
make_TQUParameter(name, type, extra, inout)
char *name
char *type
SV *extra
int inout
CODE:
TQUParameter *p = new TQUParameter;
p->name = new char[strlen(name) + 1];
strcpy((char*)p->name, name);
if(!strcmp(type, "bool"))
p->type = &static_TQUType_bool;
else if(!strcmp(type, "int"))
p->type = &static_TQUType_int;
else if(!strcmp(type, "double"))
p->type = &static_QUType_double;
else if(!strcmp(type, "char*") || !strcmp(type, "const char*"))
p->type = &static_TQUType_charstar;
else if(!strcmp(type, "TQString") || !strcmp(type, "TQString&") ||
!strcmp(type, "const TQString") || !strcmp(type, "const TQString&"))
p->type = &static_TQUType_TQString;
else
p->type = &static_TQUType_ptr;
// Lacking support for several types. Evil.
p->inOut = inout;
p->typeExtra = 0;
RETVAL = (void*)p;
OUTPUT:
RETVAL
void *
make_TQMetaData(name, method)
char *name
void *method
CODE:
TQMetaData *m = new TQMetaData; // will be deleted
m->name = new char[strlen(name) + 1];
strcpy((char*)m->name, name);
m->method = (TQUMethod*)method;
m->access = TQMetaData::Public;
RETVAL = m;
OUTPUT:
RETVAL
void *
make_TQUMethod(name, params)
char *name
SV *params
CODE:
TQUMethod *m = new TQUMethod; // permanent memory allocation
m->name = new char[strlen(name) + 1]; // this too
strcpy((char*)m->name, name);
m->count = 0;
m->parameters = 0;
if(SvOK(params) && SvRV(params)) {
AV *av = (AV*)SvRV(params);
m->count = av_len(av) + 1;
if(m->count > 0) {
m->parameters = new TQUParameter[m->count];
for(int i = 0; i < m->count; i++) {
SV *sv = av_shift(av);
if(!SvOK(sv))
croak("Invalid paramater for TQUMethod\n");
TQUParameter *p = (TQUParameter*)SvIV(sv);
SvREFCNT_dec(sv);
((TQUParameter*)m->parameters)[i] = *p;
delete p;
}
} else
m->count = 0;
}
RETVAL = m;
OUTPUT:
RETVAL
void *
make_TQMetaData_tbl(list)
SV *list
CODE:
RETVAL = 0;
if(SvOK(list) && SvRV(list)) {
AV *av = (AV*)SvRV(list);
int count = av_len(av) + 1;
TQMetaData *m = new TQMetaData[count];
for(int i = 0; i < count; i++) {
SV *sv = av_shift(av);
if(!SvOK(sv))
croak("Invalid metadata\n");
TQMetaData *old = (TQMetaData*)SvIV(sv);
SvREFCNT_dec(sv);
m[i] = *old;
delete old;
}
RETVAL = (void*)m;
}
OUTPUT:
RETVAL
SV *
make_metaObject(className, parent, slot_tbl, slot_count, signal_tbl, signal_count)
char *className
SV *parent
void *slot_tbl
int slot_count
void *signal_tbl
int signal_count
CODE:
smokeperl_object *po = sv_obj_info(parent);
if(!po || !po->ptr) croak("Cannot create metaObject\n");
TQMetaObject *meta = TQMetaObject::new_metaobject(
className, (TQMetaObject*)po->ptr,
(const TQMetaData*)slot_tbl, slot_count, // slots
(const TQMetaData*)signal_tbl, signal_count, // signals
0, 0, // properties
0, 0, // enums
0, 0);
// this object-creation code is so, so wrong here
HV *hv = newHV();
SV *obj = newRV_noinc((SV*)hv);
smokeperl_object o;
o.smoke = qt_Smoke;
o.classId = qt_Smoke->idClass("TQMetaObject");
o.ptr = meta;
o.allocated = true;
sv_magic((SV*)hv, sv_qapp, '~', (char*)&o, sizeof(o));
MAGIC *mg = mg_find((SV*)hv, '~');
mg->mg_virtual = &vtbl_smoke;
char *buf = qt_Smoke->binding->className(o.classId);
sv_bless(obj, gv_stashpv(buf, TRUE));
delete[] buf;
RETVAL = obj;
OUTPUT:
RETVAL
void
dumpObjects()
CODE:
hv_iterinit(pointer_map);
HE *e;
while(e = hv_iternext(pointer_map)) {
STRLEN len;
SV *sv = HeVAL(e);
printf("key = %s, refcnt = %d, weak = %d, ref? %d\n", HePV(e, len), SvREFCNT(sv), SvWEAKREF(sv), SvROK(sv)?1:0);
if(SvRV(sv))
printf("REFCNT = %d\n", SvREFCNT(SvRV(sv)));
//SvREFCNT_dec(HeVAL(e));
//HeVAL(e) = &PL_sv_undef;
}
void
dangle(obj)
SV *obj
CODE:
if(SvRV(obj))
SvREFCNT_inc(SvRV(obj));
void
setAllocated(obj, b)
SV *obj
bool b
CODE:
smokeperl_object *o = sv_obj_info(obj);
if(o) {
o->allocated = b;
}
void
setqapp(obj)
SV *obj
CODE:
if(!obj || !SvROK(obj))
croak("Invalid TQt::Application object. Couldn't set TQt::app()\n");
sv_qapp = SvRV(obj);
void
setThis(obj)
SV *obj
CODE:
sv_setsv_mg(sv_this, obj);
void
deleteObject(obj)
SV *obj
CODE:
smokeperl_object *o = sv_obj_info(obj);
if(!o) { XSRETURN_EMPTY; }
TQObject *qobj = (TQObject*)o->smoke->cast(o->ptr, o->classId, o->smoke->idClass("TQObject"));
delete qobj;
void
mapObject(obj)
SV *obj
CODE:
smokeperl_object *o = sv_obj_info(obj);
if(!o)
XSRETURN_EMPTY;
SmokeClass c( o->smoke, o->classId );
if(!c.hasVirtual() ) {
XSRETURN_EMPTY;
}
mapPointer(obj, o, pointer_map, o->classId, 0);
bool
isTQObject(obj)
SV *obj
CODE:
RETVAL = 0;
smokeperl_object *o = sv_obj_info(obj);
if(o && isTQObject(o->smoke, o->classId))
RETVAL = 1;
OUTPUT:
RETVAL
bool
isValidAllocatedPointer(obj)
SV *obj
CODE:
RETVAL = 0;
smokeperl_object *o = sv_obj_info(obj);
if(o && o->ptr && o->allocated)
RETVAL = 1;
OUTPUT:
RETVAL
SV*
findAllocatedObjectFor(obj)
SV *obj
CODE:
RETVAL = &PL_sv_undef;
smokeperl_object *o = sv_obj_info(obj);
SV *ret;
if(o && o->ptr && (ret = getPointerObject(o->ptr)))
RETVAL = ret;
OUTPUT:
RETVAL
SV *
getGV(cv)
SV *cv
CODE:
RETVAL = (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) ?
SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef);
OUTPUT:
RETVAL
int
idClass(name)
char *name
CODE:
RETVAL = qt_Smoke->idClass(name);
OUTPUT:
RETVAL
int
idMethodName(name)
char *name
CODE:
RETVAL = qt_Smoke->idMethodName(name);
OUTPUT:
RETVAL
int
idMethod(idclass, idmethodname)
int idclass
int idmethodname
CODE:
RETVAL = qt_Smoke->idMethod(idclass, idmethodname);
OUTPUT:
RETVAL
void
findMethod(c, name)
char *c
char *name
PPCODE:
Smoke::Index meth = qt_Smoke->findMethod(c, name);
// printf("DAMNIT on %s::%s => %d\n", c, name, meth);
if(!meth) {
// empty list
} else if(meth > 0) {
Smoke::Index i = qt_Smoke->methodMaps[meth].method;
if(!i) { // shouldn't happen
croak("Corrupt method %s::%s", c, name);
} else if(i > 0) { // single match
PUSHs(sv_2mortal(newSViv(
(IV)qt_Smoke->methodMaps[meth].method
)));
} else { // multiple match
i = -i; // turn into ambiguousMethodList index
while(qt_Smoke->ambiguousMethodList[i]) {
PUSHs(sv_2mortal(newSViv(
(IV)qt_Smoke->ambiguousMethodList[i]
)));
i++;
}
}
}
void
findMethodFromIds(idclass, idmethodname)
int idclass
int idmethodname
PPCODE:
Smoke::Index meth = qt_Smoke->findMethod(idclass, idmethodname);
if(!meth) {
// empty list
} else if(meth > 0) {
Smoke::Index i = qt_Smoke->methodMaps[meth].method;
if(i >= 0) { // single match
PUSHs(sv_2mortal(newSViv((IV)i)));
} else { // multiple match
i = -i; // turn into ambiguousMethodList index
while(qt_Smoke->ambiguousMethodList[i]) {
PUSHs(sv_2mortal(newSViv(
(IV)qt_Smoke->ambiguousMethodList[i]
)));
i++;
}
}
}
# findAllMethods(classid [, startingWith]) : returns { "mungedName" => [index in methods, ...], ... }
HV*
findAllMethods(classid, ...)
SV* classid
CODE:
RETVAL=newHV();
if(SvIOK(classid)) {
Smoke::Index c = (Smoke::Index) SvIV(classid);
char * pat = 0L;
if(items > 1 && SvPOK(ST(1)))
pat = SvPV_nolen(ST(1));
Smoke::Index imax = qt_Smoke->numMethodMaps;
Smoke::Index imin = 0, icur = -1, methmin = 0, methmax = 0;
int icmp = -1;
while(imax >= imin) {
icur = (imin + imax) / 2;
icmp = qt_Smoke->leg(qt_Smoke->methodMaps[icur].classId, c);
if(!icmp) {
Smoke::Index pos = icur;
while(icur && qt_Smoke->methodMaps[icur-1].classId == c)
icur --;
methmin = icur;
icur = pos;
while(icur < imax && qt_Smoke->methodMaps[icur+1].classId == c)
icur ++;
methmax = icur;
break;
}
if (icmp > 0)
imax = icur - 1;
else
imin = icur + 1;
}
if(!icmp) {
for(Smoke::Index i=methmin ; i <= methmax ; i++) {
Smoke::Index m = qt_Smoke->methodMaps[i].name;
if(!pat || !strncmp(qt_Smoke->methodNames[m], pat, strlen(pat))) {
Smoke::Index ix= qt_Smoke->methodMaps[i].method;
AV* meths = newAV();
if(ix >= 0) { // single match
av_push(meths, newSViv((IV)ix));
} else { // multiple match
ix = -ix; // turn into ambiguousMethodList index
while(qt_Smoke->ambiguousMethodList[ix]) {
av_push(meths, newSViv((IV)qt_Smoke->ambiguousMethodList[ix]));
ix++;
}
}
hv_store(RETVAL, qt_Smoke->methodNames[m],strlen(qt_Smoke->methodNames[m]),newRV_inc((SV*)meths),0);
}
}
}
}
OUTPUT:
RETVAL
SV *
dumpCandidates(rmeths)
SV *rmeths
CODE:
if(SvROK(rmeths) && SvTYPE(SvRV(rmeths)) == SVt_PVAV) {
AV *methods = (AV*)SvRV(rmeths);
SV *errmsg = newSVpvf("");
for(int i = 0; i <= av_len(methods); i++) {
sv_catpv(errmsg, "\t");
IV id = SvIV(*(av_fetch(methods, i, 0)));
Smoke::Method &meth = qt_Smoke->methods[id];
const char *tname = qt_Smoke->types[meth.ret].name;
if(meth.flags & Smoke::mf_static) sv_catpv(errmsg, "static ");
sv_catpvf(errmsg, "%s ", (tname ? tname:"void"));
sv_catpvf(errmsg, "%s::%s(", qt_Smoke->classes[meth.classId].className, qt_Smoke->methodNames[meth.name]);
for(int i = 0; i < meth.numArgs; i++) {
if(i) sv_catpv(errmsg, ", ");
tname = qt_Smoke->types[qt_Smoke->argumentList[meth.args+i]].name;
sv_catpv(errmsg, (tname ? tname:"void"));
}
sv_catpv(errmsg, ")");
if(meth.flags & Smoke::mf_const) sv_catpv(errmsg, " const");
sv_catpv(errmsg, "\n");
}
RETVAL=errmsg;
}
else
RETVAL=newSVpvf("");
OUTPUT:
RETVAL
SV *
catArguments(r_args)
SV* r_args
CODE:
RETVAL=newSVpvf("");
if(SvROK(r_args) && SvTYPE(SvRV(r_args)) == SVt_PVAV) {
AV* args=(AV*)SvRV(r_args);
for(int i = 0; i <= av_len(args); i++) {
SV **arg=av_fetch(args, i, 0);
if(i) sv_catpv(RETVAL, ", ");
if(!arg || !SvOK(*arg)) {
sv_catpv(RETVAL, "undef");
} else if(SvROK(*arg)) {
smokeperl_object *o = sv_obj_info(*arg);
if(o)
sv_catpv(RETVAL, o->smoke->className(o->classId));
else
sv_catsv(RETVAL, *arg);
} else {
bool isString = SvPOK(*arg);
STRLEN len;
char *s = SvPV(*arg, len);
if(isString) sv_catpv(RETVAL, "'");
sv_catpvn(RETVAL, s, len > 10 ? 10 : len);
if(len > 10) sv_catpv(RETVAL, "...");
if(isString) sv_catpv(RETVAL, "'");
}
}
}
OUTPUT:
RETVAL
SV *
callMethod(...)
PPCODE:
if(_current_method) {
MethodCall c(qt_Smoke, _current_method, &ST(0), items);
c.next();
SV *ret = c.var();
SvREFCNT_inc(ret);
PUSHs(sv_2mortal(ret));
} else
PUSHs(sv_newmortal());
bool
isObject(obj)
SV *obj
CODE:
RETVAL = sv_to_ptr(obj) ? TRUE : FALSE;
OUTPUT:
RETVAL
void
setCurrentMethod(meth)
int meth
CODE:
// FIXME: damn, this is lame, and it doesn't handle ambiguous methods
_current_method = meth; //qt_Smoke->methodMaps[meth].method;
SV *
getClassList()
CODE:
AV *av = newAV();
for(int i = 1; i <= qt_Smoke->numClasses; i++) {
//printf("%s => %d\n", qt_Smoke->classes[i].className, i);
av_push(av, newSVpv(qt_Smoke->classes[i].className, 0));
// hv_store(hv, qt_Smoke->classes[i].className, 0, newSViv(i), 0);
}
RETVAL = newRV((SV*)av);
OUTPUT:
RETVAL
void
installthis(package)
char *package
CODE:
if(!package) XSRETURN_EMPTY;
char *name = new char[strlen(package) + 7];
char *file = __FILE__;
strcpy(name, package);
strcat(name, "::this");
// *{ $name } = sub () : lvalue;
CV *thissub = newXS(name, XS_this, file);
sv_setpv((SV*)thissub, ""); // sub this () : lvalue;
delete[] name;
void
installattribute(package, name)
char *package
char *name
CODE:
if(!package || !name) XSRETURN_EMPTY;
char *attr = new char[strlen(package) + strlen(name) + 3];
sprintf(attr, "%s::%s", package, name);
char *file = __FILE__;
// *{ $attr } = sub () : lvalue;
CV *attrsub = newXS(attr, XS_attr, file);
sv_setpv((SV*)attrsub, "");
CvLVALUE_on(attrsub);
CvNODEBUG_on(attrsub);
delete[] attr;
void
installsuper(package)
char *package
CODE:
if(!package) XSRETURN_EMPTY;
char *attr = new char[strlen(package) + 8];
sprintf(attr, "%s::SUPER", package);
char *file = __FILE__;
CV *attrsub = newXS(attr, XS_super, file);
sv_setpv((SV*)attrsub, "");
delete[] attr;
void
installautoload(package)
char *package
CODE:
if(!package) XSRETURN_EMPTY;
char *autoload = new char[strlen(package) + 11];
strcpy(autoload, package);
strcat(autoload, "::_UTOLOAD");
char *file = __FILE__;
// *{ $package."::AUTOLOAD" } = XS_AUTOLOAD
newXS(autoload, XS_AUTOLOAD, file);
delete[] autoload;
# ----------------- XSUBS for TQt:: -----------------
MODULE = TQt PACKAGE = TQt
SV *
this()
CODE:
RETVAL = newSVsv(sv_this);
OUTPUT:
RETVAL
SV *
app()
CODE:
RETVAL = newRV_inc(sv_qapp);
OUTPUT:
RETVAL
SV *
version()
CODE:
RETVAL = newSVpv(TQT_VERSION_STR,0);
OUTPUT:
RETVAL
BOOT:
init_qt_Smoke();
qt_Smoke->binding = new TQtSmokeBinding(qt_Smoke);
install_handlers(TQt_handlers);
pointer_map = newHV();
sv_this = newSV(0);
methcache = new TQAsciiDict<Smoke::Index>(1187);
classcache = new TQAsciiDict<Smoke::Index>(827);
methcache->setAutoDelete(1);
classcache->setAutoDelete(1);
View Git Blame Copy Permalink