view release on metacpan or  search on metacpan

qtcore/src/QtCore4.xs  view on Meta::CPAN

//util.h brings in all the required Qt4 headers.  This has to happen before the
//perl stuff below
#include "util.h"

#include <QXmlStreamAttributes>

// Perl headers
extern "C" {
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
}

// Now my own headers
#include "smoke.h"
#include "QtCore4.h"
#include "binding.h"
#include "smokeperl.h"
#include "marshall_types.h" // Method call classes
#include "handlers.h" // for install_handlers function
#include "listclass_macros.h"

extern PerlQt4::Binding binding;
extern Q_DECL_EXPORT Smoke* qtcore_Smoke;
extern "C" void init_qtcore_Smoke();
extern Q_DECL_EXPORT QHash<Smoke*, PerlQt4Module> perlqt_modules;
extern SV* sv_qapp;
Q_DECL_EXPORT QList<Smoke*> smokeList;
QList<QString> arrayTypes;

DEF_VECTORCLASS_FUNCTIONS(QXmlStreamAttributes, QXmlStreamAttribute, Qt::XmlStreamAttributes);

MODULE = Qt                 PACKAGE = Qt::_internal

PROTOTYPES: DISABLE

int
classIsa( className, base )
        char *className
        char *base
    CODE:
        RETVAL = isDerivedFromByName(className, base, 0);
    OUTPUT:
        RETVAL

#// Args: classname: a c++ classname in which the method exists
#//       methodname: a munged method name signature, where $ is a scalar
#//       argument, ? is an array or hash ref, and # is an object
#// Returns: an array containing 1 method id if the method signature is unique,
#//          or an array of possible ids if the signature is ambiguous
void
findMethod( classname, methodname )
        char* classname
        char* methodname
    PPCODE:
        QList<Smoke::ModuleIndex> milist;
        if ( strcmp( classname, "QGlobalSpace" ) == 0 ) {
            // All modules put their global functions in "QGlobalSpace".  So we
            // have to use each smoke object to look for this method.
            for (int i = 0; i < smokeList.size(); ++i) {
                Smoke::ModuleIndex mi = smokeList.at(i)->findMethod(classname, methodname);
                if( mi.smoke ) {
                    // Found a result, add it to the return
                    milist.append(mi);
                }
            }
        }
        else {
            // qtcore_Smoke will be able to find any method not in QGlobalSpace
            milist.append( qtcore_Smoke->findMethod(classname, methodname) );
        }
        foreach (Smoke::ModuleIndex mi, milist) {
            if ( !mi.index ) {
                // empty list
            }
            else if ( mi.index  > 0 ) {
                int smokeId = smokeList.indexOf(mi.smoke);
                if ( smokeId == -1 ) {
                    croak( "Method \"%s::%s\" called, which is defined in the smoke"
                        "module \"%s\", which has not been loaded\n", classname,
                        methodname, mi.smoke->moduleName() );
                }
                Smoke::Index methodId = mi.smoke->methodMaps[mi.index].method;
                if ( !methodId ) {
                    croak( "Corrupt method %s::%s", classname, methodname );
                }
                else if ( methodId > 0 ) {     // single match
                    XPUSHs( sv_2mortal(alloc_perl_moduleindex(smokeId, methodId)) );
                }
                else {                  // multiple match
                    // trun into ambiguousMethodList index
                    methodId = -methodId;

                    // Put all ambiguous method possibilities onto the stack
                    while( mi.smoke->ambiguousMethodList[methodId] ) {
                        XPUSHs( 
                            sv_2mortal(
                                alloc_perl_moduleindex(smokeId, (IV)mi.smoke->ambiguousMethodList[methodId])
                            )
                        );
                        ++methodId;
                    }
                }
            }
        }

#// Args: none
#// Returns: an array of all classes that qtcore_Smoke knows about
SV*
getClassList()
    CODE:
        AV* av = newAV();
        for (int i = 1; i <= qtcore_Smoke->numClasses; i++) {
            av_push(av, newSVpv(qtcore_Smoke->classes[i].className, 0));
        }
        RETVAL = newRV_noinc((SV*)av);
    OUTPUT:
        RETVAL

#// args: none
#// returns: an array of all enum names that qtcore_Smoke knows about
SV*
getEnumList()
    CODE:
        AV *av = newAV();
        for(int i = 1; i < qtcore_Smoke->numTypes; i++) {
            Smoke::Type curType = qtcore_Smoke->types[i];
            if( (curType.flags & Smoke::tf_elem) == Smoke::t_enum )
                av_push(av, newSVpv(curType.name, 0));
        }
        RETVAL = newRV_noinc((SV*)av);
    OUTPUT:
        RETVAL

#// Args: int classId: a smoke classId
#// Returns: An array of strings defining the inheritance list for that class.
void
getIsa( moduleId )
        SV* moduleId
    PPCODE:
        AV* av = (AV*)SvRV(moduleId);
        SV** smokeId = av_fetch(av, 0, 0);
        SV** classId = av_fetch(av, 1, 0);
        Smoke* smoke = smokeList[SvIV(*smokeId)];
        Smoke::Index *parents =
            smoke->inheritanceList +
            smoke->classes[SvIV(*classId)].parents;
        while(*parents)
            XPUSHs(sv_2mortal(newSVpv(smoke->classes[*parents++].className, 0)));

#// Args: methodId: a smoke method id
#//       argnum: the argument number to query
#// Returns: the c++ type of the n'th argument of methodId's associated method
char*
getTypeNameOfArg( smokeId, methodId, argnum )
        int smokeId
        int methodId
        int argnum
    CODE:
        Smoke* smoke = smokeList[smokeId];
        Smoke::Method &method = smoke->methods[methodId];
        Smoke::Index* args = smoke->argumentList + method.args;
        RETVAL = (char*)smoke->types[args[argnum]].name;
    OUTPUT:
        RETVAL

SV*
getNativeMetaObject( smokeId, methodId )
        int smokeId
        int methodId
    CODE:
        smokeperl_object* nothis = alloc_smokeperl_object( false, 0, 0, 0 );
        Smoke* smoke = smokeList[smokeId];
        PerlQt4::MethodCall call(
            smoke,
            methodId,
            nothis,
            0,
            0
        );
        call.next();
        RETVAL = call.var();
    OUTPUT:
        RETVAL

#// Args: int classId: a smoke classId
#// Returns: The number of arguments that method has
int
getNumArgs( smokeId, methodId )
        int smokeId
        int methodId
    CODE:
        Smoke::Method &method = smokeList[smokeId]->methods[methodId];
        RETVAL = method.numArgs;
    OUTPUT:
        RETVAL

const char*
getSVt( sv )
        SV* sv
    CODE:
        RETVAL = get_SVt(sv);
    OUTPUT:
        RETVAL

#// Args: char* name: the c++ name of a Qt4 class
#// Returns: An array where the first element is the smoke classId for that
#// class, and the second element is the index into the list of smoke objects.
void
findClass( name )
        char* name
    PPCODE:
        Smoke::ModuleIndex mi = qtcore_Smoke->findClass(name);
        EXTEND(SP, 2);
        PUSHs(sv_2mortal(newSViv(mi.index)));
        PUSHs(sv_2mortal(newSViv(smokeList.indexOf(mi.smoke))));

#// Args: char* name: the c++ name of a Qt4 class
#// Returns: the smoke classId for that Qt4 class
const char*
classFromId( moduleId )
        SV* moduleId
    CODE:
        AV* av = (AV*)SvRV(moduleId);
        int smokeId = SvIV(*(SV**)av_fetch(av, 0, 0));
        int classId = SvIV(*(SV**)av_fetch(av, 1, 0));
        Smoke* smoke = smokeList[smokeId];
        RETVAL = smoke->classes[classId].className;
    OUTPUT:
        RETVAL

int
debug()
    CODE:
        RETVAL = do_debug;
    OUTPUT:
        RETVAL

#// Args: char* package: the name of a Perl package
#// Returns: none
#// Desc: Makes calls to undefined subroutines for the given package redirect
#//       to call XS_AUTOLOAD
void
installautoload( package )
        char* package
    CODE:
        if(!package) XSRETURN_EMPTY;
        char* autoload = new char[strlen(package) + 11];
        sprintf(autoload, "%s::_UTOLOAD", package);
        newXS(autoload, XS_AUTOLOAD, __FILE__);
        delete[] autoload;

void
installqt_metacall(package)
        char *package
    CODE:
        if(!package) XSRETURN_EMPTY;
        char *qt_metacall = new char[strlen(package) + 14];
        strcpy(qt_metacall, package);
        strcat(qt_metacall, "::qt_metacall");
        newXS(qt_metacall, XS_qt_metacall, __FILE__);
        delete[] qt_metacall;

void
installsignal(signalname)
        char *signalname
    CODE:
        if(!signalname) XSRETURN_EMPTY;
        newXS(signalname, XS_signal, __FILE__);

void
installthis( package )

qtcore/src/QtCore4.xs  view on Meta::CPAN

        memcpy( (void*)(qt_meta_stringdata), (void*)SvPV_nolen(stringdata_sv), len );

        // Define our meta object
        const QMetaObject staticMetaObject = {
            { superdata, qt_meta_stringdata,
              qt_meta_data, 0 }
        };
        QMetaObject *meta = new QMetaObject;
        *meta = staticMetaObject;

        //Package up this pointer to be returned to perl
        smokeperl_object o;
        o.smoke = qtcore_Smoke;
        o.classId = qtcore_Smoke->idClass("QMetaObject").index,
        o.ptr = meta;
        o.allocated = true;

        HV *hv = newHV();
        RETVAL = newRV_noinc((SV*)hv);
        sv_bless( RETVAL, gv_stashpv( " Qt::MetaObject", TRUE ) );
        sv_magic((SV*)hv, 0, '~', (char*)&o, sizeof(o));
        //Not sure we need the entry in the pointer_map
        mapPointer(RETVAL, &o, pointer_map, o.classId, 0);
    OUTPUT:
        RETVAL

bool
isObject(obj)
        SV* obj
    CODE:
        RETVAL = sv_obj_info(obj) ? TRUE : FALSE;
    OUTPUT:
        RETVAL

void
setDebug(channel)
        int channel
    CODE:
        do_debug = channel;

void
setQApp( qapp )
        SV* qapp
    CODE:
        if( SvROK( qapp ) )
            sv_setsv_mg( sv_qapp, qapp );

void
setThis(obj)
        SV* obj
    CODE:
        sv_setsv_mg( sv_this, obj );

void*
sv_to_ptr(sv)
    SV* sv

void
sv_obj_info(sv)
        SV* sv
    PPCODE:
        smokeperl_object* o = sv_obj_info(sv);
        if( !o || !o->ptr )
            XSRETURN_UNDEF;
        XPUSHs(sv_2mortal(newSViv(o->allocated ? 1 : 0)));
        XPUSHs(sv_2mortal(newSVpv(o->smoke->classes[o->classId].className, strlen(o->smoke->classes[o->classId].className))));
        XPUSHs(sv_2mortal(newSVpv(o->smoke->moduleName(), strlen(o->smoke->moduleName()))));
        XPUSHs(sv_2mortal(newSVpvf("0x%x", (IV)o->ptr)));

void
setIsArrayType(typeName)
        const char* typeName
    CODE:
        arrayTypes.append(typeName);


MODULE = Qt                 PACKAGE = Qt

PROTOTYPES: ENABLE

SV*
this()
    CODE:
        RETVAL = newSVsv(sv_this);
    OUTPUT:
        RETVAL

SV*
qApp()
    CODE:
        if (!sv_qapp)
            RETVAL = &PL_sv_undef;
        else
            RETVAL = newSVsv(sv_qapp);
    OUTPUT:
        RETVAL

MODULE = QtCore4            PACKAGE = QtCore4

#// The build system with cmake and mingw relies on the visibility being set
#// for a dll to export that symbol.  So we need to redefine XSPROTO so that we
#// can export the boot method.

#ifdef WIN32
#undef XSPROTO
#define XSPROTO(name) void Q_DECL_EXPORT name(pTHX_ CV* cv)
#define boot_QtCore4 boot_PerlQtCore4
#endif

BOOT:
    /* same as -DUSE_SAFE_PUTENV in compile. prevents a "free from wrong
     * pool during global destruction" error with debugperl; and a segfault
     * otherwise (due to invalid free)
     *
     * see also:
     * http://www.nntp.perl.org/group/perl.perl5.porters/2008/06/msg137726.html
     * http://www.qtsoftware.com/developer/task-tracker/index_html?id=217782&method=entry
     */
#ifndef PERL_USE_SAFE_PUTENV
    PL_use_safe_putenv = 1;
#endif