/* Implementation for Objective-C Tcl interpretter object
   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.
*/ 

#include "Tcl.h"
#include "tclObjc.h"
#import <objc/List.h>
#import <objc/HashTable.h>
#include <stdio.h>
#include <stdarg.h>
#include <stdlib.h>

//#include <string.h>

char *tcl_RcFileName = NULL;	/* Name of a user-specific startup script
				 * to source if the application is being run
				 * interactively (e.g. "~/.wishrc").  Set
				 * by Tcl_AppInit.  NULL means don't source
				 * anything ever. */
List* tclList;

@implementation Tcl

+ initialize
{
  if (self == [Tcl class])
    {
      tclList = [[List alloc] init];
    }
  return self;
}

+ firstTcl
{
  if ([tclList count])
    return [tclList objectAt:0];
  else
    {
      fprintf(stderr, "no firstTcl\n");
      return nil;
    }
}

+ tclList
{
  return tclList;
}

- (char *) preInitWithArgc: (int)argc argv: (char**)argv
{
  char *args, *msg, buffer[100];
  char *fileName;

  /* tell class object about us */
  [tclList addObject:self];

  /* Create objc name and id hashtables */
  namesToObjects = [[HashTable alloc] initKeyDesc:"*"
		    valueDesc:"@"];
  objectsToNames = [[HashTable alloc] initKeyDesc:"@"
		    valueDesc:"*"];

  /* Create and init tcl interpreter */

  interp = Tcl_CreateInterp();

  /*
   * Make command-line arguments available in the Tcl variables "argc"
   * and "argv".
   */
  fileName = NULL;
  if ((argc > 1) && (argv[1][0] != '-')) {
    fileName = argv[1];
    argc--;
    argv++;
  }

  args = Tcl_Merge(argc-1, argv+1);
  Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  ckfree(args);
  sprintf(buffer, "%d", argc-1);
  Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
             TCL_GLOBAL_ONLY);

  Tcl_SetVar(interp, "tcl_interactive", "1", TCL_GLOBAL_ONLY);
  
  return fileName;
}

- initWithArgc: (int)argc argv: (char**)argv
{
  char *fileName, *msg;

  [super init];
  fileName = [self preInitWithArgc:argc argv:argv];

  if (Tcl_AppInit(interp) == TCL_ERROR) {
    goto error;
  }
  tclObjc_registerObjectWithName(interp, self, "objcTcl");

  /*
   * If a script file was specified then source that file.
   */
  if (fileName) 
    if (Tcl_EvalFile(interp, fileName) != TCL_OK) 
      goto error;

  return self;

 error:
  msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  if (msg == NULL) {
    msg = interp->result;
  }
  [self error:msg];
  [self free];
  return nil;
}

- init
{
  return [self initWithArgc:0 argv:NULL];
}

- free
{
  int i;

  /* this weirdness to get around a bug in removeObject: */
  for (i = [tclList count]-1; i >= 0; i--)
    if ([tclList objectAt:i] == self)
      {
	[tclList removeObjectAt:i];
	break;
      }

  Tcl_DeleteInterp(interp);
  [namesToObjects free];
  [objectsToNames free];
  return [super free];
}

- eval: (char *)fmt, ...
{
  char command[512];
  va_list ap;
  vsprintf(command, fmt, ap);
  code = Tcl_Eval(interp, command);
  if (code != TCL_OK)
    {
      fprintf(stderr, "(Tcl -eval:) %s\n", interp->result);
      fprintf(stderr, "while evaluating: %s\n", command);
    }
  va_end(ap);
  return self;
}

- globalEval: (char *)fmt, ...
{
  char command[512];
  va_list ap;
  vsprintf(command, fmt, ap);
  code = Tcl_GlobalEval(interp, command);
  if (code != TCL_OK)
    {
      fprintf(stderr, "(Tcl -eval:) %s\n", interp->result);
      fprintf(stderr, "while evaluating: %s\n", command);
    }
  va_end(ap);
  return self;
}

- (BOOL) variableExists: (const char *)varName
{
  return (Tcl_GetVar(interp, (char*)varName, 0) != NULL);
}

- (const char *) variableValue: (const char *)varName
{
  return Tcl_GetVar(interp, (char*)varName, 0);
}

- (int) code
{
  return code;
}

- (const char *) result
{
  return interp->result;
}

- (Tcl_Interp *) interp
{
  return interp;
}

/* I should make all these rely on the intepretter's hash tables instead.
   That way we can get names defined by Tcl "set" commands too. */

- registerObject: (id)anObject withName: (const char *)aName
{
  [namesToObjects insertKey:(char *)aName value:anObject];
  [objectsToNames insertKey:anObject value:(char *)aName];
  tclObjc_registerObjectWithName(interp, anObject, aName);
  return self;
}

- unregisterObject: (id)anObject
{
  char *name = 
    (char *)[objectsToNames valueForKey:anObject];

  tclObjc_unregisterObjectNamed(interp, name);
  [objectsToNames removeKey:anObject];
  [namesToObjects removeKey:name];
  return self;
}

- unregisterObjectNamed:(const char *)aName
{
  return [self unregisterObject:
	       [namesToObjects valueForKey:(char *)aName]];
}

- (const char *) nameForObject:anObject
{
  return [objectsToNames valueForKey:anObject];
}
    
- objectNamed:(const char *)aName
{
  id theObject = nil;
  unsigned int ptr;
  
  if (aName && aName[0] == '0' && aName[1] == 'x') {
    sscanf(aName, "%x", &ptr);
    theObject = (id)ptr;
    return theObject;
  }
  return [namesToObjects valueForKey:(char *)aName];
}

- (BOOL) objectIsRegistered: anObject
{
  return [objectsToNames isKey:anObject];
}

- (BOOL) nameIsRegistered: (const char *)aName
{
  return [namesToObjects isKey:(char *)aName];
}

- promptAndEval
{
    char buffer[1000], *cmd;
    int result, gotPartial, tty;
    static Tcl_DString command;	/* Used to buffer incomplete commands being
				 * read from stdin. */

//    return [self notImplemented:_cmd];

    gotPartial = 0;
    //    tty = isatty(0);
    tty = 1;
    Tcl_DStringInit(&command);
    while (1) {
	clearerr(stdin);
	if (!gotPartial && tty) {
	    fputs("% ", stdout);
	    fflush(stdout);
	}
	if (fgets(buffer, 1000, stdin) == NULL) {
	    if (!gotPartial) {
	      //		exit(0);
	      printf("\n");
	      return self;
	    }
	    buffer[0] = 0;
	}
	cmd = Tcl_DStringAppend(&command, buffer, -1);
	if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) {
	    gotPartial = 1;
	    continue;
	}

	gotPartial = 0;
	result = Tcl_RecordAndEval(interp, cmd, 0);
	Tcl_DStringFree(&command);
	if (result != TCL_OK) {
	    fprintf(stderr, "%s\n", interp->result);
	} else if (tty && (*interp->result != 0)) {
	    printf("%s\n", interp->result);
	}
    }
    return self;
}

@end

