summaryrefslogtreecommitdiffstats
path: root/PerlQt/Qt.xs
diff options
context:
space:
mode:
Diffstat (limited to 'PerlQt/Qt.xs')
-rw-r--r--PerlQt/Qt.xs2198
1 files changed, 0 insertions, 2198 deletions
diff --git a/PerlQt/Qt.xs b/PerlQt/Qt.xs
deleted file mode 100644
index 22a66de..0000000
--- a/PerlQt/Qt.xs
+++ /dev/null
@@ -1,2198 +0,0 @@
-#include <stdio.h>
-#include <qglobal.h>
-#include <qstring.h>
-#include <qapplication.h>
-#include <qmetaobject.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_TQUType_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_TQUType_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(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(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_TQUType_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);
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-12 05:49:12 +0000