home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / tcl-lib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  20.9 KB  |  793 lines
  1. /*
  2.  *
  3.  * t c l - l i b . c         - A library remplacement for simulating 
  4.  *                  a Tcl interpreter in Scheme
  5.  *
  6.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  7.  * 
  8.  *
  9.  * Permission to use, copy, and/or distribute this software and its
  10.  * documentation for any purpose and without fee is hereby granted, provided
  11.  * that both the above copyright notice and this permission notice appear in
  12.  * all copies and derived works.  Fees for distribution or use of this
  13.  * software or derived works may only be charged with express written
  14.  * permission of the copyright holder.  
  15.  * This software is provided ``as is'' without express or implied warranty.
  16.  *
  17.  * This software is a derivative work of other copyrighted softwares; the
  18.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  19.  *
  20.  *
  21.  *            Author: Erick Gallesio [eg@unice.fr]
  22.  *    Creation date: 19-Feb-1993 22:15
  23.  * Last file update: 15-Jul-1996 16:44
  24.  *
  25.  */
  26.  
  27.  
  28. #include "stk.h"
  29.  
  30. #ifdef USE_TK
  31. #  include "tk-glue.h"
  32. #else
  33. #  include "tclInt.h"
  34. #endif
  35.  
  36.  
  37. #ifdef USE_TK
  38. #define BUFF_SIZE 100
  39. /******************************************************************************
  40.  *
  41.  *                Eval functions
  42.  *
  43.  ******************************************************************************/
  44.  
  45. int Tcl_GlobalEval(interp, s)
  46.      Tcl_Interp *interp;
  47.      char *s;
  48. {
  49.   char buffer[BUFF_SIZE+3], *ptr = buffer;
  50.   SCM result;
  51.  
  52.   /* 
  53.    * If the callback is nor surrounded by parenthesis, add them. We
  54.    * don't have parenthesis when the callback is a closure. In this
  55.    * case, the callback is simply #p12345. Note that this allow Tk to
  56.    * add some parameters to the callback when needed (on bindings, or
  57.    * scrollbars for instance). To recognize such cases, we look at
  58.    * first character: if it is not an open parenthesis, we add a pair
  59.    * of () around the callback string
  60.    *     
  61.    */
  62.   if (*s == '\0') return TCL_OK;
  63.   if (*s != '(') {
  64.     /* Build the command to evaluate by adding a pair of parenthesis */
  65.     int len = strlen(s);
  66.     
  67.     if (len > BUFF_SIZE) 
  68.       ptr = (char *) must_malloc(len+3);
  69.     sprintf(ptr, "(%s)", s);
  70.     s = ptr;
  71.   }
  72.   result = STk_internal_eval_string(s, ERR_TCL_BACKGROUND, NIL);
  73.   Tcl_ResetResult(interp);
  74.     
  75.   if (ptr != buffer) free(ptr);
  76.  
  77.   if (result != EVAL_ERROR) {
  78.     SCM dumb;
  79.  
  80.     Tcl_SetResult(interp, 
  81.           STk_stringify(STk_convert_for_Tk(result, &dumb), 0), 
  82.           TCL_DYNAMIC);
  83.     /* 
  84.      * Store also the "true" result in STk_last_Tk_result
  85.      * Warning: This pointer inot GC protected. We have to use it very soon 
  86.      * This is a kludge (used in text window)
  87.      */
  88.      STk_last_Tk_result = result;
  89.        
  90.      return (result == Sym_break) ? TCL_BREAK : TCL_OK;
  91.   }
  92.   
  93.   return TCL_ERROR;
  94. }
  95.  
  96. int Tcl_Eval(interp, s)     /* very simplist. */
  97.      Tcl_Interp *interp;    /* But do we need something more clever? */
  98.      char *s;
  99. {
  100.   return Tcl_GlobalEval(interp, s);
  101. }
  102.  
  103.  
  104. /*
  105.  *----------------------------------------------------------------------
  106.  *
  107.  * Tcl_VarEval --
  108.  *
  109.  *    Given a variable number of string arguments, concatenate them
  110.  *    all together and execute the result as a Tcl command.
  111.  *
  112.  * Results:
  113.  *    A standard Tcl return result.  An error message or other
  114.  *    result may be left in interp->result.
  115.  *
  116.  * Side effects:
  117.  *    Depends on what was done by the command.
  118.  *
  119.  *----------------------------------------------------------------------
  120.  */
  121.     /* VARARGS2 */ /* ARGSUSED */
  122. int
  123. Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
  124. {
  125.     va_list argList;
  126.     Tcl_DString buf;
  127.     char *string;
  128.     Tcl_Interp *interp;
  129.     int result;
  130.  
  131.     /*
  132.      * Copy the strings one after the other into a single larger
  133.      * string.  Use stack-allocated space for small commands, but if
  134.      * the command gets too large than call ckalloc to create the
  135.      * space.
  136.      */
  137.  
  138.     interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
  139.     Tcl_DStringInit(&buf);
  140.     while (1) {
  141.     string = va_arg(argList, char *);
  142.     if (string == NULL) {
  143.         break;
  144.     }
  145.     Tcl_DStringAppend(&buf, string, -1);
  146.     }
  147.     va_end(argList);
  148.  
  149.     result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
  150.     Tcl_DStringFree(&buf);
  151.     return result;
  152. }
  153.  
  154. /******************************************************************************
  155.  *
  156.  *          Variable accesses (GetVar, GetVar2, SetVar, SetVar2)
  157.  *
  158.  ******************************************************************************/
  159.  
  160. char *Tcl_GetVar(interp, var, flags)
  161.      Tcl_Interp *interp;    /* not used */
  162.      char *var;
  163.      int flags;
  164. {
  165.   SCM dumb, V = VCELL(Intern(var));
  166.   return (V == UNBOUND) ? NULL : STk_convert_for_Tk(V, &dumb);
  167. }
  168.  
  169. char *Tcl_GetVar2(interp, name1, name2, flags)
  170.      Tcl_Interp *interp;    /* not used */
  171.      char *name1, *name2;
  172.      int flags;
  173. {
  174.   if (name2 && *name2) {
  175.     char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);
  176.  
  177.     sprintf(s, "%s{%s}", name1, name2);
  178.     res = Tcl_GetVar(interp, s, flags);
  179.     free(s);
  180.     return res;
  181.   }
  182.   return Tcl_GetVar(interp, name1, flags);
  183. }
  184.  
  185. char *Tcl_SetVar(interp, var, val, flags)
  186.      Tcl_Interp *interp;
  187.      char *var, *val;
  188.      int flags;
  189. {
  190.   register SCM tmp, value;
  191.  
  192.   tmp = Intern(var);
  193.   if (flags & STk_STRINGIFY) {
  194.     /* Val is already a string, since it comes from Tk */
  195.     value = STk_makestring(val);
  196.   }
  197.   else {
  198.     if (*val) {
  199.       SCM port;
  200.       int eof;
  201.       
  202.       port  = STk_internal_open_input_string(val);
  203.       value = STk_internal_read_from_string(port, &eof, TRUE);
  204.       if (value == EVAL_ERROR) return NULL;
  205.     }
  206.     else 
  207.       value =  STk_makestring("");
  208.   }
  209.  
  210.   VCELL(tmp) = value;
  211.   if (TRACED_VARP(tmp)) STk_change_value(tmp, NIL);
  212.  
  213.   return val;
  214. }
  215.  
  216. char *Tcl_SetVar2(interp, name1, name2, val, flags)
  217.      Tcl_Interp *interp;
  218.      char *name1, *name2, *val;
  219.      int flags;
  220. { 
  221.   if (name2 && *name2) {
  222.     char *res, *s = must_malloc(strlen(name1) + strlen(name2) + 3);
  223.  
  224.     sprintf(s, "%s{%s}", name1, name2);
  225.     res = Tcl_SetVar(interp, s, val, flags);
  226.     free(s);
  227.     return res;
  228.   }
  229.   return Tcl_SetVar(interp, name1, val, flags);
  230. }
  231.  
  232. /******************************************************************************
  233.  *
  234.  *                Tcl command management
  235.  *
  236.  ******************************************************************************/
  237.  
  238.  
  239. int Tcl_DeleteCommand(interp, cmdName)
  240.      Tcl_Interp *interp;
  241.      char *cmdName;
  242. {
  243.   struct Tk_command *W;
  244.   Interp *iPtr = (Interp *) interp;
  245.   Tcl_HashEntry *hPtr;
  246.  
  247.   hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
  248.   if (hPtr == NULL) return -1;
  249.  
  250.   W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  251.   /* Execute the delete handler */
  252.   if (W->delproc != NULL) (*W->delproc)(W->deldata);
  253.  
  254.   /* Note: W will be freed by the GC */
  255.   Tcl_DeleteHashEntry(hPtr);
  256.  
  257.   /* Delete the command from the callbacks hash table */
  258.   STk_delete_callback(cmdName);
  259.  
  260.   /* Undefine "cmdName" by doing a (set! cmdname #<unbound>) */
  261.   VCELL(Intern(cmdName)) = UNBOUND;
  262.   W->Id[0] = 0; /* To avoid to make again a call to this function from GC */
  263.  
  264.   return 0;
  265. }
  266.  
  267.  
  268. /*
  269.  *----------------------------------------------------------------------
  270.  *
  271.  * Tcl_CreateCommand --
  272.  *
  273.  *    Define a new command in a command table.
  274.  *
  275.  * Results:
  276.  *    The return value is a token for the command, which can
  277.  *    be used in future calls to Tcl_NameOfCommand.
  278.  *
  279.  * Side effects:
  280.  *    If a command named cmdName already exists for interp, it is
  281.  *    deleted.
  282.  *----------------------------------------------------------------------
  283.  */
  284. Tcl_Command
  285. Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
  286.     Tcl_Interp *interp;        /* Token for command interpreter (returned
  287.                  * by a previous call to Tcl_CreateInterp). */
  288.     char *cmdName;        /* Name of command. */
  289.     Tcl_CmdProc *proc;        /* Command procedure to associate with
  290.                  * cmdName. */
  291.     ClientData clientData;    /* Arbitrary one-word value to pass to proc. */
  292.     Tcl_CmdDeleteProc *deleteProc;
  293.                 /* If not NULL, gives a procedure to call when
  294.                  * this command is deleted. */
  295. {
  296.   struct Tk_command * W;
  297.  
  298.   /* 
  299.    * There are two parts here.  
  300.    *
  301.    * First part is related to Scheme. We create a new variable and
  302.    * associate the newly created Tk object to it.
  303.    *
  304.    * Second part is quite similar to the Tcl CreateCommand (commands
  305.    * must be stored in a hashtable contained in the interp data
  306.    * structure. This is necessary to delete all the command associated
  307.    * to the interpreter. This is important at least for the "send"
  308.    * command which un-register the interpreter from the X server.
  309.    *
  310.    */
  311.  
  312.   {
  313.     /* First: Scheme part */
  314.     SCM z;
  315.  
  316.     W = (struct Tk_command *) 
  317.               must_malloc(sizeof(struct Tk_command)+strlen(cmdName));
  318.     W->ptr         = clientData;
  319.     W->fct          = proc;
  320.     W->delproc       = deleteProc;
  321.     W->deldata         = clientData;
  322.     strcpy(W->Id, cmdName);
  323.  
  324.     /* Define a Tk-command cell for this new command */
  325.     NEWCELL(z, tc_tkcommand);
  326.     z->storage_as.tk.data   = W;
  327.     z->storage_as.tk.l_data = Ntruth;
  328.     
  329.     /* Define a variable whose name is the command name */
  330.     VCELL(Intern(cmdName)) = z;
  331.   }
  332.   
  333.   {
  334.     /* Second: Tcl part */
  335.     Interp *iPtr = (Interp *) interp;
  336.     register struct Tk_command *cmdPtr;
  337.     Tcl_HashEntry *hPtr;
  338.     int new;
  339.  
  340.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
  341.     if (!new) {
  342.       /* Command already exists: delete the old one */
  343.       cmdPtr = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  344.       if (cmdPtr->delproc != NULL) {
  345.     (*cmdPtr->delproc)(cmdPtr->deldata);
  346.       }
  347.       /* Remember that we have already deleted this command for further GC */
  348.       cmdPtr->Id[0] = '\0';
  349.     }
  350.     Tcl_SetHashValue(hPtr, W);
  351.   }
  352.   return (Tcl_Command) W;
  353. }
  354.  
  355.  
  356. /*
  357.  *----------------------------------------------------------------------
  358.  *
  359.  * Tcl_GetCommandName --
  360.  *
  361.  *    Given a token returned by Tcl_CreateCommand, this procedure
  362.  *    returns the current name of the command (which may have changed
  363.  *    due to renaming).
  364.  *
  365.  * Results:
  366.  *    The return value is the name of the given command.
  367.  *
  368.  * Side effects:
  369.  *    None.
  370.  *
  371.  *----------------------------------------------------------------------
  372.  */
  373.  
  374. char *
  375. Tcl_GetCommandName(interp, command)
  376.     Tcl_Interp *interp;        /* Interpreter containing the command. */
  377.     Tcl_Command command;    /* Token for the command, returned by a
  378.                  * previous call to Tcl_CreateCommand.
  379.                  * The command must not have been deleted. */
  380. {
  381.   return ((struct Tk_command *) command)->Id;
  382. }
  383.  
  384. /*
  385.  *----------------------------------------------------------------------
  386.  *
  387.  * Tcl_GetCommandInfo --
  388.  *
  389.  *    Returns various information about a Tcl command.
  390.  *
  391.  * Results:
  392.  *    If cmdName exists in interp, then *infoPtr is modified to
  393.  *    hold information about cmdName and 1 is returned.  If the
  394.  *    command doesn't exist then 0 is returned and *infoPtr isn't
  395.  *    modified.
  396.  *
  397.  * Side effects:
  398.  *    None.
  399.  *
  400.  *----------------------------------------------------------------------
  401.  */
  402.  
  403. int
  404. Tcl_GetCommandInfo(interp, cmdName, infoPtr)
  405.     Tcl_Interp *interp;            /* Interpreter in which to look
  406.                      * for command. */
  407.     char *cmdName;            /* Name of desired command. */
  408.     Tcl_CmdInfo *infoPtr;        /* Where to store information about
  409.                      * command. */
  410. {
  411.     SCM v = Intern(cmdName);
  412.     struct Tk_command *p;
  413.     
  414.     if (NTKCOMMP(VCELL(v))) return 0;
  415.  
  416.     p =  VCELL(v)->storage_as.tk.data;
  417.  
  418.     infoPtr->proc       = p->fct;
  419.     infoPtr->clientData = p->ptr;
  420.     infoPtr->deleteProc = p->delproc;;
  421.     infoPtr->deleteData = NULL;
  422.     return 1;
  423. }
  424.  
  425.  
  426. /******************************************************************************
  427.  *
  428.  *              Tcl interpreter management
  429.  *
  430.  ******************************************************************************/
  431.  
  432. Tcl_Interp *Tcl_CreateInterp()
  433. {
  434.   register Interp *iPtr = (Interp *) ckalloc(sizeof(Interp));
  435.   
  436.   iPtr->result         = iPtr->resultSpace;
  437.   iPtr->freeProc     = 0;
  438.   iPtr->errorLine     = 0;
  439.   iPtr->resultSpace[0]   = 0;
  440.   
  441.   iPtr->appendResult     = NULL;
  442.   iPtr->appendAvl     = 0;
  443.   iPtr->appendUsed     = 0;
  444.  
  445.   strcpy(iPtr->pdFormat, "%g");
  446.  
  447.   iPtr->assocData      = (Tcl_HashTable *) NULL;
  448.  
  449.   /* See Tcl_CreateCommand for this table utility  */
  450.   Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS);
  451.  
  452.   return (Tcl_Interp *) iPtr;
  453. }
  454.  
  455. /*
  456.  *----------------------------------------------------------------------
  457.  *
  458.  * Tcl_SetAssocData --
  459.  *
  460.  *    Creates a named association between user-specified data, a delete
  461.  *    function and this interpreter. If the association already exists
  462.  *    the data is overwritten with the new data. The delete function will
  463.  *    be invoked when the interpreter is deleted.
  464.  *
  465.  * Results:
  466.  *    None.
  467.  *
  468.  * Side effects:
  469.  *    Sets the associated data, creates the association if needed.
  470.  *
  471.  *----------------------------------------------------------------------
  472.  */
  473.  
  474. void
  475. Tcl_SetAssocData(interp, name, proc, clientData)
  476.     Tcl_Interp *interp;        /* Interpreter to associate with. */
  477.     char *name;            /* Name for association. */
  478.     Tcl_InterpDeleteProc *proc;    /* Proc to call when interpreter is
  479.                                  * about to be deleted. */
  480.     ClientData clientData;    /* One-word value to pass to proc. */
  481. {
  482.     Interp *iPtr = (Interp *) interp;
  483.     AssocData *dPtr;
  484.     Tcl_HashEntry *hPtr;
  485.     int new;
  486.  
  487.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  488.     if (iPtr->flags & DELETED) {
  489.         /*
  490.          * Don't create new entries after interpreter deletion
  491.          * has started;  it isn't even safe to muck with the
  492.          * interpreter right now
  493.          */
  494.  
  495.         return;
  496.     }
  497.         iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
  498.         Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
  499.     }
  500.     hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
  501.     if (new == 0) {
  502.         dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  503.     } else {
  504.         dPtr = (AssocData *) ckalloc(sizeof(AssocData));
  505.     }
  506.     dPtr->proc = proc;
  507.     dPtr->clientData = clientData;
  508.  
  509.     Tcl_SetHashValue(hPtr, dPtr);
  510. }
  511.  
  512. /*
  513.  *----------------------------------------------------------------------
  514.  *
  515.  * Tcl_DeleteAssocData --
  516.  *
  517.  *    Deletes a named association of user-specified data with
  518.  *    the specified interpreter.
  519.  *
  520.  * Results:
  521.  *    None.
  522.  *
  523.  * Side effects:
  524.  *    Deletes the association.
  525.  *
  526.  *----------------------------------------------------------------------
  527.  */
  528.  
  529. void
  530. Tcl_DeleteAssocData(interp, name)
  531.     Tcl_Interp *interp;            /* Interpreter to associate with. */
  532.     char *name;                /* Name of association. */
  533. {
  534.     Interp *iPtr = (Interp *) interp;
  535.     AssocData *dPtr;
  536.     Tcl_HashEntry *hPtr;
  537.  
  538.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  539.         return;
  540.     }
  541.     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  542.     if (hPtr == (Tcl_HashEntry *) NULL) {
  543.         return;
  544.     }
  545.     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  546.     ckfree((char *) dPtr);
  547.     Tcl_DeleteHashEntry(hPtr);
  548. }
  549.  
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * Tcl_GetAssocData --
  554.  *
  555.  *    Returns the client data associated with this name in the
  556.  *    specified interpreter.
  557.  *
  558.  * Results:
  559.  *    The client data in the AssocData record denoted by the named
  560.  *    association, or NULL.
  561.  *
  562.  * Side effects:
  563.  *    None.
  564.  *
  565.  *----------------------------------------------------------------------
  566.  */
  567.  
  568. ClientData
  569. Tcl_GetAssocData(interp, name, procPtr)
  570.     Tcl_Interp *interp;            /* Interpreter associated with. */
  571.     char *name;                /* Name of association. */
  572.     Tcl_InterpDeleteProc **procPtr;    /* Pointer to place to store address
  573.                      * of current deletion callback. */
  574. {
  575.     Interp *iPtr = (Interp *) interp;
  576.     AssocData *dPtr;
  577.     Tcl_HashEntry *hPtr;
  578.  
  579.     if (iPtr->assocData == (Tcl_HashTable *) NULL) {
  580.         return (ClientData) NULL;
  581.     }
  582.     hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
  583.     if (hPtr == (Tcl_HashEntry *) NULL) {
  584.         return (ClientData) NULL;
  585.     }
  586.     dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
  587.     if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
  588.         *procPtr = dPtr->proc;
  589.     }
  590.     return dPtr->clientData;
  591. }
  592.  
  593. /*
  594.  *----------------------------------------------------------------------
  595.  *
  596.  * Tcl_InterpDeleted --
  597.  *
  598.  *    Returns nonzero if the interpreter has been deleted with a call
  599.  *    to Tcl_DeleteInterp.
  600.  *
  601.  * Results:
  602.  *    Nonzero if the interpreter is deleted, zero otherwise.
  603.  *
  604.  * Side effects:
  605.  *    None.
  606.  *
  607.  *----------------------------------------------------------------------
  608.  */
  609.  
  610. int
  611. Tcl_InterpDeleted(interp)
  612.     Tcl_Interp *interp;
  613. {
  614.     return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
  615. }
  616. /*
  617.  *----------------------------------------------------------------------
  618.  *
  619.  * Tcl_DeleteInterp --
  620.  *
  621.  *    Delete an interpreter and free up all of the resources associated
  622.  *    with it.
  623.  *
  624.  * Results:
  625.  *    None.
  626.  *
  627.  * Side effects:
  628.  *    The interpreter is destroyed.  The caller should never again
  629.  *    use the interp token.
  630.  *
  631.  *----------------------------------------------------------------------
  632.  */
  633. void Tcl_DeleteInterp(interp)
  634.     Tcl_Interp *interp;
  635. {
  636.   Interp *iPtr = (Interp *) interp;
  637.   Tcl_HashEntry *hPtr;
  638.   Tcl_HashSearch search;
  639.   struct Tk_command *W;
  640.  
  641.   if (!iPtr || (iPtr->flags & DELETED)) return;
  642.  
  643.   /* Mark the interpreter as deleted. No further evals will be allowed. */
  644.   iPtr->flags |= DELETED;
  645.   
  646.   /* Delete result space */
  647.   if (iPtr->appendResult != NULL) {
  648.     ckfree(iPtr->appendResult);
  649.   }
  650.   
  651.   /* delete hash table of Tk commands (see Tcl_CreateCommand) */
  652.   for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  653.        hPtr != NULL; 
  654.        hPtr = Tcl_NextHashEntry(&search)) {
  655.     W = (struct Tk_command *) Tcl_GetHashValue(hPtr);
  656.     Tcl_DeleteCommand(interp, W->Id);
  657.   }
  658.   Tcl_DeleteHashTable(&iPtr->commandTable);
  659.  
  660.   ckfree((char *) iPtr);
  661. }
  662.  
  663.  
  664.  
  665. /*
  666.  *----------------------------------------------------------------------
  667.  *
  668.  * Tcl_GetOpenFile --
  669.  *
  670.  *    Given a name of a channel registered in the given interpreter,
  671.  *    returns a FILE * for it.
  672.  *
  673.  * Results:
  674.  *    A standard Tcl result. If the channel is registered in the given
  675.  *    interpreter and it is managed by the "file" channel driver, and
  676.  *    it is open for the requested mode, then the output parameter
  677.  *    filePtr is set to a FILE * for the underlying file. On error, the
  678.  *    filePtr is not set, TCL_ERROR is returned and an error message is
  679.  *    left in interp->result.
  680.  *
  681.  * Side effects:
  682.  *    May invoke fdopen to create the FILE * for the requested file.
  683.  *
  684.  *----------------------------------------------------------------------
  685.  */
  686.  
  687. int
  688. Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
  689.     Tcl_Interp *interp;        /* Interpreter in which to find file. */
  690.     char *string;        /* String that identifies file. */
  691.     int forWriting;        /* 1 means the file is going to be used
  692.                  * for writing, 0 means for reading. */
  693.     int checkUsage;        /* 1 means verify that the file was opened
  694.                  * in a mode that allows the access specified
  695.                  * by "forWriting". Ignored, we always
  696.                                  * check that the channel is open for the
  697.                                  * requested mode. */
  698.     ClientData *filePtr;    /* Store pointer to FILE structure here. */
  699. {
  700.   SCM port;
  701.  
  702.   if ((string[0] == '#') && (string[1] == 'f') && (string[2] == 'i')
  703.       && (string[3] == 'l') && string[4] == 'e') {
  704.     char *end;
  705.     
  706.     port = (SCM) strtoul(string+5, &end, 16);
  707.     if ((end != string+5) && (*end == 0)) {
  708.       /* Verify the given address is a port */
  709.       if (STk_valid_address(port) && (IPORTP(port) || OPORTP(port))) {
  710.     /* Verify the port usage  */
  711.     if (checkUsage && (PORT_FLAGS(port) & PORT_CLOSED)) {
  712.       Tcl_AppendResult(interp, "\"", string,
  713.                "\" is closed", (char *) NULL);
  714.       return TCL_ERROR;
  715.     }
  716.     if (forWriting) {
  717.       if (checkUsage && !OPORTP(port)) {
  718.         Tcl_AppendResult(interp, "\"", string,
  719.             "\" wasn't opened for writing", (char *) NULL);
  720.         return TCL_ERROR;
  721.       }
  722.     }
  723.     else {
  724.        if (!IPORTP(port)) {
  725.          Tcl_AppendResult(interp, "\"", string,
  726.                   "\" wasn't opened for reading", (char *) NULL);
  727.          return TCL_ERROR;
  728.        }
  729.     }
  730.     
  731.     /* File is correct; return it in filePtr */
  732.     *filePtr = PORT_FILE(port);
  733.     return TCL_OK;
  734.       }
  735.     }
  736.   }
  737.   Tcl_AppendResult(interp, "Bad file specification \"", string,
  738.             "\"", (char *) NULL);
  739.   return TCL_ERROR; 
  740. }
  741. #endif
  742.  
  743. /******************************************************************************
  744.  *
  745.  * Tcl channels simulation.
  746.  *
  747.  *    Current version is very minimal. It should probably be extended to be 
  748.  *    more Tcl compatible, since Tcl model is very neat.
  749.  *
  750.  ******************************************************************************/
  751.  
  752. Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName, 
  753.                 char *modeString, int permissions)
  754. {
  755.   return (Tcl_Channel) fopen(fileName, modeString);
  756. }
  757.  
  758. int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
  759. {
  760.   return fclose((FILE *) chan);
  761. }
  762.  
  763. int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
  764. {
  765.   return read(fileno((FILE *)chan), bufPtr, toRead);
  766. }
  767.  
  768. int Tcl_Write(Tcl_Channel chan, char *s, int slen)
  769. {
  770.   return write(fileno((FILE *)chan), s, slen);
  771. }
  772.  
  773.  
  774. int Tcl_Seek(Tcl_Channel chan, int offset, int mode)
  775. {
  776.   return fseek((FILE*) chan, (long) offset, mode);
  777. }
  778.  
  779. int Tcl_Flush(Tcl_Channel chan)
  780. {
  781.   return fflush((FILE *) chan);
  782. }
  783.  
  784. Tcl_Channel Tcl_GetStdChannel(int type) /*  TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
  785. {
  786.   switch (type) {
  787.     case TCL_STDIN:  return (Tcl_Channel) STk_stdin;
  788.     case TCL_STDOUT: return (Tcl_Channel) STk_stdout;
  789.     case TCL_STDERR: return (Tcl_Channel) STk_stderr;
  790.   }
  791.   return NULL;
  792. }
  793.