This is Tcl.m in view mode; [Download] [Up]
/* 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
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.