home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / src / tclXgeneral.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-19  |  6.8 KB  |  237 lines
  1. /* 
  2.  * tclXgeneral.c --
  3.  *
  4.  *      Contains general extensions to the basic TCL command set.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1993 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 3.0 1993/11/19 06:58:43 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * These globals must be set by main for the information to be defined.
  23.  */
  24.  
  25. char *tclxVersion       = NULL;  /* 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. int   tclAppPatchlevel  = 0;     /* Patch level of the application          */
  32.  
  33.  
  34. /*
  35.  *-----------------------------------------------------------------------------
  36.  *
  37.  * Tcl_EchoCmd --
  38.  *    Implements the TCL echo command:
  39.  *        echo ?str ...?
  40.  *
  41.  * Results:
  42.  *      Always returns TCL_OK.
  43.  *
  44.  *-----------------------------------------------------------------------------
  45.  */
  46. int
  47. Tcl_EchoCmd(clientData, interp, argc, argv)
  48.     ClientData  clientData;
  49.     Tcl_Interp *interp;
  50.     int         argc;
  51.     char      **argv;
  52. {
  53.     int idx;
  54.  
  55.     for (idx = 1; idx < argc; idx++) {
  56.         fputs (argv [idx], stdout);
  57.         if (idx < (argc - 1))
  58.             printf(" ");
  59.     }
  60.     printf("\n");
  61.     return TCL_OK;
  62. }
  63.  
  64. /*
  65.  *-----------------------------------------------------------------------------
  66.  *
  67.  * Tcl_InfoxCmd --
  68.  *    Implements the TCL infox command:
  69.  *        infox option
  70.  *
  71.  *-----------------------------------------------------------------------------
  72.  */
  73. int
  74. Tcl_InfoxCmd (clientData, interp, argc, argv)
  75.     ClientData  clientData;
  76.     Tcl_Interp *interp;
  77.     int         argc;
  78.     char      **argv;
  79. {
  80.     char numBuf [32];
  81.  
  82.     if (argc != 2) {
  83.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  84.                           " option", (char *) NULL);
  85.         return TCL_ERROR;
  86.     }
  87.  
  88.     if (STREQU ("version", argv [1])) {
  89.         Tcl_SetResult (interp, tclxVersion, TCL_STATIC);
  90.         return TCL_OK;
  91.     }
  92.     if (STREQU ("patchlevel", argv [1])) {
  93.         sprintf (numBuf, "%d", tclxPatchlevel);
  94.         Tcl_SetResult (interp, numBuf, TCL_VOLATILE);
  95.         return TCL_OK;
  96.     }
  97.     if (STREQU ("have_fsync", argv [1])) {
  98. #       ifdef HAVE_FSYNC
  99.         interp->result = "1";
  100. #       else
  101.         interp->result = "0";
  102. #       endif        
  103.         return TCL_OK;
  104.     }
  105.     if (STREQU ("have_msgcats", argv [1])) {
  106. #       ifdef HAVE_CATGETS
  107.         interp->result = "1";
  108. #       else
  109.         interp->result = "0";
  110. #       endif        
  111.         return TCL_OK;
  112.     }
  113.     if (STREQU ("have_posix_signals", argv [1])) {
  114. #       ifdef HAVE_SIGACTION
  115.         interp->result = "1";
  116. #       else
  117.         interp->result = "0";
  118. #       endif        
  119.         return TCL_OK;
  120.     }
  121.     if (STREQU ("have_sockets", argv [1])) {
  122. #       ifdef HAVE_GETHOSTBYNAME
  123.         interp->result = "1";
  124. #       else
  125.         interp->result = "0";
  126. #       endif        
  127.         return TCL_OK;
  128.     }
  129.     if (STREQU ("appname", argv [1])) {
  130.         if (tclAppName != NULL)
  131.             Tcl_SetResult (interp, tclAppName, TCL_STATIC);
  132.         return TCL_OK;
  133.     }
  134.     if (STREQU ("applongname", argv [1])) {
  135.         if (tclAppLongname != NULL)
  136.             Tcl_SetResult (interp, tclAppLongname, TCL_STATIC);
  137.         return TCL_OK;
  138.     }
  139.     if (STREQU ("appversion", argv [1])) {
  140.         if (tclAppVersion != NULL)
  141.             Tcl_SetResult (interp, tclAppVersion, TCL_STATIC);
  142.         return TCL_OK;
  143.     }
  144.     if (STREQU ("apppatchlevel", argv [1])) {
  145.         sprintf (numBuf, "%d", tclAppPatchlevel);
  146.         Tcl_SetResult (interp, numBuf, TCL_VOLATILE);
  147.         return TCL_OK;
  148.     }
  149.  
  150.     Tcl_AppendResult (interp, "illegal option \"", argv [1], 
  151.                       "\" expect one of: version, patchlevel, ",
  152.                       "have_fsync, have_msgcats, have_posix_signals, ",
  153.                       "have_sockets, ",
  154.                       "appname, applongname, appversion, or apppatchlevel",
  155.                       (char *) NULL);
  156.     return TCL_ERROR;
  157. }
  158.  
  159. /*
  160.  *-----------------------------------------------------------------------------
  161.  *
  162.  * Tcl_LoopCmd --
  163.  *     Implements the TCL loop command:
  164.  *         loop var start end ?increment? command
  165.  *
  166.  * Results:
  167.  *      Standard TCL results.
  168.  *
  169.  *-----------------------------------------------------------------------------
  170.  */
  171. int
  172. Tcl_LoopCmd (dummy, interp, argc, argv)
  173.     ClientData  dummy;
  174.     Tcl_Interp *interp;
  175.     int         argc;
  176.     char      **argv;
  177. {
  178.     int   result = TCL_OK;
  179.     long  i, first, limit, incr = 1;
  180.     char *command;
  181.     char  itxt [12];
  182.  
  183.     if ((argc < 5) || (argc > 6)) {
  184.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  185.                           " var first limit ?incr? command", (char *) NULL);
  186.         return TCL_ERROR;
  187.     }
  188.  
  189.     if (Tcl_ExprLong (interp, argv[2], &first) != TCL_OK)
  190.         return TCL_ERROR;
  191.     if (Tcl_ExprLong (interp, argv[3], &limit) != TCL_OK)
  192.         return TCL_ERROR;
  193.     if (argc == 5) {
  194.         command = argv[4];
  195.     } else {
  196.         if (Tcl_ExprLong (interp, argv[4], &incr) != TCL_OK)
  197.             return TCL_ERROR;
  198.         command = argv[5];
  199.     }
  200.  
  201.     for (i = first;
  202.              (((i < limit) && (incr > 0)) || ((i > limit) && (incr < 0)));
  203.              i += incr) {
  204.  
  205.         sprintf (itxt,"%ld",i);
  206.         if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
  207.             return TCL_ERROR;
  208.  
  209.         result = Tcl_Eval (interp, command);
  210.         if (result != TCL_OK) {
  211.             if (result == TCL_CONTINUE) {
  212.                 result = TCL_OK;
  213.             } else if (result == TCL_BREAK) {
  214.                 result = TCL_OK;
  215.                 break;
  216.             } else if (result == TCL_ERROR) {
  217.                 char buf [64];
  218.  
  219.                 sprintf (buf, "\n    (\"loop\" body line %d)", 
  220.                          interp->errorLine);
  221.                 Tcl_AddErrorInfo (interp, buf);
  222.                 break;
  223.             } else {
  224.                 break;
  225.             }
  226.         }
  227.     }
  228.     /*
  229.      * Set variable to its final value.
  230.      */
  231.     sprintf (itxt,"%ld",i);
  232.     if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
  233.         return TCL_ERROR;
  234.  
  235.     return result;
  236. }
  237.