This is tclObjc.m in view mode; [Download] [Up]
/* Implementation for Objective-C Tcl interpretter functions
Copyright (C) 1993,1994 R. Andrew McCallum
Written by: R. Andrew McCallum <mccallum@cs.rochester.edu>
Dept. of Computer Science, U. of Rochester, Rochester, NY 14627
This file is part of the Tcl/Objective-C interface library.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
This library 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
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
in Tcl type:
set tclObjcDebug 1
to see debugging information at each message send.
*/
#import <objc/objc-class.h>
#import <objc/objc-runtime.h>
#import <objc/hashtable.h>
#import <objc/List.h>
#import "tclObjc.h"
#import <tcl.h>
#import <string.h>
#include <stdlib.h>
int (*tclObjc_eventHook)();
Tcl_Interp *_TclObject_interp;
#define CLS_ISCLASS(cls) ((cls)&&CLS_GETINFO(cls, CLS_CLASS))
static BOOL object_is_instance(id object)
{
BOOL ret1, ret2;
ret1 = (object!=nil);
ret2 = CLS_ISCLASS(object->isa);
return ((object!=nil) && CLS_ISCLASS(object->isa));
}
char *tclObjc_objectToName(id obj)
{
/* Fix this messiness */
static char name[128];
if (obj)
{
sprintf(name, "%s@0x%x", obj->isa->name, (unsigned)obj);
return name;
}
return "nil";
}
extern char *strchr();
id tclObjc_nameToObject(const char *name)
{
id object;
char *p = strchr(name, '@');
if ((!p) || (sscanf(p+3, "%x", (unsigned*)&object) != 1))
{
if ((!strcmp(name, "nil"))
|| (!strcmp(name, "Nil"))
|| (!strcmp(name, "0x0")))
object = (id)0;
else
object = (id)-1;
}
return object;
}
int tclObjc_msgSendToClientData(ClientData clientData, Tcl_Interp *interp,
int argc, char *argv[])
{
char resultString[32];
char methodName[100];
BOOL argvIsMethodArg[32];
id object;
SEL sel;
Method method;
int i;
if (argc < 2)
{
interp->result = "no method specified.";
return TCL_ERROR;
}
argvIsMethodArg[0] = NO;
argvIsMethodArg[1] = NO;
strcpy(methodName, argv[1]);
for (i = 2; i < argc; i++)
{
if (argv[i][strlen(argv[i])-1] == ':')
{
strcat(methodName, argv[i]);
argvIsMethodArg[i] = NO;
}
else
{
argvIsMethodArg[i] = YES;
}
}
object = (id)clientData;
/* special case hack for getting List contents to tcl.
Send the message "contents" to a List object.
*/
if (!strcmp("contents", methodName)
&& [object isKindOf:[List class]])
{
int i;
Tcl_ResetResult(interp);
for (i = 0; i < [object count]; i++)
{
Tcl_AppendElement(interp, tclObjc_objectToName([object objectAt:i]));
}
return TCL_OK;
}
/* special case hack for sending message to a TclObject */
if (object->isa == [TclObject class])
{
static Tcl_DString command;
static char *cmd;
int i;
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, ((TclObject*)object)->_tclName, -1);
Tcl_DStringAppend(&command, " ", -1);
Tcl_DStringAppend(&command, methodName, -1);
for (i = 2; i < argc; i++)
{
if (argvIsMethodArg[i]) continue;
Tcl_DStringAppendElement(&command, argv[i]);
Tcl_DStringAppend(&command, " ", -1);
}
cmd = Tcl_DStringAppend(&command, "\n", -1);
if (!(((TclObject*)object)->_interp))
{
fprintf(stderr, "TclObject interp not yet set\n");
return TCL_ERROR;
}
Tcl_Eval(((TclObject*)object)->_interp, cmd);
Tcl_DStringFree(&command);
return TCL_OK;
}
// sel = sel_get_uid(argv[1]);
sel = sel_getUid(methodName);
if (![object respondsTo:sel])
{
printf("%s does not respond to method %s\n",
[object name], methodName);
Tcl_SetResult(interp, "object does not respond to method",
TCL_STATIC);
return TCL_ERROR;
}
if (object_is_instance(object))
method = class_getInstanceMethod(object->isa, sel);
else
method = class_getClassMethod(object->isa, sel);
method = class_getInstanceMethod(object->isa, sel);
if (!method)
{
printf("class %s doesn't have method %s\n",
object->isa->name, methodName);
Tcl_SetResult(interp, "method is NULL", TCL_STATIC);
return TCL_ERROR;
}
{
int argnum;
int argsize = method_getSizeOfArguments(method);
char argptr_buffer[argsize+256];
union {char *p; char r[256];} argframecontents;
marg_list argframe;
unsigned int bargframe = (unsigned int)argptr_buffer;
const char *type;
id retframe;
int tmpint;
int tmpuint;
char *objcdebug;
BOOL debug_printing;
Tcl_CmdInfo cmdInfo;
int *offset;
int realOffset;
objcdebug = Tcl_GetVar(interp, "tclObjcDebug", TCL_GLOBAL_ONLY);
if (objcdebug)
debug_printing = YES;
else
debug_printing = NO;
argframecontents.p = argptr_buffer;
argframe = (marg_list)&argframecontents;
if (debug_printing)
{
printf("c %d, name %s, argsize %d, method types: '%s'\n",
argc, methodName, argsize, method->method_types);
}
offset = &realOffset;
method_getArgumentInfo(method, 0, &type, offset);
*(marg_getRef(argframe, *offset, id)) = object;
offset = &realOffset;
method_getArgumentInfo(method, 1, &type, offset);
*(marg_getRef(argframe, *offset, SEL)) = sel;
type = 1;
for (argnum = 2; argnum < argc && type; argnum++)
{
offset = &realOffset;
method_getArgumentInfo(method, argnum, &type, offset);
if (debug_printing)
{
printf("datum=%x type=%s\n",
(unsigned int)(marg_getRef(argframe, *offset, id)) - bargframe, type);
printf("argv[%d] = %s type=%s\n", argnum, argv[argnum], type);
}
switch (*type)
{
case _C_SEL:
argnum--;
break;
case _C_ID:
*(marg_getRef(argframe, *offset, id)) =
tclObjc_nameToObject(argv[argnum]);
if (*(marg_getRef(argframe, *offset, id)) == (id)-1)
{
sprintf(interp->result,
"Expected objc object, got %s instead.\n",
argv[argnum]);
return TCL_ERROR;
}
break;
case _C_PTR:
sscanf(argv[argnum], "0x%x",
(marg_getRef(argframe, *offset, unsigned int)));
break;
case _C_INT:
sscanf(argv[argnum], "%d",
(marg_getRef(argframe, *offset, int)));
break;
case _C_UINT:
sscanf(argv[argnum], "%u",
(marg_getRef(argframe, *offset, unsigned int)));
break;
case _C_LNG:
sscanf(argv[argnum], "%ld",
(marg_getRef(argframe, *offset, long)));
break;
case _C_ULNG:
sscanf(argv[argnum], "%lu",
(marg_getRef(argframe, *offset, unsigned long)));
break;
case _C_SHT:
sscanf(argv[argnum], "%d", &tmpint);
*(marg_getRef(argframe, *offset, short)) = (short)tmpint;
break;
case _C_USHT:
sscanf(argv[argnum], "%u", &tmpuint);
*(marg_getRef(argframe, *offset, unsigned short)) =
(unsigned short)tmpuint;
break;
case _C_CHR:
sscanf(argv[argnum], "%c",
(marg_getRef(argframe, *offset, char)));
break;
case _C_UCHR:
sscanf(argv[argnum], "%d", &tmpuint);
*(marg_getRef(argframe, *offset, unsigned char)) =
(unsigned char)tmpuint;
break;
case _C_CHARPTR:
*(marg_getRef(argframe, *offset, char*)) = argv[argnum];
break;
case _C_FLT:
sscanf(argv[argnum], "%f", (marg_getRef(argframe, *offset, float)));
break;
case _C_DBL:
sscanf(argv[argnum], "%lf",
(marg_getRef(argframe, *offset, double)));
break;
default:
{
fprintf(stderr, "Tcl can't handle arg type %s", type);
sprintf(resultString, "Tcl can't handle arg type %s", type);
Tcl_SetResult(interp, resultString, TCL_VOLATILE);
return TCL_ERROR;
}
}
// offset = &realOffset;
// method_getArgumentInfo(method, argnum, &type, offset);
}
retframe =
objc_msgSendv(object, sel, method_getSizeOfArguments(method), argframe);
if (debug_printing)
{
printf("retframe unsigned int 0x%x\n", (unsigned int)retframe);
}
type = method->method_types;
switch (*type)
{
case _C_ID:
sprintf(resultString, "%s", tclObjc_objectToName(retframe));
if (!Tcl_GetCommandInfo(interp, resultString, &cmdInfo))
Tcl_CreateCommand(interp, resultString, tclObjc_msgSendToClientData,
retframe, 0);
break;
case _C_PTR:
sprintf(resultString, "0x%x", (unsigned int)retframe);
break;
case _C_INT:
sprintf(resultString, "%d", (int)retframe);
break;
case _C_UINT:
sprintf(resultString, "%u", (unsigned int)retframe);
break;
case _C_SHT:
// What's going on here?
sprintf(resultString, "%d", (int)retframe);
break;
case _C_USHT:
// What's going on here?
sprintf(resultString, "%u", (unsigned int)retframe);
break;
case _C_LNG:
sprintf(resultString, "%ld", (long)retframe);
break;
case _C_ULNG:
sprintf(resultString, "%lx", (unsigned long)retframe);
break;
case _C_CHR:
sprintf(resultString, "%c", (char)retframe);
// tmpint = *(int*)retframe;
// sprintf(resultString, "%d", tmpint);
break;
case _C_UCHR:
// What's going on here?
sprintf(resultString, "%d", (unsigned int)retframe);
break;
case _C_CHARPTR:
/* Yuck. Clean this up. */
Tcl_SetResult(interp, (char*)retframe, TCL_VOLATILE);
return TCL_OK;
sprintf(resultString, "%s", (char*)retframe);
break;
case _C_FLT:
sprintf(resultString, "%g", (float *)retframe);
break;
case _C_DBL:
sprintf(resultString, "%g", (double *)retframe);
break;
case _C_VOID:
sprintf(resultString, "");
break;
default:
{
fprintf(stderr, "Tcl can't handle ret type %s", type);
sprintf(resultString, "Tcl can't handle ret type %s", type);
Tcl_SetResult(interp, resultString, TCL_VOLATILE);
return TCL_ERROR;
}
}
Tcl_SetResult(interp, resultString, TCL_VOLATILE);
if (*tclObjc_eventHook)
(*tclObjc_eventHook)();
return TCL_OK;
}
}
void tclObjc_registerObjectWithName(Tcl_Interp *interp,
id object, const char *name)
{
Tcl_CreateCommand(interp, (char *)name, tclObjc_msgSendToClientData,
object, 0);
}
void tclObjc_unregisterObjectNamed(Tcl_Interp *interp,
const char *name)
{
Tcl_DeleteCommand(interp, (char *)name);
}
void tclObjc_registerClassnames(Tcl_Interp *interp)
{
Class thisClass;
NXHashTable *classes = objc_getClasses();
NXHashState state = NXInitHashState(classes);
while (NXNextHashState(classes, &state, (void **)&thisClass))
{
printf("registering %s\n",
(char *)object_getClassName((id)thisClass));
tclObjc_registerObjectWithName(interp, thisClass, object_getClassName((id)thisClass));
}
}
/********************************************************************
int tclObjc_msgSendToArgv0(ClientData clientData, Tcl_Interp *interp,
int argc, char *argv[])
{
unsigned int addr;
Tcl *object = clientData;
if ((sscanf(argv[1], "0x%x", &addr)) == 1)
{
return TclObjcMsgSendToClientData((ClientData)addr, interp,
argc-1, &(argv[1]));
}
else if ([object nameIsRegistered:argv[1]])
{
return
TclObjcMsgSendToClientData((ClientData)[object objectNamed:argv[1]],
interp,
argc-1, &(argv[1]));
}
else
{
Tcl_SetResult(interp, "argv1 not recognized as an object",
TCL_STATIC);
return TCL_ERROR;
}
}
********************************************************************/
@implementation TclObject
+ newName: (char *)objectName
{
TclObject *newTclObject = class_createInstance(self, 0);
newTclObject->_tclName = (char *)malloc(strlen(objectName)+1);
strcpy(newTclObject->_tclName, objectName);
/* Fix this!!!!!!!!!!! */
newTclObject->_interp = _TclObject_interp;
return newTclObject;
}
- free
{
free(_tclName);
return object_dispose(self);
}
- (BOOL) respondsTo: (SEL)aSel
{
Tcl_CmdInfo cmdInfo;
char selString[128];
sprintf(selString, "%s%s", _tclName, sel_getName(aSel));
return (((object_is_instance(self)
?class_getInstanceMethod(self->ISA, aSel)
:class_getClassMethod(self->ISA, aSel))!= NULL)
|| Tcl_GetCommandInfo(_interp, selString, &cmdInfo));
}
- forward: (SEL)aSel : (marg_list)argframe
{
return [self performv: aSel :argframe];
}
- performv:(SEL)aSel :(marg_list)argframe
{
int argnum;
int *offset;
int realOffset;
const char *type;
char *objcdebug;
BOOL debug_printing;
Method method;
char argString[128];
Tcl_DString command;
char *cmd;
int tmpint;
unsigned int tmpuint;
// static methodHash;
if (_interp == NULL)
{
fprintf(stderr, "interp not set yet, %s\n", sel_getName(aSel));
return self;
}
objcdebug = Tcl_GetVar(_interp, "objcdebug", TCL_GLOBAL_ONLY);
if (objcdebug)
debug_printing = YES;
else
debug_printing = NO;
debug_printing = YES;
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, _tclName, -1);
// Tcl_DStringAppend(&command, " ", -1);
Tcl_DStringAppend(&command, (char *)sel_getName(aSel), -1);
Tcl_DStringAppend(&command, " ", -1);
if (debug_printing)
printf("selector: %s\n", sel_getName(aSel));
/* search all classes for the method */
{
Class thisClass;
NXHashTable *classes = objc_getClasses();
NXHashState state = NXInitHashState(classes);
while (NXNextHashState(classes, &state, (void **)&thisClass)
&& (!(method =
class_getInstanceMethod(object_getClassName((id)thisClass), aSel)))
&& (!(method =
class_getClassMethod(object_getClassName((id)thisClass), aSel))))
{
;
}
}
if (!method)
{
fprintf(stderr, "method not found, %s\n", sel_getName(aSel));
return self;
}
for (argnum = 2,
offset = &realOffset,
method_getArgumentInfo(method, argnum, &type, offset);
type;
offset = &realOffset,
method_getArgumentInfo(method, argnum, &type, offset))
{
switch (*type)
{
case _C_ID:
case _C_PTR:
sprintf(argString, "0x%x", *(unsigned int*)(marg_getRef(argframe, *offset, unsigned int)));
Tcl_DStringAppendElement(&command, argString);
break;
case _C_INT:
sprintf(argString, "%d", *(int*)(marg_getRef(argframe, *offset, int)));
Tcl_DStringAppendElement(&command, argString);
break;
case _C_UINT:
sprintf(argString, "%u", *(unsigned int*)(marg_getRef(argframe, *offset, unsigned int)));
Tcl_DStringAppendElement(&command, argString);
break;
case _C_SHT:
tmpint = *(short*)(marg_getRef(argframe, *offset, short));
sprintf(argString, "%d", tmpint);
Tcl_DStringAppendElement(&command, argString);
break;
case _C_USHT:
tmpuint = *(unsigned short*)(marg_getRef(argframe, *offset, unsigned short));
sprintf(argString, "%u", tmpuint);
Tcl_DStringAppendElement(&command, argString);
break;
case _C_CHR:
sprintf(argString, "%c", *(char*)(marg_getRef(argframe, *offset, char)));
Tcl_DStringAppendElement(&command, argString);
break;
case _C_UCHR:
tmpuint = *(unsigned char*)(marg_getRef(argframe, *offset, unsigned char));
sprintf(argString, "%u", tmpuint);
Tcl_DStringAppendElement(&command, argString);
break;
case _C_CHARPTR:
Tcl_DStringAppendElement(&command, *(char**)(marg_getRef(argframe, *offset, char *)));
break;
case _C_FLT:
sprintf(argString, "%f", *(float*)(marg_getRef(argframe, *offset, float)));
Tcl_DStringAppendElement(&command, argString);
break;
case _C_DBL:
sprintf(argString, "%f", *(double*)(marg_getRef(argframe, *offset, double)));
Tcl_DStringAppendElement(&command, argString);
break;
default:
{
fprintf(stderr, "TclObject can't handle arg type %s", type);
return self;
}
}
}
cmd = Tcl_DStringAppend(&command, "\n", -1);
Tcl_GlobalEval(_interp, cmd);
return self;
}
@end
/*****************************************************************/
int TclObjc_Init(Tcl_Interp *interp)
{
_TclObject_interp = interp;
tclObjc_registerClassnames(interp);
return TCL_OK;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.