home *** CD-ROM | disk | FTP | other *** search
/ Serving the Web / ServingTheWeb1995.disc1of1.iso / linux / slacksrce / tcl / tcl+tk+t / tclx7.3bl / tclx7 / tclX7.3b / src / tclXgeneral.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-16  |  7.3 KB  |  252 lines
  1. /* 
  2.  * tclXgeneral.c --
  3.  *
  4.  *      Contains general extensions to the basic TCL command set.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1994 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 4.0 1994/07/16 05:27:00 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.     FILE *stdoutPtr;
  55.  
  56.     if (Tcl_GetOpenFile (interp, "stdout", 
  57.                          TRUE,   /* Write access */
  58.                          TRUE,   /* Check access */
  59.                          &stdoutPtr) != TCL_OK)
  60.         return TCL_ERROR;
  61.  
  62.     for (idx = 1; idx < argc; idx++) {
  63.         fputs (argv [idx], stdoutPtr);
  64.         if (idx < (argc - 1))
  65.             fprintf (stdoutPtr, " ");
  66.     }
  67.     fprintf (stdoutPtr, "\n");
  68.     return TCL_OK;
  69. }
  70.  
  71. /*
  72.  *-----------------------------------------------------------------------------
  73.  *
  74.  * Tcl_InfoxCmd --
  75.  *    Implements the TCL infox command:
  76.  *        infox option
  77.  *
  78.  *-----------------------------------------------------------------------------
  79.  */
  80. int
  81. Tcl_InfoxCmd (clientData, interp, argc, argv)
  82.     ClientData  clientData;
  83.     Tcl_Interp *interp;
  84.     int         argc;
  85.     char      **argv;
  86. {
  87.     char numBuf [32];
  88.  
  89.     if (argc != 2) {
  90.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  91.                           " option", (char *) NULL);
  92.         return TCL_ERROR;
  93.     }
  94.  
  95.     if (STREQU ("version", argv [1])) {
  96.         Tcl_SetResult (interp, tclxVersion, TCL_STATIC);
  97.         return TCL_OK;
  98.     }
  99.     if (STREQU ("patchlevel", argv [1])) {
  100.         sprintf (numBuf, "%d", tclxPatchlevel);
  101.         Tcl_SetResult (interp, numBuf, TCL_VOLATILE);
  102.         return TCL_OK;
  103.     }
  104.     if (STREQU ("have_flock", argv [1])) {
  105. #       ifdef F_SETLKW
  106.         interp->result = "1";
  107. #       else
  108.         interp->result = "0";
  109. #       endif        
  110.         return TCL_OK;
  111.     }
  112.     if (STREQU ("have_fsync", argv [1])) {
  113. #       ifdef HAVE_FSYNC
  114.         interp->result = "1";
  115. #       else
  116.         interp->result = "0";
  117. #       endif        
  118.         return TCL_OK;
  119.     }
  120.     if (STREQU ("have_msgcats", argv [1])) {
  121. #       ifdef HAVE_CATGETS
  122.         interp->result = "1";
  123. #       else
  124.         interp->result = "0";
  125. #       endif        
  126.         return TCL_OK;
  127.     }
  128.     if (STREQU ("have_posix_signals", argv [1])) {
  129. #       ifdef HAVE_SIGACTION
  130.         interp->result = "1";
  131. #       else
  132.         interp->result = "0";
  133. #       endif        
  134.         return TCL_OK;
  135.     }
  136.     if (STREQU ("have_sockets", argv [1])) {
  137. #       ifdef HAVE_GETHOSTBYNAME
  138.         interp->result = "1";
  139. #       else
  140.         interp->result = "0";
  141. #       endif        
  142.         return TCL_OK;
  143.     }
  144.     if (STREQU ("appname", argv [1])) {
  145.         if (tclAppName != NULL)
  146.             Tcl_SetResult (interp, tclAppName, TCL_STATIC);
  147.         return TCL_OK;
  148.     }
  149.     if (STREQU ("applongname", argv [1])) {
  150.         if (tclAppLongname != NULL)
  151.             Tcl_SetResult (interp, tclAppLongname, TCL_STATIC);
  152.         return TCL_OK;
  153.     }
  154.     if (STREQU ("appversion", argv [1])) {
  155.         if (tclAppVersion != NULL)
  156.             Tcl_SetResult (interp, tclAppVersion, TCL_STATIC);
  157.         return TCL_OK;
  158.     }
  159.     if (STREQU ("apppatchlevel", argv [1])) {
  160.         sprintf (numBuf, "%d", tclAppPatchlevel);
  161.         Tcl_SetResult (interp, numBuf, TCL_VOLATILE);
  162.         return TCL_OK;
  163.     }
  164.  
  165.     Tcl_AppendResult (interp, "illegal option \"", argv [1], 
  166.                       "\" expect one of: version, patchlevel, have_flock, ",
  167.                       "have_fsync, have_msgcats, have_posix_signals, ",
  168.                       "have_sockets, ",
  169.                       "appname, applongname, appversion, or apppatchlevel",
  170.                       (char *) NULL);
  171.     return TCL_ERROR;
  172. }
  173.  
  174. /*
  175.  *-----------------------------------------------------------------------------
  176.  *
  177.  * Tcl_LoopCmd --
  178.  *     Implements the TCL loop command:
  179.  *         loop var start end ?increment? command
  180.  *
  181.  * Results:
  182.  *      Standard TCL results.
  183.  *
  184.  *-----------------------------------------------------------------------------
  185.  */
  186. int
  187. Tcl_LoopCmd (dummy, interp, argc, argv)
  188.     ClientData  dummy;
  189.     Tcl_Interp *interp;
  190.     int         argc;
  191.     char      **argv;
  192. {
  193.     int   result = TCL_OK;
  194.     long  i, first, limit, incr = 1;
  195.     char *command;
  196.     char  itxt [12];
  197.  
  198.     if ((argc < 5) || (argc > 6)) {
  199.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  200.                           " var first limit ?incr? command", (char *) NULL);
  201.         return TCL_ERROR;
  202.     }
  203.  
  204.     if (Tcl_ExprLong (interp, argv[2], &first) != TCL_OK)
  205.         return TCL_ERROR;
  206.     if (Tcl_ExprLong (interp, argv[3], &limit) != TCL_OK)
  207.         return TCL_ERROR;
  208.     if (argc == 5) {
  209.         command = argv[4];
  210.     } else {
  211.         if (Tcl_ExprLong (interp, argv[4], &incr) != TCL_OK)
  212.             return TCL_ERROR;
  213.         command = argv[5];
  214.     }
  215.  
  216.     for (i = first;
  217.              (((i < limit) && (incr > 0)) || ((i > limit) && (incr < 0)));
  218.              i += incr) {
  219.  
  220.         sprintf (itxt,"%ld",i);
  221.         if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
  222.             return TCL_ERROR;
  223.  
  224.         result = Tcl_Eval (interp, command);
  225.         if (result != TCL_OK) {
  226.             if (result == TCL_CONTINUE) {
  227.                 result = TCL_OK;
  228.             } else if (result == TCL_BREAK) {
  229.                 result = TCL_OK;
  230.                 break;
  231.             } else if (result == TCL_ERROR) {
  232.                 char buf [64];
  233.  
  234.                 sprintf (buf, "\n    (\"loop\" body line %d)", 
  235.                          interp->errorLine);
  236.                 Tcl_AddErrorInfo (interp, buf);
  237.                 break;
  238.             } else {
  239.                 break;
  240.             }
  241.         }
  242.     }
  243.     /*
  244.      * Set variable to its final value.
  245.      */
  246.     sprintf (itxt,"%ld",i);
  247.     if (Tcl_SetVar (interp, argv [1], itxt, TCL_LEAVE_ERR_MSG) == NULL)
  248.         return TCL_ERROR;
  249.  
  250.     return result;
  251. }
  252.