git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxgenl.c

   1 /*
   2  * tclXgeneral.c --
   3  *
   4  *      Contains general extensions to the basic TCL command set.
   5  *-----------------------------------------------------------------------------
   6  * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
   7  *
   8  * Permission to use, copy, modify, and distribute this software and its
   9  * documentation for any purpose and without fee is hereby granted, provided
  10  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  11  * Mark Diekhans make no representations about the suitability of this
  12  * software for any purpose.  It is provided "as is" without express or
  13  * implied warranty.
  14  *-----------------------------------------------------------------------------
  15  * $Id: tclXgeneral.c,v 2.0 1992/10/16 04:50:47 markd Rel $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.h"
  20
  21 /*
  22  * These globals must be set by main for the information to be defined.
  23  */
  24
  25 char *tclxVersion       = "?";   /* Extended Tcl version number.            */
  26 int   tclxPatchlevel    = 0;     /* Extended Tcl patch level.               */
  27
  28 char *tclAppName        = NULL;  /* Application name                        */
  29 char *tclAppLongname    = NULL;  /* Long, natural language application name */
  30 char *tclAppVersion     = NULL;  /* Version number of the application       */
  31
  32 \f
  33 /*
  34  *-----------------------------------------------------------------------------
  35  *
  36  * Tcl_EchoCmd --
  37  *    Implements the TCL echo command:
  38  *        echo str1 [str2..]
  39  *
  40  * Results:
  41  *      Always returns TCL_OK.
  42  *
  43  *-----------------------------------------------------------------------------
  44  */
  45 int
  46 Tcl_EchoCmd(clientData, interp, argc, argv)
  47     ClientData  clientData;
  48     Tcl_Interp *interp;
  49     int         argc;
  50     char      **argv;
  51 {
  52     int idx;
  53
  54     for (idx = 1; idx < argc; idx++) {
  55         fputs (argv [idx], stdout);
  56         if (idx < (argc - 1))
  57             printf(" ");
  58     }
  59     printf("\n");
  60     return TCL_OK;
  61 }
  62 \f
  63 /*
  64  *-----------------------------------------------------------------------------
  65  *
  66  * Tcl_InfoxCmd --
  67  *    Implements the TCL infox command:
  68  *        infox option
  69  *
  70  *-----------------------------------------------------------------------------
  71  */
  72 int
  73 Tcl_InfoxCmd (clientData, interp, argc, argv)
  74     ClientData  clientData;
  75     Tcl_Interp *interp;
  76     int         argc;
  77     char      **argv;
  78 {
  79     if (argc != 2) {
  80         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  81                           " option", (char *) NULL);
  82         return TCL_ERROR;
  83     }
  84
  85     if (STREQU ("version", argv [1])) {
  86         Tcl_SetResult (interp, tclxVersion, TCL_STATIC);
  87     } else if (STREQU ("patchlevel", argv [1])) {
  88         char numBuf [32];
  89         sprintf (numBuf, "%d", tclxPatchlevel);
  90         Tcl_SetResult (interp, numBuf, TCL_VOLATILE);
  91     } else if (STREQU ("appname", argv [1])) {
  92         if (tclAppName != NULL)
  93             Tcl_SetResult (interp, tclAppName, TCL_STATIC);
  94     } else if (STREQU ("applongname", argv [1])) {
  95         if (tclAppLongname != NULL)
  96             Tcl_SetResult (interp, tclAppLongname, TCL_STATIC);
  97     } else if (STREQU ("appversion", argv [1])) {
  98         if (tclAppVersion != NULL)
  99             Tcl_SetResult (interp, tclAppVersion, TCL_STATIC);
 100     } else {
 101         Tcl_AppendResult (interp, "illegal option \"", argv [1],
 102                           "\" expect one of: version, patchlevel, appname, ",
 103                           "applongname, or appversion", (char *) NULL);
 104         return TCL_ERROR;
 105     }
 106     return TCL_OK;
 107 }
 108 \f
 109 /*
 110  *-----------------------------------------------------------------------------
 111  *
 112  * Tcl_LoopCmd --
 113  *     Implements the TCL loop command:
 114  *         loop var start end [increment] command
 115  *
 116  * Results:
 117  *      Standard TCL results.
 118  *
 119  *-----------------------------------------------------------------------------
 120  */
 121 int
 122 Tcl_LoopCmd (dummy, interp, argc, argv)
 123     ClientData  dummy;
 124     Tcl_Interp *interp;
 125     int         argc;
 126     char      **argv;
 127 {
 128     int   result = TCL_OK;
 129     long  i, first, limit, incr = 1;
 130     char *command;
 131     char  itxt [12];
 132
 133     if ((argc < 5) || (argc > 6)) {
 134         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
 135                           " var first limit [incr] command", (char *) NULL);
 136         return TCL_ERROR;
 137     }
 138
 139     if (Tcl_GetLong (interp, argv[2], &first) != TCL_OK)
 140         return TCL_ERROR;
 141     if (Tcl_GetLong (interp, argv[3], &limit) != TCL_OK)
 142         return TCL_ERROR;
 143     if (argc == 5)
 144         command = argv[4];
 145     else {
 146         if (Tcl_GetLong (interp, argv[4], &incr) != TCL_OK)
 147             return TCL_ERROR;
 148         command = argv[5];
 149     }
 150
 151     for (i = first;
 152              (((i < limit) && (incr > 0)) || ((i > limit) && (incr < 0)));
 153              i += incr) {
 154
 155         sprintf (itxt,"%ld",i);
 156         if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
 157             return TCL_ERROR;
 158
 159         result = Tcl_Eval(interp, command, 0, (char **) NULL);
 160         if (result != TCL_OK) {
 161             if (result == TCL_CONTINUE) {
 162                 result = TCL_OK;
 163             } else if (result == TCL_BREAK) {
 164                 result = TCL_OK;
 165                 break;
 166             } else if (result == TCL_ERROR) {
 167                 char buf [64];
 168
 169                 sprintf (buf, "\n    (\"loop\" body line %d)",
 170                          interp->errorLine);
 171                 Tcl_AddErrorInfo (interp, buf);
 172                 break;
 173             } else {
 174                 break;
 175             }
 176         }
 177     }
 178     /*
 179      * Set variable to its final value.
 180      */
 181     sprintf (itxt,"%ld",i);
 182     if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
 183         return TCL_ERROR;
 184
 185     return result;
 186 }