/* 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;
}

