stk/Src/tcl-lib.c

/*
 *
 * t c l - l i b . c 		- A library remplacement for simulating 
 *				  a Tcl interpreter in Scheme
 *
 * Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
 * 
 *
 * Permission to use, copy, and/or distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that both the above copyright notice and this permission notice appear in
 * all copies and derived works.  Fees for distribution or use of this
 * software or derived works may only be charged with express written
 * permission of the copyright holder.  
 * This software is provided ``as is'' without express or implied warranty.
 *
 * This software is a derivative work of other copyrighted softwares; the
 * copyright notices of these softwares are placed in the file COPYRIGHTS
 *
 *
 *            Author: Erick Gallesio [eg@unice.fr]
 *    Creation date: 19-Feb-1993 22:15
 * Last file update:  7-Jun-1998 18:13
 *
 */


#include "stk.h"
#include "module.h"

#ifdef USE_TK
#  include "tk-glue.h"
#else
#  include "tclInt.h"
#endif


#ifdef USE_TK
#define BUFF_SIZE 100
/******************************************************************************
 *
 *				Eval functions
 *
 ******************************************************************************/

int Tcl_GlobalEval(interp, s)
     Tcl_Interp *interp;
     char *s;
{
  char buffer[BUFF_SIZE+3], *ptr = buffer;
  SCM result;

  /* 
   * If the callback is nor surrounded by parenthesis, add them. We
   * don't have parenthesis when the callback is a closure. In this
   * case, the callback is simply #p12345. Note that this allow Tk to
   * add some parameters to the callback when needed (on bindings, or
   * scrollbars for instance). To recognize such cases, we look at
   * first character: if it is not an open parenthesis, we add a pair
   * of () around the callback string
   *     
   */
  if (*s == '\0') return TCL_OK;
  if (*s != '(') {
    /* Build the command to evaluate by adding a pair of parenthesis */
    int len = strlen(s);
    
    if (len > BUFF_SIZE) 
      ptr = (char *) must_malloc(len+3);
    sprintf(ptr, "(%s)", s);
    s = ptr;
  }
  result = STk_internal_eval_string(s, ERR_TCL_BACKGROUND, MOD_ENV(STk_Tk_module));
  Tcl_ResetResult(interp);
    
  if (ptr != buffer) free(ptr);

  if (result != EVAL_ERROR) {
    SCM dumb;

    Tcl_SetResult(interp, 
		  STk_stringify(STk_convert_for_Tcl(result, &dumb), 0), 
		  TCL_DYNAMIC);
    /* 
     * Store also the "true" result in STk_last_Tk_result
     * Warning: This pointer inot GC protected. We have to use it very soon 
     * This is a kludge (used in text window)
     */
     STk_last_Tk_result = result;
       
     return (result == Sym_break) ? TCL_BREAK : TCL_OK;
  }
  
  return TCL_ERROR;
}

int Tcl_Eval(interp, s) 	/* very simplist. */
     Tcl_Interp *interp;	/* But do we need something more clever? */
     char *s;
{
  return Tcl_GlobalEval(interp, s);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_VarEval --
 *
 *	Given a variable number of string arguments, concatenate them
 *	all together and execute the result as a Tcl command.
 *
 * Results:
 *	A standard Tcl return result.  An error message or other
 *	result may be left in interp->result.
 *
 * Side effects:
 *	Depends on what was done by the command.
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */ /* ARGSUSED */
int
Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
    va_list argList;
    Tcl_DString buf;
    char *string;
    Tcl_Interp *interp;
    int result;

    /*
     * Copy the strings one after the other into a single larger
     * string.  Use stack-allocated space for small commands, but if
     * the command gets too large than call ckalloc to create the
     * space.
     */

    interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
    Tcl_DStringInit(&buf);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	Tcl_DStringAppend(&buf, string, -1);
    }
    va_end(argList);

    result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
    Tcl_DStringFree(&buf);
    return result;
}

/******************************************************************************
 *
 *	      Variable accesses (GetVar, GetVar2, SetVar, SetVar2)
 *
 ******************************************************************************/

char *Tcl_GetVar(interp, var, flags)
     Tcl_Interp *interp;	/* not used */
     char *var;
     int flags;
{
  Debug("Usage of Tcl_GetVar for ", STk_makestring(var));
  return STk_tcl_getvar(var, "#f");
}

char *Tcl_GetVar2(interp, name1, name2, flags)
     Tcl_Interp *interp;	/* not used */
     char *name1, *name2;
     int flags;
{
  Debug("Usage of Tcl_GetVar2 for ", STk_makestring(name1));
  return STk_tcl_getvar2(name1, name2, "#f");

}

char *Tcl_SetVar(interp, var, val, flags)
     Tcl_Interp *interp;
     char *var, *val;
     int flags;
{
  Debug("Usage of Tcl_SetVar for ", STk_makestring(var));
  return STk_tcl_setvar(var, val, flags, "#f");
}

char *Tcl_SetVar2(interp, name1, name2, val, flags)
     Tcl_Interp *interp;
     char *name1, *name2, *val;
     int flags;
{ 
  Debug("Usage of Tcl_SetVar for ", STk_makestring(name1));
  return STk_tcl_setvar2(name1, name2, val, flags, "#f");
}

/******************************************************************************
 *
 *			    Tcl command management
 *
 ******************************************************************************/

int Tcl_internal_DeleteCommand(interp, cmdName)
  Tcl_Interp *interp;
  char *cmdName;
{
  struct Tk_command *W;
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  
  /* the internal DeleteCommand do all the job (except setting cmdName to
   * UNBOUND, because this implies to use intern which can allocate a cell)
   * Consequently, GC calls this function, whereas Tk call the true 
   * DeleteCommand
   */
  hPtr = Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName);
  if (hPtr == NULL) return -1;

  W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  if (W->deleted) return -1;

  /* Execute the delete handler */
  if (W->delproc != NULL) (*W->delproc)(W->deldata);

  /* Note: W will be freed by the GC */
  Tcl_DeleteHashEntry(hPtr);

  /* Delete the command from the callbacks hash table */
  STk_delete_callback(cmdName);

  /* Remember that the command has been deleted */
  W->deleted = 1;

  return 0;
}
  

int Tcl_DeleteCommand(interp, cmdName)
     Tcl_Interp *interp;
     char *cmdName;
{
  int result;

  if (result = Tcl_internal_DeleteCommand(interp, cmdName))
    return result;
  
  /* Undefine "cmdName" by doing a (set! cmdname #<unbound>) */
  STk_define_variable(cmdName, UNBOUND, STk_Tk_module);

  return 0;
}


/* 
 * Tcl_DeleteCommandFromToken --
 *
 *	Removes the given command from the given interpreter. This procedure
 *	resembles Tcl_DeleteCommand, but takes a Tcl_Command token instead
 *	of a command name for efficiency.
 */

int
Tcl_DeleteCommandFromToken(interp, cmd)
    Tcl_Interp *interp;		/* Token for command interpreter returned by
				 * a previous call to Tcl_CreateInterp. */
    Tcl_Command cmd;            /* Token for command to delete. */
{
  /* In STk this function is less efficient than the Tcl one since it 
   * searches the name of the given command and call Tcl_DeleteCommand
   * However, the time penalty should be lower than in Tcl here.
   */
  return Tcl_DeleteCommand(interp, Tcl_GetCommandName(interp, cmd));
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateCommand --
 *
 *	Define a new command in a command table.
 *
 * Results:
 *	The return value is a token for the command, which can
 *	be used in future calls to Tcl_NameOfCommand.
 *
 * Side effects:
 *	If a command named cmdName already exists for interp, it is
 *	deleted.
 *----------------------------------------------------------------------
 */
Tcl_Command
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
    Tcl_Interp *interp;		/* Token for command interpreter (returned
				 * by a previous call to Tcl_CreateInterp). */
    char *cmdName;		/* Name of command. */
    Tcl_CmdProc *proc;		/* Command procedure to associate with
				 * cmdName. */
    ClientData clientData;	/* Arbitrary one-word value to pass to proc. */
    Tcl_CmdDeleteProc *deleteProc;
				/* If not NULL, gives a procedure to call when
				 * this command is deleted. */
{
  struct Tk_command * W;
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  int new;
  SCM z;

  /* 
   * There are two things to do here.  
   * 	- We must create a new variable and associate the newly
   * 	  created Tk object to it. This is the Scheme part.
   *    - We must  store the cmd in a hashtable contained in the interp data
   *      structure. This is necessary to delete all the command associated
   *      to the interpreter. This is important at least for the "send"
   *      command which un-register the interpreter from the X server.
   * 
   */

  /* Initialize the Tk_command structure */
  W = (struct Tk_command *)must_malloc(sizeof(struct Tk_command)+strlen(cmdName));
  W->ptr	= clientData;
  W->fct 	= proc;
  W->delproc    = deleteProc;
  W->deldata	= clientData;
  W->deleted	= 0;
  W->objproc	= 0;
  strcpy(W->Id, cmdName);

  /* Register the command in the Tcl command hash table */
  hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdName, &new);
  if (!new) {
    /* Command already exists: delete the old one */
    Tcl_DeleteCommand(interp, cmdName); /* not efficient but safer */
  }
  Tcl_SetHashValue(hPtr, W);

  /* Define a Tk-command cell for this new command */
  NEWCELL(z, tc_tkcommand);
  z->storage_as.tk.data   = W;
  z->storage_as.tk.l_data = Ntruth;
    
  /* Define a variable whose name is the command name */
  STk_define_variable(cmdName, z, STk_Tk_module);

  return (Tcl_Command) W;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandName --
 *
 *	Given a token returned by Tcl_CreateCommand, this procedure
 *	returns the current name of the command (which may have changed
 *	due to renaming).
 *
 * Results:
 *	The return value is the name of the given command.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetCommandName(interp, command)
    Tcl_Interp *interp;		/* Interpreter containing the command. */
    Tcl_Command command;	/* Token for the command, returned by a
				 * previous call to Tcl_CreateCommand.
				 * The command must not have been deleted. */
{
  return ((struct Tk_command *) command)->Id;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetCommandInfo --
 *
 *	Returns various information about a Tcl command.
 *
 * Results:
 *	If cmdName exists in interp, then *infoPtr is modified to
 *	hold information about cmdName and 1 is returned.  If the
 *	command doesn't exist then 0 is returned and *infoPtr isn't
 *	modified.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
    Tcl_Interp *interp;			/* Interpreter in which to look
					 * for command. */
    char *cmdName;			/* Name of desired command. */
    Tcl_CmdInfo *infoPtr;		/* Where to store information about
					 * command. */
{
    SCM v;
    struct Tk_command *p;
    
    v = STk_lookup_variable(cmdName, STk_Tk_module);
    if (NTKCOMMP(v)) return 0;

    p =  v->storage_as.tk.data;

    infoPtr->proc       = p->fct;
    infoPtr->clientData = p->ptr;
    infoPtr->deleteProc = p->delproc;;
    infoPtr->deleteData = NULL;
    return 1;
}


/******************************************************************************
 *
 *			  Tcl interpreter management
 *
 ******************************************************************************/

Tcl_Interp *Tcl_CreateInterp()
{
  register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp));
  
  iPtr->result		 = iPtr->resultSpace;
  iPtr->freeProc	 = 0;
  iPtr->errorLine	 = 0;
  iPtr->resultSpace[0]   = 0;
  
  iPtr->appendResult	 = NULL;
  iPtr->appendAvl	 = 0;
  iPtr->appendUsed	 = 0;

  /* strcpy(iPtr->pdFormat, "%g"); No more needed for 8.0 */

  iPtr->assocData 	 = (Tcl_HashTable *) NULL;

  /* See Tcl_CreateCommand for this table utility  */
  iPtr->globalNsPtr	= (Namespace*) STk_must_malloc(sizeof(Namespace));
  Tcl_InitHashTable(&iPtr->globalNsPtr->cmdTable, TCL_STRING_KEYS);

  /* Protect the Tcl_Obj result */
  Tcl_ResetObjResult(iPtr);
  STk_gc_protect((SCM*) &(iPtr->objResultPtr));

  return (Tcl_Interp *) iPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetAssocData --
 *
 *	Creates a named association between user-specified data, a delete
 *	function and this interpreter. If the association already exists
 *	the data is overwritten with the new data. The delete function will
 *	be invoked when the interpreter is deleted.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets the associated data, creates the association if needed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetAssocData(interp, name, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter to associate with. */
    char *name;			/* Name for association. */
    Tcl_InterpDeleteProc *proc;	/* Proc to call when interpreter is
                                 * about to be deleted. */
    ClientData clientData;	/* One-word value to pass to proc. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;
    int new;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
	if (iPtr->flags & DELETED) {
	    /*
	     * Don't create new entries after interpreter deletion
	     * has started;  it isn't even safe to muck with the
	     * interpreter right now
	     */

	    return;
	}
        iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
        Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
    }
    hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
    if (new == 0) {
        dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    } else {
        dPtr = (AssocData *) ckalloc(sizeof(AssocData));
    }
    dPtr->proc = proc;
    dPtr->clientData = clientData;

    Tcl_SetHashValue(hPtr, dPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteAssocData --
 *
 *	Deletes a named association of user-specified data with
 *	the specified interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Deletes the association.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DeleteAssocData(interp, name)
    Tcl_Interp *interp;			/* Interpreter to associate with. */
    char *name;				/* Name of association. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    ckfree((char *) dPtr);
    Tcl_DeleteHashEntry(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetAssocData --
 *
 *	Returns the client data associated with this name in the
 *	specified interpreter.
 *
 * Results:
 *	The client data in the AssocData record denoted by the named
 *	association, or NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_GetAssocData(interp, name, procPtr)
    Tcl_Interp *interp;			/* Interpreter associated with. */
    char *name;				/* Name of association. */
    Tcl_InterpDeleteProc **procPtr;	/* Pointer to place to store address
					 * of current deletion callback. */
{
    Interp *iPtr = (Interp *) interp;
    AssocData *dPtr;
    Tcl_HashEntry *hPtr;

    if (iPtr->assocData == (Tcl_HashTable *) NULL) {
        return (ClientData) NULL;
    }
    hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
    if (hPtr == (Tcl_HashEntry *) NULL) {
        return (ClientData) NULL;
    }
    dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
    if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
        *procPtr = dPtr->proc;
    }
    return dPtr->clientData;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InterpDeleted --
 *
 *	Returns nonzero if the interpreter has been deleted with a call
 *	to Tcl_DeleteInterp.
 *
 * Results:
 *	Nonzero if the interpreter is deleted, zero otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_InterpDeleted(interp)
    Tcl_Interp *interp;
{
    return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
}
/*
 *----------------------------------------------------------------------
 *
 * Tcl_DeleteInterp --
 *
 *	Delete an interpreter and free up all of the resources associated
 *	with it.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The interpreter is destroyed.  The caller should never again
 *	use the interp token.
 *
 *----------------------------------------------------------------------
 */
void Tcl_DeleteInterp(interp)
    Tcl_Interp *interp;
{
  Interp *iPtr = (Interp *) interp;
  Tcl_HashEntry *hPtr;
  Tcl_HashSearch search;
  struct Tk_command *W;

  if (!iPtr || (iPtr->flags & DELETED)) return;

  /* Mark the interpreter as deleted. No further evals will be allowed. */
  iPtr->flags |= DELETED;
  
  /* Delete result space */
  if (iPtr->appendResult != NULL) {
    ckfree(iPtr->appendResult);
  }
  
  /* delete hash table of Tk commands (see Tcl_CreateCommand) */
  for (hPtr = Tcl_FirstHashEntry(&iPtr->globalNsPtr->cmdTable, &search);
       hPtr != NULL; 
       hPtr = Tcl_NextHashEntry(&search)) {
    W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
    Tcl_DeleteCommand(interp, W->Id);
  }
  Tcl_DeleteHashTable(&iPtr->globalNsPtr->cmdTable);

  /* Unprotect the Tcl_Obj result */
  STk_gc_unprotect((SCM*) &(iPtr->objResultPtr));

  ckfree((char *) iPtr);
}



/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetOpenFile --
 *
 *	Given a name of a channel registered in the given interpreter,
 *	returns a FILE * for it.
 *
 * Results:
 *	A standard Tcl result. If the channel is registered in the given
 *	interpreter and it is managed by the "file" channel driver, and
 *	it is open for the requested mode, then the output parameter
 *	filePtr is set to a FILE * for the underlying file. On error, the
 *	filePtr is not set, TCL_ERROR is returned and an error message is
 *	left in interp->result.
 *
 * Side effects:
 *	May invoke fdopen to create the FILE * for the requested file.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
    Tcl_Interp *interp;		/* Interpreter in which to find file. */
    char *string;		/* String that identifies file. */
    int forWriting;		/* 1 means the file is going to be used
				 * for writing, 0 means for reading. */
    int checkUsage;		/* 1 means verify that the file was opened
				 * in a mode that allows the access specified
				 * by "forWriting". Ignored, we always
                                 * check that the channel is open for the
                                 * requested mode. */
    ClientData *filePtr;	/* Store pointer to FILE structure here. */
{
  SCM port;

  if ((string[0] == '#') && (string[1] == 'f') && (string[2] == 'i')
      && (string[3] == 'l') && string[4] == 'e') {
    char *end;
    
    port = (SCM) strtoul(string+5, &end, 16);
    if ((end != string+5) && (*end == 0)) {
      /* Verify the given address is a port */
      if (STk_valid_address(port) && (IPORTP(port) || OPORTP(port))) {
	/* Verify the port usage  */
	if (checkUsage && (PORT_FLAGS(port) & PORT_CLOSED)) {
	  Tcl_AppendResult(interp, "\"", string,
			   "\" is closed", (char *) NULL);
	  return TCL_ERROR;
	}
	if (forWriting) {
	  if (checkUsage && !OPORTP(port)) {
	    Tcl_AppendResult(interp, "\"", string,
		    "\" wasn't opened for writing", (char *) NULL);
	    return TCL_ERROR;
	  }
	}
	else {
	   if (!IPORTP(port)) {
	     Tcl_AppendResult(interp, "\"", string,
			      "\" wasn't opened for reading", (char *) NULL);
	     return TCL_ERROR;
	   }
	}
	
	/* File is correct; return it in filePtr */
	*filePtr = PORT_FILE(port);
	return TCL_OK;
      }
    }
  }
  Tcl_AppendResult(interp, "Bad file specification \"", string,
		    "\"", (char *) NULL);
  return TCL_ERROR; 
}
#endif

/******************************************************************************
 *
 * Tcl channels simulation.
 *
 *	Current version is very minimal. It should probably be extended to be 
 *	more Tcl compatible, since Tcl model is very neat.
 *
 ******************************************************************************/

Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName, 
				char *modeString, int permissions)
{
  FILE *f = fopen(fileName, modeString);
  
  if (f == NULL) {
    if (interp != (Tcl_Interp *) NULL) {
      Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
		       Tcl_PosixError(interp), (char *) NULL);
    }
  }
  return (Tcl_Channel) f;
}

int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
{
  return fclose((FILE *) chan);
}

int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
{
  clearerr((FILE*) chan);
  return fread(bufPtr, 1, toRead, (FILE*) chan);
}

int Tcl_Write(Tcl_Channel chan, char *s, int slen)
{
  int len = (slen < 0) ? strlen(s) : slen;
  
  return fwrite(s, 1, len, (FILE*) chan);
}


int Tcl_Seek(Tcl_Channel chan, int offset, int mode)
{
  int res;

  if ((res=fseek((FILE*) chan, (long) offset, mode)) != -1)
    return (int) ftell((FILE*) chan);

  return res;
}

int Tcl_Flush(Tcl_Channel chan)
{
  return fflush((FILE *) chan);
}

Tcl_Channel Tcl_GetStdChannel(int type) /*  TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
  switch (type) {
    case TCL_STDIN:  return (Tcl_Channel) STk_stdin;
    case TCL_STDOUT: return (Tcl_Channel) STk_stdout;
    case TCL_STDERR: return (Tcl_Channel) STk_stderr;
  }
  return NULL;
}

int Tcl_Eof(Tcl_Channel chan)		/* Does this channel have EOF? */
{
  return feof((FILE *) chan);
}

int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, char *optionName, 
			 char *newValue)
{
  /* Do nothing */
  return TCL_OK;
}

  

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinPath --
 *
 *	Combine a list of paths in a platform specific manner.
 *
 * Results:
 *	Appends the joined path to the end of the specified
 *	returning a pointer to the resulting string.  Note that
 *	the Tcl_DString must already be initialized.
 *
 * Side effects:
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(argc, argv, resultPtr)
    int argc;
    char **argv;
    Tcl_DString *resultPtr;	/* Pointer to previously initialized DString. */
{
    int oldLength, length, i, needsSep;
    Tcl_DString buffer;
    char *p, *dest;

    Tcl_DStringInit(&buffer);
    oldLength = Tcl_DStringLength(resultPtr);

#ifndef STk_CODE
    switch (tclPlatform) {
   	case TCL_PLATFORM_UNIX:
#endif
#ifndef WIN32
	    for (i = 0; i < argc; i++) {
		p = argv[i];
		/*
		 * If the path is absolute, reset the result buffer.
		 * Consume any duplicate leading slashes or a ./ in
		 * front of a tilde prefixed path that isn't at the
		 * beginning of the path.
		 */

		if (*p == '/') {
		    Tcl_DStringSetLength(resultPtr, oldLength);
		    Tcl_DStringAppend(resultPtr, "/", 1);
		    while (*p == '/') {
			p++;
		    }
		} else if (*p == '~') {
		    Tcl_DStringSetLength(resultPtr, oldLength);
		} else if ((Tcl_DStringLength(resultPtr) != oldLength)
			&& (p[0] == '.') && (p[1] == '/')
			&& (p[2] == '~')) {
		    p += 2;
		}

		if (*p == '\0') {
		    continue;
		}

		/*
		 * Append a separator if needed.
		 */

		length = Tcl_DStringLength(resultPtr);
		if ((length != oldLength)
			&& (Tcl_DStringValue(resultPtr)[length-1] != '/')) {
		    Tcl_DStringAppend(resultPtr, "/", 1);
		    length++;
		}

		/*
		 * Append the element, eliminating duplicate and trailing
		 * slashes.
		 */

		Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
		dest = Tcl_DStringValue(resultPtr) + length;
		for (; *p != '\0'; p++) {
		    if (*p == '/') {
			while (p[1] == '/') {
			    p++;
			}
			if (p[1] != '\0') {
			    *dest++ = '/';
			}
		    } else {
			*dest++ = *p;
		    }
		}
		length = dest - Tcl_DStringValue(resultPtr);
		Tcl_DStringSetLength(resultPtr, length);
	    }
#endif
#ifndef STk_CODE
	    break;
	case TCL_PLATFORM_WINDOWS:
#endif
#ifdef WIN32
	    /*
	     * Iterate over all of the components.  If a component is
	     * absolute, then reset the result and start building the
	     * path from the current component on.
	     */

	    for (i = 0; i < argc; i++) {
		p = ExtractWinRoot(argv[i], resultPtr, oldLength);
		length = Tcl_DStringLength(resultPtr);
		
		/*
		 * If the pointer didn't move, then this is a relative path
		 * or a tilde prefixed path.
		 */

		if (p == argv[i]) {
		    /*
		     * Remove the ./ from tilde prefixed elements unless
		     * it is the first component.
		     */

		    if ((length != oldLength)
			    && (p[0] == '.')
			    && ((p[1] == '/') || (p[1] == '\\'))
			    && (p[2] == '~')) {
			p += 2;
		    } else if (*p == '~') {
			Tcl_DStringSetLength(resultPtr, oldLength);
			length = oldLength;
		    }
		}

		if (*p != '\0') {
		    /*
		     * Check to see if we need to append a separator.
		     */
		    int c;
		    
		    if (length != oldLength) {
			c = Tcl_DStringValue(resultPtr)[length-1];
			if ((c != '/') && (c != ':')) {
			    Tcl_DStringAppend(resultPtr, "/", 1);
			}
		    }

		    /*
		     * Append the element, eliminating duplicate and
		     * trailing slashes.
		     */

		    length = Tcl_DStringLength(resultPtr);
		    Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
		    dest = Tcl_DStringValue(resultPtr) + length;
		    for (; *p != '\0'; p++) {
			if ((*p == '/') || (*p == '\\')) {
			    while ((p[1] == '/') || (p[1] == '\\')) {
				p++;
			    }
			    if (p[1] != '\0') {
				*dest++ = '/';
			    }
			} else {
			    *dest++ = *p;
			}
		    }
		    length = dest - Tcl_DStringValue(resultPtr);
		    Tcl_DStringSetLength(resultPtr, length);
		}
	    }
#endif
#ifndef STk_CODE
	    break;
	case TCL_PLATFORM_MAC:
	    needsSep = 1;
	    for (i = 0; i < argc; i++) {
		Tcl_DStringSetLength(&buffer, 0);
		p = SplitMacPath(argv[i], &buffer);
		if ((*p != ':') && (*p != '\0')
			&& (strchr(p, ':') != NULL)) {
		    Tcl_DStringSetLength(resultPtr, oldLength);
		    length = strlen(p);
		    Tcl_DStringAppend(resultPtr, p, length);
		    needsSep = 0;
		    p += length+1;
		}

		/*
		 * Now append the rest of the path elements, skipping
		 * : unless it is the first element of the path, and
		 * watching out for :: et al. so we don't end up with
		 * too many colons in the result.
		 */

		for (; *p != '\0'; p += length+1) {
		    if (p[0] == ':' && p[1] == '\0') {
			if (Tcl_DStringLength(resultPtr) != oldLength) {
			    p++;
			} else {
			    needsSep = 0;
			}
		    } else {
			c = p[1];
			if (*p == ':') {
			    if (!needsSep) {
				p++;
			    }
			} else {
			    if (needsSep) {
				Tcl_DStringAppend(resultPtr, ":", 1);
			    }
			}
			needsSep = (c == ':') ? 0 : 1;
		    }
		    length = strlen(p);
		    Tcl_DStringAppend(resultPtr, p, length);
		}
	    }
	    break;
			       
    }
#endif
    Tcl_DStringFree(&buffer);
    return Tcl_DStringValue(resultPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_IsSafe --
 *
 *	Determines whether an interpreter is safe
 *
 *----------------------------------------------------------------------
 */

int
Tcl_IsSafe(interp)
    Tcl_Interp *interp;		/* Is this interpreter "safe" ? */
{
  return STk_is_safe;		/* STk is always unsafe for now, but this 
				   could change ... */
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_HideCommand --
 *
 *	Makes a command hidden so that it cannot be invoked from within
 *	an interpreter, only from within an ancestor.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_HideCommand(interp, cmdName, hiddenCmdName)
    Tcl_Interp *interp;		/* Interpreter in which to hide command. */
    char *cmdName;		/* Name of hidden command. */
    char *hiddenCmdName;	/* Name of to-be-hidden command. */
{
  /* Easy job */
  return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WrongNumArgs --
 *
 *	This procedure generates a "wrong # args" error message in an
 *	interpreter.  It is used as a utility function by many command
 *	procedures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	An error message is generated in interp's result object to
 *	indicate that a command was invoked with the wrong number of
 *	arguments.  The message has the form
 *		wrong # args: should be "foo bar additional stuff"
 *	where "foo" and "bar" are the initial objects in objv (objc
 *	determines how many of these are printed) and "additional stuff"
 *	is the contents of the message argument.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_WrongNumArgs(interp, objc, objv, message)
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments to print
					 * from objv. */
    Tcl_Obj *CONST objv[];		/* Initial argument objects, which
					 * should be included in the error
					 * message. */
    char *message;			/* Error message to print after the
					 * leading objects in objv. */
{
    Tcl_Obj *objPtr;
    int i;
#ifdef STk_CODE
    int stk_hack = (objc == 2);
#endif
    
    objPtr = Tcl_GetObjResult(interp);
#ifdef STk_CODE
    Tcl_AppendToObj(objPtr, "wrong # args: should be (", -1);
    for (i = 0; i < objc; i++) {

      if (stk_hack && i == 1) {
	/* VERY VERY HACKY: place a quote in front of the second element
	 * of the message. This is a special case for messages such as
	 *      wrong # args: should be (.but 'configure ....)
	 *  But this code is so frequent.
	 */
	Tcl_AppendStringsToObj(objPtr, "'",
			       Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
			       (char *) NULL);
      }	  
      else {
	Tcl_AppendStringsToObj(objPtr,
			       Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
			       (char *) NULL);
      }
    }
    Tcl_AppendStringsToObj(objPtr, message, ")", (char *) NULL);
#else
    Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
    for (i = 0; i < objc; i++) {
	Tcl_AppendStringsToObj(objPtr,
		Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
		(char *) NULL);
    }
    Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL);
#endif
}