rendered paste body/***************************************************************************** * * * The breve Simulation Environment * * Coplright (C) 2000-2006 Jonathan Klein * * * * This program is free software; you can redistribute it and/or modify * * it under the terms of the GNU General Public License as published by * * the Free Software Foundation; either version 2 of the License, or * * (at your option) any later version. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * * GNU General Public License for more details. * * * * You should have received a copl of the GNU General Public License * * along with this program; if not, write to the Free Software * * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * *****************************************************************************/#define HAVE_LIBPERL#ifdef HAVE_LIBPERL#include "EXTERN.h"#include "perl.h"static PerlInterpreter *my_perl; int whatever(int argc, char **argv, char **env){ PERL_SYS_INIT3(&argc,&argv,&env); my_perl = perl_alloc(); perl_construct(my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_parse(my_perl, NULL, argc, argv, (char **)NULL); perl_run(my_perl); perl_destruct(my_perl); perl_free(my_perl); PERL_SYS_TERM(); return 0;}/*std::string brPerlToSteveName( const char *in ) { //fprintf(STDERR, "brPerlToSteveName: %s",in); std::string result; for( unsigned int n = 0; n < strlen( in ); n++ ) { if( isupper( in[ n ] ) ) { result += "-"; result += tolower( in[ n ] ); } else { result += in[ n ]; } } return result;}*//** * Translates a PlInt or PlFloat to a double. For breve vectors and matrices, * which can come in either as ints or doubles *//* double PlNumber_AS_DOUBLE( PlObject *inObject ) { if( PlInt_Check( inObject ) ) return (double)PlInt_AS_LONG( inObject ); return PlFloat_AS_DOUBLE( inObject );} *//** * Does PlObject_GetAttrString * * Super-suprising Perl optimization note: HasAttrString actually calls GetAttrString. * So when I thought I was being smart by checking for the Attr before getting it, it * actually was taking up more time! *//* inline PlObject *PlObject_GetAttrStringSafe( PlObject *inObject, char *inString ) { PlObject *result = PlObject_GetAttrString( inObject, inString ); if( !result ) PlErr_Clear(); return result;} *//** * Translation function from a Perl object to a breve value. * * @param inObject The Perl object to be translated. * @param outEval The breve value output. * @return Either EC_OK or EC_ERROR indicating the success of the translation *//* inline int brPerlTypeToEval( PlObject *inObject, brEval *outEval ) { int result = EC_ERROR; PlObject *breveInstance; if( !inObject ) return result; if( inObject == Pl_None ) return EC_OK; if ( PlInt_Check( inObject ) ) { outEval->set( PlInt_AS_LONG( inObject ) ); result = EC_OK; } else if ( PlFloat_Check( inObject ) ) { outEval->set( PlFloat_AS_DOUBLE( inObject ) ); result = EC_OK; } else if ( PlString_Check( inObject ) ) { outEval->set( PlString_AS_STRING( inObject ) ); result = EC_OK; } else if( PlCObject_Check( inObject ) ) { outEval->set( PlCObject_AsVoidPtr( inObject ) ); result = EC_OK; } else if( PlObject_HasAttrString( inObject, "isVector" ) ) { slVector v = { 0.0, 0.0, 0.0 }; PlObject *x = PlObject_GetAttrString( inObject, "x" ); PlObject *y = PlObject_GetAttrString( inObject, "y" ); PlObject *z = PlObject_GetAttrString( inObject, "z" ); if( x ) v.x = PlNumber_AS_DOUBLE( x ); if( y ) v.y = PlNumber_AS_DOUBLE( y ); if( z ) v.z = PlNumber_AS_DOUBLE( z ); Pl_DECREF( x ); Pl_DECREF( y ); Pl_DECREF( z ); outEval->set( v ); result = EC_OK; } else if ( ( breveInstance = PlObject_GetAttrStringSafe( inObject, "breveInstance" ) ) ) { outEval->set( (brInstance*)PlCObject_AsVoidPtr( breveInstance ) ); Pl_DECREF( breveInstance ); result = EC_OK; } else if( PlObject_HasAttrString( inObject, "isMatrix" ) ) { slMatrix m; PlObject *x1 = PlObject_GetAttrString( inObject, "x1" ); PlObject *x2 = PlObject_GetAttrString( inObject, "x2" ); PlObject *x3 = PlObject_GetAttrString( inObject, "x3" ); PlObject *y1 = PlObject_GetAttrString( inObject, "y1" ); PlObject *y2 = PlObject_GetAttrString( inObject, "y2" ); PlObject *y3 = PlObject_GetAttrString( inObject, "y3" ); PlObject *z1 = PlObject_GetAttrString( inObject, "z1" ); PlObject *z2 = PlObject_GetAttrString( inObject, "z2" ); PlObject *z3 = PlObject_GetAttrString( inObject, "z3" ); m[ 0 ][ 0 ] = PlNumber_AS_DOUBLE( x1 ); m[ 0 ][ 1 ] = PlNumber_AS_DOUBLE( x2 ); m[ 0 ][ 2 ] = PlNumber_AS_DOUBLE( x3 ); m[ 1 ][ 0 ] = PlNumber_AS_DOUBLE( y1 ); m[ 1 ][ 1 ] = PlNumber_AS_DOUBLE( y2 ); m[ 1 ][ 2 ] = PlNumber_AS_DOUBLE( y3 ); m[ 2 ][ 0 ] = PlNumber_AS_DOUBLE( z1 ); m[ 2 ][ 1 ] = PlNumber_AS_DOUBLE( z2 ); m[ 2 ][ 2 ] = PlNumber_AS_DOUBLE( z3 ); Pl_DECREF( x1 ); Pl_DECREF( x2 ); Pl_DECREF( x3 ); Pl_DECREF( y1 ); Pl_DECREF( y2 ); Pl_DECREF( y3 ); Pl_DECREF( z1 ); Pl_DECREF( z2 ); Pl_DECREF( z3 ); outEval->set( m ); result = EC_OK; } else if( PlSequence_Check( inObject ) ) { brEvalListHead *list = new brEvalListHead; int size = PlSequence_Size( inObject ); for( int n = 0; n < size; n++ ) { brEval item; brPerlTypeToEval( PlSequence_GetItem( inObject, n ), &item ); brEvalListInsert( list, list->_vector.size(), &item ); } outEval->set( list ); result = EC_OK; } return result;} *//** * Translation function from a breve value to a Perl object. * * @param inEval The breve value to be translated. * @param inModuleObject The Perl breveInternal module object * @return A newly created Perl object translated from the source value. *//* inline PlObject *brPerlTypeFromEval( const brEval *inEval, PlObject *inModuleObject ) { PlObject *result = NULL; brInstance *breveInstance; switch ( inEval->type() ) { case AT_NULL: result = Pl_None; Pl_INCREF( result ); break; case AT_INT: result = PlInt_FromLong( BRINT( inEval ) ); break; case AT_DOUBLE: result = PlFloat_FromDouble( BRDOUBLE( inEval ) ); break; case AT_STRING: result = PlString_FromString( BRSTRING( inEval ) ); break; case AT_INSTANCE: breveInstance = BRINSTANCE( inEval ); // Is this a native type, or should we make a bridge of it? if( breveInstance && breveInstance->object->type->_typeSignature == PERL_TYPE_SIGNATURE ) { result = (PlObject*)breveInstance->userData; Pl_INCREF( result ); } else if( breveInstance ) { // Create a bridge object, and set the breveInstance field PlObject *bridgeObject = PlObject_GetAttrString( inModuleObject, "bridgeObject" ); PlObject *args = PlTuple_New( 0 ); result = PlObject_Call( bridgeObject, args, NULL ); Pl_DECREF( args ); if( !result ) { PlErr_Print(); Pl_INCREF( Pl_None ); return Pl_None; } PlObject_SetAttrString( result, "breveInstance", PlCObject_FromVoidPtr( breveInstance, NULL ) ); } else { result = Pl_None; Pl_INCREF( result ); } break; case AT_POINTER: result = PlCObject_FromVoidPtr( BRPOINTER( inEval ), NULL ); break; case AT_VECTOR: { PlObject *vectorType = PlObject_GetAttrString( inModuleObject, "vectorType" ); const slVector &v = BRVECTOR( inEval ); if( vectorType ) { PlObject *args = PlTuple_New( 3 ); PlTuple_SET_ITEM( args, 0, PlFloat_FromDouble( v.x ) ); PlTuple_SET_ITEM( args, 1, PlFloat_FromDouble( v.y ) ); PlTuple_SET_ITEM( args, 2, PlFloat_FromDouble( v.z ) ); result = PlObject_Call( vectorType, args, NULL ); Pl_DECREF( args ); Pl_DECREF( vectorType ); } } break; case AT_MATRIX: { const slMatrix &m = BRMATRIX( inEval ); PlObject *matrixType = PlObject_GetAttrString( inModuleObject, "matrixType" ); if( matrixType ) { PlObject *args = PlTuple_New( 9 ); PlTuple_SET_ITEM( args, 0, PlFloat_FromDouble( m[ 0 ][ 0 ] ) ); PlTuple_SET_ITEM( args, 1, PlFloat_FromDouble( m[ 0 ][ 1 ] ) ); PlTuple_SET_ITEM( args, 2, PlFloat_FromDouble( m[ 0 ][ 2 ] ) ); PlTuple_SET_ITEM( args, 3, PlFloat_FromDouble( m[ 1 ][ 0 ] ) ); PlTuple_SET_ITEM( args, 4, PlFloat_FromDouble( m[ 1 ][ 1 ] ) ); PlTuple_SET_ITEM( args, 5, PlFloat_FromDouble( m[ 1 ][ 2 ] ) ); PlTuple_SET_ITEM( args, 6, PlFloat_FromDouble( m[ 2 ][ 0 ] ) ); PlTuple_SET_ITEM( args, 7, PlFloat_FromDouble( m[ 2 ][ 1 ] ) ); PlTuple_SET_ITEM( args, 8, PlFloat_FromDouble( m[ 2 ][ 2 ] ) ); result = PlObject_Call( matrixType, args, NULL ); Pl_DECREF( args ); Pl_DECREF( matrixType ); } } break; case AT_LIST: { brEvalListHead *list = BRLIST( inEval ); result = PlList_New( list->_vector.size() ); for( unsigned int n = 0; n < list->_vector.size(); n++ ) { PlObject *element = brPerlTypeFromEval( &list->_vector[ n ], inModuleObject ); PlList_SET_ITEM( result, n, element ); } } break; case AT_ARRAY: case AT_DATA: case AT_HASH: default: slMessage( DEBUG_ALL, "Could not convert breve internal type \"%d\" to a Perl type\n", inEval->type() ); break; } return result;} *//** * Callback to handle stdout/stderr from Perl and redirect it to breve output. *//* PlObject *brPerlCatchOutput( PlObject *inSelf, PlObject *inArgs ) { PlObject *moduleObject; char *message; if( !PlArg_ParseTuple( inArgs, "Os", &moduleObject, &message ) ) return NULL; slFormattedMessage( DEBUG_ALL, message ); Pl_INCREF( Pl_None ); return Pl_None;} *//** * Callback to set the controller object *//* PlObject *brPerlSetController( PlObject *inSelf, PlObject *inArgs ) { PlObject *moduleObject, *perlInstance; if ( !PlArg_ParseTuple( inArgs, "OO", &moduleObject, &perlInstance) ) return NULL; PlObject *engineObject = PlObject_GetAttrString( moduleObject, "breveEngine" ); PlObject *instanceObject = PlObject_GetAttrString( perlInstance, "breveInstance" ); brEngine *engine = (brEngine*)PlCObject_AsVoidPtr( engineObject ); brInstance *instance = (brInstance*)PlCObject_AsVoidPtr( instanceObject ); brEngineSetController( engine, instance ); Pl_DECREF( engineObject ); Pl_DECREF( instanceObject ); Pl_INCREF( Pl_None ); return Pl_None;} *//** * Perl callback to add a Perl instance to the breve engine. *//* PlObject *brPerlAddInstance( PlObject *inSelf, PlObject *inArgs ) { PlObject *object, *moduleObject, *typeObject, *result; brObject *breveObject; if ( !PlArg_ParseTuple( inArgs, "OOO", &moduleObject, &typeObject, &object ) ) return NULL; // Extract the breveEngine from the module data PlObject *engineObject = PlObject_GetAttrString( moduleObject, "breveEngine" ); if( !engineObject ) { PlErr_SetString( PlExc_RuntimeError, "Could not locate breve engine in first internal breve call argument" ); return NULL; } brEngine *engine = ( brEngine* )PlCObject_AsVoidPtr( engineObject ); Pl_DECREF( engineObject ); // Adding the instance requires a brObject type. // Figure out the brObject type for this instance. We may need to create it ourselves. PlObject *breveTypeObject = PlObject_GetAttrString( typeObject, "breveObject" ); if( !breveTypeObject ) { // Clear the missing attr error PlErr_Clear(); PlObject *nameObject = PlObject_GetAttrString( typeObject, "__name__" ); if( !nameObject || !PlString_Check( nameObject ) ) { PlErr_SetString( PlExc_RuntimeError, "Internal error while adding breve class type for Perl object" ); return NULL; } char *name = PlString_AsString( nameObject ); Pl_DECREF( nameObject ); // This object type has not previously been added to the breve engine. PlObject *perlLanguageType = PlObject_GetAttrString( moduleObject, "breveObjectType" ); breveObject = brEngineAddObject( engine, (brObjectType*)PlCObject_AsVoidPtr( perlLanguageType ), name, typeObject ); PlObject_SetAttrString( typeObject, "breveObject", PlCObject_FromVoidPtr( breveObject, NULL ) ); Pl_DECREF( perlLanguageType ); } else { // Found an existing brObject type for this Perl class PlObject *breveTypeObject = PlObject_GetAttrString( typeObject, "breveObject" ); breveObject = (brObject*)PlCObject_AsVoidPtr( breveTypeObject ); Pl_DECREF( breveTypeObject ); } brInstance *i = brEngineAddInstance( engine, breveObject, object ); // Now the engine has a copl of object -- increment the reference count Pl_INCREF( object ); if( i ) { result = PlCObject_FromVoidPtr( i, NULL ); } else { result = Pl_None; Pl_INCREF( result ); } // Set the breveInstance field for this object to the newly created engine instance PlObject_SetAttrString( object, "breveInstance", result ); return result;} *//** * Perl callback to remove a Perl instance from the breve engine. *//* PlObject *brPerlRemoveInstance( PlObject *inSelf, PlObject *inArgs ) { PlObject *engineObject, *object; if ( !PlArg_ParseTuple( inArgs, "OO", &engineObject, &object ) ) return NULL; PlObject *breveObject = PlObject_GetAttrString( object, "breveInstance" ); brEngine *engine = ( brEngine* )PlCObject_AsVoidPtr( engineObject ); brInstance *instance = ( brInstance* )PlCObject_AsVoidPtr( breveObject ); brEngineRemoveInstance( engine, instance ); Pl_DECREF( breveObject ); Pl_INCREF( Pl_None ); return Pl_None;} *//** * Perl callback to locate a breve internal function. * * Arguments are parsed from the Perl tuple. *//* PlObject *brPerlFindInternalFunction( PlObject *inSelf, PlObject *inArgs ) { char *name; PlObject *breveModule; if ( !PlArg_ParseTuple( inArgs, "Os", &breveModule, &name ) ) return NULL; brEngine *engine = ( brEngine* )PlCObject_AsVoidPtr( breveModule ); brInternalFunction *function = brEngineInternalFunctionLookup( engine, name ); if ( !function ) { std::string error( "could not locate internal breve method \"" ); error += name; error += "\""; PlErr_SetString( PlExc_RuntimeError, error.c_str() ); return NULL; } PlObject *result = PlCObject_FromVoidPtr( ( void* )function, NULL ); return result;} *//** * Perl callback to call a breve internal function. * * The function has already been looked up using \ref brPerlFindInternalFunction. *//* PlObject *brPerlCallInternalFunction( PlObject *inSelf, PlObject *inArgs ) { brEval args[ 128 ], resultEval; PlObject *callerObject, *functionObject, *arguments, *moduleObject; if ( !PlArg_ParseTuple( inArgs, "OOOO", &moduleObject, &callerObject, &functionObject, &arguments ) ) return NULL; brInternalFunction *function = ( brInternalFunction* )PlCObject_AsVoidPtr( functionObject ); if ( !function ) { PlErr_SetString( PlExc_RuntimeError, "Could not execute internal breve function" ); return NULL; } PlObject *breveObject = PlObject_GetAttrString( callerObject, "breveInstance" ); if( !breveObject ) { PlErr_SetString( PlExc_RuntimeError, "Internal breve function called for Perl object not in breve engine (missing call to __init__ for the parent class?)" ); return NULL; } brInstance *caller = ( brInstance* )PlCObject_AsVoidPtr( breveObject ); Pl_DECREF( breveObject ); if( function->_argCount != 0 ) { if( !PlTuple_Check( arguments ) ) { PlErr_SetString( PlExc_RuntimeError, "Invalid arguments passed to internal breve function" ); return NULL; } int argCount = PlTuple_GET_SIZE( arguments ); if( argCount != function->_argCount ) { char err[ 1024 ]; snprintf( err, 1023, "internal function \"%s\" given %d arguments, expects %d", function->_name.c_str(), argCount, function->_argCount ); PlErr_SetString( PlExc_RuntimeError, err ); return NULL; } for( int n = 0; n < argCount; n++ ) { brPerlTypeToEval( PlTuple_GET_ITEM( arguments, n ), &args[ n ] ); if( args[ n ].type() != function->_argTypes[ n ] ) { // int <=> double conversion if( args[ n ].type() == AT_INT && function->_argTypes[ n ] == AT_DOUBLE ) { args[ n ].set( (double)BRINT( &args[ n ] ) ); } else if( args[ n ].type() == AT_DOUBLE && function->_argTypes[ n ] == AT_INT) { args[ n ].set( (int)BRDOUBLE( &args[ n ] ) ); } else { char err[ 1024 ]; snprintf( err, 1023, "invalid type for argument %d of internal function \"%s\" (got \"%s\", expected \"%s\")", n, function->_name.c_str(), brAtomicTypeStrings[ args[ n ].type() ], brAtomicTypeStrings[ function->_argTypes[ n ] ] ); PlErr_SetString( PlExc_RuntimeError, err ); return NULL; } } } } function->_call( args, &resultEval, caller ); return brPerlTypeFromEval( &resultEval, moduleObject );} *//** * Perl callback to locate a breve object method (in another language frontend). * * Arguments are parsed from the Perl tuple. *//* PlObject *brPerlFindBridgeMethod( PlObject *inSelf, PlObject *inArgs ) { PlObject *object, *attrObject; char *name; std::string altname; char err[ 1024 ]; if ( !PlArg_ParseTuple( inArgs, "Os", &object, &name ) ) return NULL; attrObject = PlObject_GetAttrString( object, "breveInstance" ); if( !attrObject ) { snprintf( err, 1023, "could not locate breve instance for Perl bridge instance" ); PlErr_SetString( PlExc_RuntimeError, err ); return NULL; } altname = brPerlToSteveName( name ); for( unsigned int n = 0; n < strlen( name ); n++ ) { if( name[ n ] == '_' ) name[ n ] = '-'; } brInstance *breveInstance = (brInstance*)PlCObject_AsVoidPtr( attrObject ); Pl_DECREF( attrObject ); brMethod *method; // try the original name method = brMethodFindWithArgRange( breveInstance->object, name, NULL, 0, 50 ); if( method ) return PlCObject_FromVoidPtr( method, NULL ); // try the alternative name method = brMethodFindWithArgRange( breveInstance->object, altname.c_str(), NULL, 0, 50 ); if( method ) return PlCObject_FromVoidPtr( method, NULL ); // nope Pl_INCREF( Pl_None ); return Pl_None;} *//** * Perl callback to call a breve object method (for another language frontend) * * The method has already been located using \ref brPerlFindBridgeMethod. *//* PlObject *brPerlCallBridgeMethod( PlObject *inSelf, PlObject *inArgs ) { PlObject *object, *method, *arguments, *module; char err[ 1024 ]; const brEval **args; brEval resultEval; args = new const brEval*[ 128 ]; if ( !PlArg_ParseTuple( inArgs, "OOOO", &module, &object, &method, &arguments ) ) return NULL; PlObject *attrObject = PlObject_GetAttrString( object, "breveInstance" ); if( !attrObject ) { snprintf( err, 1023, "could not locate breve instance for Perl bridge instance" ); PlErr_SetString( PlExc_RuntimeError, err ); return NULL; } brInstance *breveInstance = (brInstance*)PlCObject_AsVoidPtr( attrObject ); Pl_DECREF( attrObject ); brMethod *breveMethod = (brMethod*)PlCObject_AsVoidPtr( method ); for( int n = 0; n < PlTuple_GET_SIZE( arguments ); n++ ) { brEval *newEval = new brEval; brPerlTypeToEval( PlTuple_GET_ITEM( arguments, n ), newEval ); args[ n ] = newEval; } brMethodCall( breveInstance, breveMethod, args, &resultEval ); for( int n = 0; n < PlTuple_GET_SIZE( arguments ); n++ ) { delete args[ n ]; } delete[] args; return brPerlTypeFromEval( &resultEval, module );} *////////////////////////////////////////////////////////////////////////////////////// // Perl language frontend callbacks for the breveObjectType structure /////////////////////////////////////////////////////////////////////////////////////// /** * A breveObjectType callback to locate a method in a Perl object. * * @param inObject A void pointer to a Perl object. * @param inName The name of the method to locate. * @param inTypes Argument types (currently unused) * @param inCount The argument count * * @return A void pointer to a Perl method object. *//* void *brPerlFindMethod( void *inObject, const char *inName, unsigned char *inTypes, int inCount ) { PlObject *type = ( PlObject* )inObject; char *name = strdup( inName ); // Translate steve to Perl method names for( unsigned int n = 0; n < strlen( name ); n++ ) { if( name[ n ] == '-' ) name[ n ] = '_'; } PlObject *method = PlObject_GetAttrStringSafe( type, name ); free( name ); if ( !method ) { return NULL; } PlObject *code = PlObject_GetAttrString( method, "func_code" ); if( !code ) { PlErr_Clear(); return NULL; } Pl_DECREF( code ); PlObject *argumentCount = PlObject_GetAttrString( code, "co_argcount" ); if( !argumentCount || PlInt_AS_LONG( argumentCount ) != ( inCount + 1 ) ) { PlErr_Clear(); return NULL; } Pl_DECREF( argumentCount ); return method;} *//** * A breveObjectType callback to locate a class in Perl. * * @param inData The userdata callback pointer to a __main__ module * @param inName The name of the desired object *//* void *brPerlFindObject( void *inData, const char *inName ) { PlObject *module = ( PlObject* )inData; return PlObject_GetAttrStringSafe( module, (char*)inName );} *//** * A breveObjectType callback to instantiate a class in Perl * * @param inEngine The breve engine creating the instancce. * @param inObject The object to be instantiated. * @param inArgs Constructor arguments -- not currently used. * @param inArgCount Constructor argument count -- not currently used. *//* brInstance *brPerlInstantiate( brEngine *inEngine, brObject* inObject, const brEval **inArgs, int inArgCount ) { PlObject *object = ( PlObject* )inObject->userData; PlObject *args = PlTuple_New( 0 ); PlObject *result = PlObject_Call( object, args, NULL ); Pl_DECREF( args ); if ( !result ) { PlErr_Print(); return NULL; } PlObject *breveObject = PlObject_GetAttrString( result, "breveInstance" ); if( !breveObject ) { // This is a fundamental rule of the Perl frontend: objects must add themselves // to the breve engine, or else they cannot be used slMessage( DEBUG_ALL, "New Perl object was not added to breve engine\n" ); slMessage( DEBUG_ALL, "breve Perl objects must inherit from class breve.object\n" ); return NULL; } Pl_INCREF( result ); Pl_DECREF( breveObject ); // Note: the brInstance we return will return (brInstance*)PlCObject_AsVoidPtr( breveObject );} *//** * A breveObjectType callback to call a method in Perl * * @param inInstance The object instance data (as found with \ref brPerlInstantiate) * @param inMethod The method callback data (as found with \ref brPerlFindMethod ) * @param inArguments NOT CURRENTLY IMPLEMENTED * @param outResult The brEval result of the method calll *//* int brPerlCallMethod( void *inInstance, void *inMethod, const brEval **inArguments, brEval *outResult ) { PlObject *instance = ( PlObject* )inInstance; PlObject *method = ( PlObject* )inMethod; static PlObject *tuples[ 5 ] = { PlTuple_New( 1 ), PlTuple_New( 2 ), PlTuple_New( 3 ), PlTuple_New( 4 ), PlTuple_New( 5 ) }; if ( !PlCallable_Check( method ) ) { slMessage( DEBUG_ALL, "Warning: called method is not callable\n" ); return EC_ERROR; } // Get the number of arguments to this method PlObject *code = PlObject_GetAttrString( method, "func_code" ); PlObject *argumentCount = PlObject_GetAttrString( code, "co_argcount" ); if( !argumentCount ) { slMessage( DEBUG_ALL, "Warning: cannot find argument count for method %p\n", method ); return EC_ERROR; } // we subtract 1 for the "self" argument int count = PlInt_AS_LONG( argumentCount ) - 1; Pl_DECREF( code ); Pl_DECREF( argumentCount ); PlObject *tuple; if( count < 5 ) { tuple = tuples[ count ]; } else { tuple = PlTuple_New( count + 1 ); } // the instance we're calling the method for has the breveInternal module pointer PlObject *module = PlObject_GetAttrString( instance, "breveModule" ); if( !module ) { slMessage( DEBUG_ALL, "Could not locate breveModule for %p\n", instance ); PlErr_Print(); return EC_ERROR; } // Set the self argument Pl_INCREF( instance ); PlTuple_SetItem( tuple, 0, instance ); // Set the rest of the arguments for( int n = 0; n < count; n++ ) { PlObject *argument = brPerlTypeFromEval( inArguments[ n ], module ); PlTuple_SetItem( tuple, n + 1, argument ); } Pl_DECREF( module ); PlObject *result = PlObject_Call( method, tuple, NULL ); if( count > 5 ) Pl_DECREF( tuple ); if( !result ) { PlErr_Print(); return EC_ERROR; } else { Pl_INCREF( result ); brPerlTypeToEval( result, outResult ); } return EC_OK;} *//** * A brObjectType callback to determine whether one object is a subclass of another. Used by * collision detection to determine if a handler is installed for an object pair. *//* int brPerlIsSubclass( brObjectType *inType, void *inClassA, void *inClassB ) { return PlObject_IsSubclass( (PlObject*)inClassA, (PlObject*)inClassB );} *//** * The Perl canLoad breve object callback *//* int brPerlCanLoad( void *inObjectData, const char *inExtension ) { if( !strcasecmp( inExtension, "pl" ) || !strcasecmp( inExtension, "plbreve" ) ) return 1; return 0;} *//** * The Perl load breve object callback *//* int brPerlLoad( brEngine *inEngine, void *inObjectTypeUserData, const char *inFilename, const char *inFiletext ) { int result = EC_OK; FILE *fp = fopen( inFilename, "r" ); if( fp ) { if( PlRun_SimpleFile( fp, inFilename ) ) result = EC_ERROR; fclose( fp ); } else { if( PlRun_SimpleString( inFiletext ) ) result = EC_ERROR; } return result;} *//** * A brObjectType callback to clean up a generic Perl object. This method is used as the * destructor for both objects and methods * * @param inObject A void pointer to a Perl object. *//* void brPerlDestroyGenericPerlObject( void *inObject ) { if( !inObject ) return; PlObject *object = ( PlObject* )inObject; Pl_DECREF( object );} *//** * A function to initialize the Perl frontend. * * Creates necessary Perl structures and initializes a brObjectType for * all of the required language callbacks. *//* void brPerlInit( brEngine *breveEngine ) { static int plInitialized = 0; brObjectType *brevePerlType = new brObjectType(); static PlMethodDef methods[] = { { "setController", brPerlSetController, METH_VARARGS, "" }, { "findInternalFunction", brPerlFindInternalFunction, METH_VARARGS, "" }, { "callInternalFunction", brPerlCallInternalFunction, METH_VARARGS, "" }, { "addInstance", brPerlAddInstance, METH_VARARGS, "" }, { "removeInstance", brPerlRemoveInstance, METH_VARARGS, "" }, { "findBridgeMethod", brPerlFindBridgeMethod, METH_VARARGS, "" }, { "callBridgeMethod", brPerlCallBridgeMethod, METH_VARARGS, "" }, { "catchOutput", brPerlCatchOutput, METH_VARARGS, "" }, { NULL, NULL, 0, NULL } }; if( !plInitialized ) { plInitialized = 1; Pl_Initialize(); } PlObject *internal = Pl_InitModule( "breveInternal", methods ); PlObject_SetAttrString( internal, "breveEngine", PlCObject_FromVoidPtr( ( void* )breveEngine, NULL ) ); PlObject_SetAttrString( internal, "breveObjectType", PlCObject_FromVoidPtr( ( void* )brevePerlType, NULL ) ); PlRun_SimpleString( "import sys" ); std::string setpath, path; for( unsigned int n = 0; n < breveEngine->_searchPaths.size(); n++ ) { path = breveEngine->_searchPaths[ n ]; setpath = "sys.path.append( '" + path + "' ) "; PlRun_SimpleString( setpath.c_str() ); path += "/PerlLibraries/"; setpath = "sys.path.append( '" + path + "' ) "; PlRun_SimpleString( setpath.c_str() ); } const std::vector< std::string > &paths = brEngineGetSearchPaths( breveEngine ); for( unsigned int n = 0; n < paths.size(); n++ ) { char path[ MAXPATHLEN + 1024 ]; snprintf( path, MAXPATHLEN + 1023, "sys.path.append( '%s' )", paths[ n ].c_str() ); // printf( "Appending path '%s'\n", path ); PlRun_SimpleString( path ); } PlRun_SimpleString( "import breve" ); brevePerlType->userData = ( void* )PlImport_ImportModule( "__main__" ); brevePerlType->findMethod = brPerlFindMethod; brevePerlType->findObject = brPerlFindObject; brevePerlType->instantiate = brPerlInstantiate; brevePerlType->callMethod = brPerlCallMethod; brevePerlType->isSubclass = brPerlIsSubclass; brevePerlType->destroyObject = brPerlDestroyGenericPerlObject; brevePerlType->destroyMethod = brPerlDestroyGenericPerlObject; brevePerlType->destroyInstance = brPerlDestroyGenericPerlObject; brevePerlType->canLoad = brPerlCanLoad; brevePerlType->load = brPerlLoad; brevePerlType->_typeSignature = PERL_TYPE_SIGNATURE; brEngineRegisterObjectType( breveEngine, brevePerlType ); breveInitPerlFunctions( breveEngine->internalMethods );#ifndef WINDOWS // Those meddling Perl kids mess with the signal handlers! signal( SIGINT, NULL );#endif} */#endif