This is Tcl.m in view mode; [Download] [Up]
/* 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 "coll/List.h"
#include "coll/HashTable.h"
#endif /* NeXT */
#include "Tcl.h"
#include "tclObjc.h"
#include <stdio.h>
#include <stdarg.h>
#if HAVE_READLINE
#include <readline/readline.h>
#include <readline/history.h>
#endif /* HAVE_READLINE */
#define DEFAULT_PROMPT "Tcl% "
#define DEFAULT_PARTIAL_PROMPT "Tcl> "
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;
}
}
+ tclAtIndex: (unsigned) index
{
if (index < [tclList count])
return [tclList objectAt:index];
return nil;
}
+ (unsigned) tclCount
{
return [tclList count];
}
- (char *) preInitWithArgc: (int)argc argv: (char**)argv
{
char *args, 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);
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. */
tcl_RcFileName = "~/.wishrc";
return fileName;
}
- initWithArgc: (int)argc argv: (char**)argv
{
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, 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];
}
- eval: (char *)fmt, ...
{
char cmd[512]; /* Ugly constant. Get rid of this */
va_list ap;
va_start(ap,fmt);
vsprintf(cmd, fmt, ap);
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:) %s\n", msg);
fprintf(stderr, "while evaluating: %s\n", cmd);
}
va_end(ap);
return self;
}
- globalEval: (char *)fmt, ...
{
char cmd[512];
va_list ap;
va_start(ap,fmt);
vsprintf(cmd, fmt, ap);
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:) %s\n", msg);
fprintf(stderr, "while evaluating: %s\n", 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:) %s\n", msg);
fprintf(stderr, "while evaluating contents of file %s\n", 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 variable\n", 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 variable\n", 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;
char *cmd;
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, "%s\n", interp->result);
else
printf("%s\n", interp->result);
}
return self;
}
#else /* HAVE_READLINE */
{
char buffer[1000], *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(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 (*interp->result != 0) {
printf("%s\n", interp->result);
}
}
return self;
}
#endif /* HAVE_READLINE */
@end
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.