]>
cvs.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxgenl.c
4 * Contains general extensions to the basic TCL command set.
5 *-----------------------------------------------------------------------------
6 * Copyright 1992 Karl Lehenbauer and Mark Diekhans.
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
14 *-----------------------------------------------------------------------------
15 * $Id: tclXgeneral.c,v 2.0 1992/10/16 04:50:47 markd Rel $
16 *-----------------------------------------------------------------------------
22 * These globals must be set by main for the information to be defined.
25 char *tclxVersion
= "?"; /* Extended Tcl version number. */
26 int tclxPatchlevel
= 0; /* Extended Tcl patch level. */
28 char *tclAppName
= NULL
; /* Application name */
29 char *tclAppLongname
= NULL
; /* Long, natural language application name */
30 char *tclAppVersion
= NULL
; /* Version number of the application */
34 *-----------------------------------------------------------------------------
37 * Implements the TCL echo command:
41 * Always returns TCL_OK.
43 *-----------------------------------------------------------------------------
46 Tcl_EchoCmd(clientData
, interp
, argc
, argv
)
47 ClientData clientData
;
54 for (idx
= 1; idx
< argc
; idx
++) {
55 fputs (argv
[idx
], stdout
);
64 *-----------------------------------------------------------------------------
67 * Implements the TCL infox command:
70 *-----------------------------------------------------------------------------
73 Tcl_InfoxCmd (clientData
, interp
, argc
, argv
)
74 ClientData clientData
;
80 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
81 " option", (char *) NULL
);
85 if (STREQU ("version", argv
[1])) {
86 Tcl_SetResult (interp
, tclxVersion
, TCL_STATIC
);
87 } else if (STREQU ("patchlevel", argv
[1])) {
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
);
101 Tcl_AppendResult (interp
, "illegal option \"", argv
[1],
102 "\" expect one of: version, patchlevel, appname, ",
103 "applongname, or appversion", (char *) NULL
);
110 *-----------------------------------------------------------------------------
113 * Implements the TCL loop command:
114 * loop var start end [increment] command
117 * Standard TCL results.
119 *-----------------------------------------------------------------------------
122 Tcl_LoopCmd (dummy
, interp
, argc
, argv
)
129 long i
, first
, limit
, incr
= 1;
133 if ((argc
< 5) || (argc
> 6)) {
134 Tcl_AppendResult (interp
, tclXWrongArgs
, argv
[0],
135 " var first limit [incr] command", (char *) NULL
);
139 if (Tcl_GetLong (interp
, argv
[2], &first
) != TCL_OK
)
141 if (Tcl_GetLong (interp
, argv
[3], &limit
) != TCL_OK
)
146 if (Tcl_GetLong (interp
, argv
[4], &incr
) != TCL_OK
)
152 (((i
< limit
) && (incr
> 0)) || ((i
> limit
) && (incr
< 0)));
155 sprintf (itxt
,"%ld",i
);
156 if (Tcl_SetVar (interp
, argv
[1], itxt
, TCL_LEAVE_ERR_MSG
) == NULL
)
159 result
= Tcl_Eval(interp
, command
, 0, (char **) NULL
);
160 if (result
!= TCL_OK
) {
161 if (result
== TCL_CONTINUE
) {
163 } else if (result
== TCL_BREAK
) {
166 } else if (result
== TCL_ERROR
) {
169 sprintf (buf
, "\n (\"loop\" body line %d)",
171 Tcl_AddErrorInfo (interp
, buf
);
179 * Set variable to its final value.
181 sprintf (itxt
,"%ld",i
);
182 if (Tcl_SetVar (interp
, argv
[1], itxt
, TCL_LEAVE_ERR_MSG
) == NULL
)