信息检索与抽取

开发平台：
Unix_Linux

TclInterp.m：源码内容
							/* Implementation for Objective-C Tcl interpreter 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.
*/ 
#ifdef NeXT
#include "objc-gnu2next.h"
#include <objc/List.h>
#include <objc/HashTable.h>
#else
#include "List.h"
#include "HashTable.h"
#endif /* NeXT */
#include "TclInterp.h"
#include "tclObjc.h"
#include <misc.h>
#if HAVE_READLINE
#include <readline/readline.h>
#include <readline/history.h>
#endif /* HAVE_READLINE */
#define DEFAULT_PROMPT "Tcl% "
#define DEFAULT_PARTIAL_PROMPT "Tcl> "
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 4)
#define SUBDIR "tcl8.4"
#elif (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 3)
#define SUBDIR "tcl8.3"
#elif (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 2)
#define SUBDIR "tcl8.2"
#elif (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION == 1)
#define SUBDIR "tcl8.1"
#else
#define SUBDIR "tcl8.0"
#endif
#ifdef __CYGWIN__
#include <unistd.h> // MAXPATHLEN
#include <sys/cygwin.h> // cygwin_conv_to_win32_path
#endif
/* If we're using tcl 7.4 or greater, must make tcl_RcFileName reference
 * be extern or else we get a linker conflict. In tcl 7.3, you must
 * declare it here or else it links in the wrong file.
 *
 * And the variable was changed for tcl 7.5 from a C variable to a 
 * Tcl variable, so it doesn't have to be declared here anymore.  
 * These defines were moved to TclInterp.h. 
 */
#if (TCLVERSIONLT74 == 0)
#   if (TCLVERSIONGT74 == 0)
extern char* tcl_RcFileName;
#   endif
#else
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. */
#endif
List* tclList;
@implementation TclInterp
+ initialize
{
  if (self == [TclInterp class])
    {
      tclList = [[List alloc] init];
    }
  return self;
}
+ firstTcl
{
  if ([tclList count])
    return [tclList objectAt:0];
  else
    {
      fprintf(stderr, "no firstTcln");
      return nil;
    }
}
+ tclAtIndex: (unsigned) index
{
  if (index < [tclList count])
    return [tclList objectAt:index];
  return nil;
}
+ (unsigned) tclCount
{
  return [tclList count];
}
- setSecondaryLibraryPath: (const char *)path
{
  secondaryPath = path;
  return self;
}
- (const char *)checkPath: (const char *)path
             subdirectory: (const char *)subdir
                     file: (const char *)file
{
  if (path == NULL)
    return NULL;
  else
    {
      size_t path_len = strlen (path);
      size_t subdir_len = subdir ? strlen (subdir) + 1 : 0;
      size_t len = path_len + 1 + subdir_len + strlen (file) + 1;
      char *dirbuf = malloc (len);
      char filebuf[len + strlen (file) + 1];
      if (dirbuf == NULL)
        abort ();
      strcpy (dirbuf, path);
      if (path[path_len - 1] != '/')
        strcat (dirbuf, "/");
      if (subdir)
        {
          strcat (dirbuf, subdir);
          strcat (dirbuf, "/");
        }
      strcpy (filebuf, dirbuf);
      strcat (filebuf, file);
      if (access (filebuf, R_OK) != -1)
        return dirbuf;
      else 
        {
          free (dirbuf);
          return NULL;
        }
    }
}
const char *
fix_tcl_path (const char *path)
{
#ifndef __CYGWIN__
  return path;
#else
  char buf[MAXPATHLEN + 1], *p;
  
  cygwin_conv_to_win32_path (path, buf);
  
  p = buf;
  while (*p)
    {
      if (*p == '\')
	*p = '/';
      p++;
      }
  return xstrdup (buf);
#endif
}
- (const char *)checkTclLibrary
{
  const char *path;
  if ([self checkPath: TCL_LIBRARY subdirectory: NULL file: "init.tcl"])
    path = TCL_LIBRARY;
  else
    path =
      [self checkPath: secondaryPath subdirectory: SUBDIR file: "init.tcl"];
  return fix_tcl_path (path);
}
- (const char *)preInitWithArgc: (int)argc argv: (const char **)argv
{
  const char *args;
  const 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:"*"];
  /* This calls Tcl_FindEncoding which ends up
     calling TclWinSetInterfaces which sets getFileAttributesExProc 
     which will be used by TclpObjNormalizePath. */
  Tcl_FindExecutable (argv[0]);
  /* Create and init tcl interpreter */
  interp = Tcl_CreateInterp ();
  {
    const char *path = [self checkTclLibrary];
    
    if (path)
      {
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        extern void TclSetLibraryPath (Tcl_Obj *pathPtr);
        Tcl_Obj *pathObj = Tcl_NewStringObj (path, -1);
        TclSetLibraryPath (Tcl_NewListObj (1, &pathObj));
#else
        Tcl_SetVar (interp, "tcl_library", (char *) path, TCL_GLOBAL_ONLY);
#endif
      }
    else
      {
        char *msg = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
        if (msg == NULL)
          msg = interp->result;
        [self error:msg];
        abort ();
      }
  }
  /*
   * 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, (char **)argv+1);
  Tcl_SetVar (interp, "argv", (char *)args, TCL_GLOBAL_ONLY);
  ckfree ((void *)args);
  {
    char buffer[20];
    
    sprintf (buffer, "%d", argc-1);
    Tcl_SetVar (interp, "argc", buffer, TCL_GLOBAL_ONLY);
  }
  Tcl_SetVar (interp, "argv0",
              (char *)((fileName != NULL) ? fileName : argv[0]),
              TCL_GLOBAL_ONLY);
  
  Tcl_SetVar (interp, "tcl_interactive", "1", TCL_GLOBAL_ONLY);
  Tcl_SetVar (interp, "tclObjc", tclObjc_objectToName(self), TCL_GLOBAL_ONLY);
  
  if (Tcl_Init (interp) == TCL_ERROR || TclObjc_Init(interp) == TCL_ERROR)
    {
      char *msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
      if (msg == NULL)
	msg = interp->result;
      [self error:msg];
      return NULL;		/* shouldn't get here anyway */
    }
  /* Specify a user-specific startup file to invoke if the application
     is run interactively.  Typically the startup file is "~/.apprc"
     where "app" is the name of the application.  If this line is
     deleted then no user-specific startup file will be run under any
     conditions. */
#if (TCLVERSIONGT74 == 1)
  Tcl_SetVar(interp, "tcl_rcFileName", "~/.wishrc", TCL_GLOBAL_ONLY);
#else
  tcl_RcFileName = "~/.wishrc";
#endif
  return fileName;
}
- initWithArgc: (int)argc argv: (const char **)argv
{
  const char *fileName, *msg;
  [super init];
#if HAVE_READLINE
  if (argc)
    rl_readline_name = argv[0];
#endif
  fileName = [self preInitWithArgc:argc argv:argv];
  tclObjc_registerObjectWithName(interp, self, "objcTcl");
  /* If a script file was specified then source that file. */
  if (fileName) 
    if (Tcl_EvalFile(interp, (char *)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
{
  [tclList removeObject:self];
  Tcl_DeleteInterp(interp);
  [namesToObjects free];
  [objectsToNames free];
  return [super free];
}
- setEvalDebugPrint: (BOOL) value
{
  evalDebugPrint = value;
  return self;
}
- eval: (const char *)fmt, ...
{
  char cmd[32768];   /* Ugly constant.  Get rid of this */
  va_list ap;
  va_start(ap,fmt);
  vsprintf(cmd, fmt, ap);
  if (evalDebugPrint)
    fprintf(stderr, "%sn", cmd);
  code = Tcl_Eval(interp, cmd);
  if (code != TCL_OK)
    {
      char *msg;
      msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
      if (msg == NULL) {
	msg = interp->result;
      }
      fprintf(stderr, "(Tcl -eval:) %sn", msg);
      fprintf(stderr, "while evaluating: %sn", cmd);
    }
  va_end(ap);
  return self;
}
- globalEval: (const char *)fmt, ...
{
  char cmd[4096];
  va_list ap;
  va_start(ap,fmt);
  vsprintf(cmd, fmt, ap);
  if (evalDebugPrint)
    fprintf(stderr, "(global) %sn", cmd);
  code = Tcl_GlobalEval(interp, cmd);
  if (code != TCL_OK)
    {
      char *msg;
      msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
      if (msg == NULL) {
	msg = interp->result;
      }
      fprintf(stderr, "(Tcl -eval:) %sn", msg);
      fprintf(stderr, "while evaluating: %sn", cmd);
    }
  va_end(ap);
  return self;
}
- evalFile: (const char *)filename
{
  if ((code = Tcl_EvalFile(interp, (char*)filename)) != TCL_OK) 
    {
      char *msg;
      msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
      if (msg == NULL) {
	msg = interp->result;
      }
      fprintf(stderr, "(Tcl -evalFile:) %sn", msg);
      fprintf(stderr, "while evaluating contents of file %sn", filename);
    }
  return self;
}
- (BOOL) variableExists: (const char *)varName
{
  return (Tcl_GetVar(interp, (char*)varName, 0) != NULL);
}
- (BOOL) globalVariableExists: (const char *)varName
{
  return (Tcl_GetVar(interp, (char*)varName, TCL_GLOBAL_ONLY) != NULL);
}
- (const char *) variableValue: (const char *)varName
{
  const char *v = Tcl_GetVar(interp, (char*)varName, 0);
  if (!v)
    fprintf(stderr, "(Tcl variableValue:) %s isn't a variablen", varName);
  return v;
}
- (const char *) globalVariableValue: (const char *)varName
{
  const char *v = Tcl_GetVar(interp, (char*)varName, TCL_GLOBAL_ONLY);
  if (!v)
    fprintf(stderr, "(Tcl variableValue:) %s isn't a variablen", varName);
  return v;
}
- (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: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:
	       (id)[namesToObjects valueForKey:(char *)aName]];
}
- (const char *) nameForObject:anObject
{
  return (char *)[objectsToNames valueForKey:anObject];
}
    
- objectNamed:(const char *)aName
{
  id theObject = nil;
  if ((theObject = tclObjc_nameToObject(aName)) != (id)-1)
    return theObject;
  else if ((theObject = [namesToObjects valueForKey:aName]))
    return theObject;
  return (id)-1;
}
- (BOOL) objectIsRegistered: anObject
{
  return [objectsToNames isKey:anObject];
}
- (BOOL) nameIsRegistered: (const char *)aName
{
  return [namesToObjects isKey:aName];
}
- promptAndEval
#if HAVE_READLINE
{
  Tcl_DString command;
  const char *cmd;
  const char *line;
  int result;
  int gotPartial = 0;
      
  Tcl_DStringInit(&command);
  while (1)
    {
      /* I could add code to do something like tcl_prompt1 */
      if (gotPartial)
	line = readline(DEFAULT_PARTIAL_PROMPT);
      else
	line = readline(DEFAULT_PROMPT);
      if (!line)
	{
	  printf("n");
	  return self;
	}
      add_history(line);
      cmd = Tcl_DStringAppend(&command, line, -1);
      free(line);
      if (!Tcl_CommandComplete(cmd))
	{
	  gotPartial = 1;
	  continue;
	}
      gotPartial = 0;
      result = Tcl_RecordAndEval(interp, cmd, 0);
      Tcl_DStringFree(&command);
      if (result != TCL_OK)
	fprintf(stderr, "%sn", interp->result);
      else
	printf("%sn", interp->result);
    }
  return self;
}
#else /* HAVE_READLINE */
{
    char buffer[1000];
    const char *cmd;
    int result, gotPartial;
    static Tcl_DString command;	/* Used to buffer incomplete commands being
				 * read from stdin. */
    gotPartial = 0;
    Tcl_DStringInit(&command);
    for (;;) {
	clearerr(stdin);
	/* I could add code to do something like tcl_prompt1 */
	if (gotPartial)
	  fputs (DEFAULT_PARTIAL_PROMPT, stdout);
	else
	  fputs (DEFAULT_PROMPT, stdout);
	fflush (stdout);
	if (fgets (buffer, 1000, stdin) == NULL) {
	    if (!gotPartial) {
	      printf("n");
	      return self;
	    }
	    buffer[0] = 0;
	}
	cmd = Tcl_DStringAppend(&command, buffer, -1);
	if ((buffer[0] != 0) && !Tcl_CommandComplete ((char *)cmd)) {
	    gotPartial = 1;
	    continue;
	}
	gotPartial = 0;
	result = Tcl_RecordAndEval (interp, (char *)cmd, 0);
	Tcl_DStringFree(&command);
	if (result != TCL_OK) {
	    fprintf(stderr, "%sn", interp->result);
	} else if (*interp->result != 0) {
	    printf("%sn", interp->result);
	}
    }
    return self;
}
#endif /* HAVE_READLINE */
@end

						