shared_source/c_tcl_base_7_5_w_mods/tclclock.c

/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclclock.c,v 1.1.1.1 2001/06/13 04:34:06 dtashley Exp $ */

/* 
 * tclClock.c --
 *
 *      Contains the time and date related commands.  This code
 *      is derived from the time and date facilities of TclX,
 *      by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
 * Copyright (c) 1995 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclclock.c,v 1.1.1.1 2001/06/13 04:34:06 dtashley Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclPort.h"

/*
 * The date parsing stuff uses lexx and has tons o statics.
 */

TCL_DECLARE_MUTEX(clockMutex)

/*
 * Function prototypes for local procedures in this file:
 */

static int              FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
                            unsigned long clockVal, int useGMT,
                            char *format));

/*
 *-------------------------------------------------------------------------
 *
 * Tcl_ClockObjCmd --
 *
 *      This procedure is invoked to process the "clock" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *-------------------------------------------------------------------------
 */

int
Tcl_ClockObjCmd (client, interp, objc, objv)
    ClientData client;                  /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];              /* Argument values. */
{
    Tcl_Obj *resultPtr;
    int index;
    Tcl_Obj *CONST *objPtr;
    int useGMT = 0;
    char *format = "%a %b %d %X %Z %Y";
    int dummy;
    unsigned long baseClock, clockVal;
    long zone;
    Tcl_Obj *baseObjPtr = NULL;
    char *scanStr;
    
    static char *switches[] =
        {"clicks", "format", "scan", "seconds", (char *) NULL};
    enum command { COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN,
                       COMMAND_SECONDS
    };
    static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL};
    static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL};

    resultPtr = Tcl_GetObjResult(interp);
    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
        return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
            != TCL_OK) {
        return TCL_ERROR;
    }
    switch ((enum command) index) {
        case COMMAND_CLICKS:    {               /* clicks */
            int forceMilli = 0;

            if (objc == 3) {
                format = Tcl_GetStringFromObj(objv[2], &index);
                if (strncmp(format, "-milliseconds",
                        (unsigned int) index) == 0) {
                    forceMilli = 1;
                } else {
                    Tcl_AppendStringsToObj(resultPtr,
                            "bad switch \"", format,
                            "\": must be -milliseconds", (char *) NULL);
                    return TCL_ERROR;
                }
            } else if (objc != 2) {
                Tcl_WrongNumArgs(interp, 2, objv, "?-milliseconds?");
                return TCL_ERROR;
            }
            if (forceMilli) {
                /*
                 * We can enforce at least millisecond granularity
                 */
                Tcl_Time time;
                TclpGetTime(&time);
                Tcl_SetLongObj(resultPtr,
                        (long) (time.sec*1000 + time.usec/1000));
            } else {
                Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
            }
            return TCL_OK;
        }

        case COMMAND_FORMAT:                    /* format */
            if ((objc < 3) || (objc > 7)) {
                wrongFmtArgs:
                Tcl_WrongNumArgs(interp, 2, objv,
                        "clockval ?-format string? ?-gmt boolean?");
                return TCL_ERROR;
            }

            if (Tcl_GetLongFromObj(interp, objv[2], (long*) &clockVal)
                    != TCL_OK) {
                return TCL_ERROR;
            }
    
            objPtr = objv+3;
            objc -= 3;
            while (objc > 1) {
                if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches,
                        "switch", 0, &index) != TCL_OK) {
                    return TCL_ERROR;
                }
                switch (index) {
                    case 0:             /* -format */
                        format = Tcl_GetStringFromObj(objPtr[1], &dummy);
                        break;
                    case 1:             /* -gmt */
                        if (Tcl_GetBooleanFromObj(interp, objPtr[1],
                                &useGMT) != TCL_OK) {
                            return TCL_ERROR;
                        }
                        break;
                }
                objPtr += 2;
                objc -= 2;
            }
            if (objc != 0) {
                goto wrongFmtArgs;
            }
            return FormatClock(interp, (unsigned long) clockVal, useGMT,
                    format);

        case COMMAND_SCAN:                      /* scan */
            if ((objc < 3) || (objc > 7)) {
                wrongScanArgs:
                Tcl_WrongNumArgs(interp, 2, objv,
                        "dateString ?-base clockValue? ?-gmt boolean?");
                return TCL_ERROR;
            }

            objPtr = objv+3;
            objc -= 3;
            while (objc > 1) {
                if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
                        "switch", 0, &index) != TCL_OK) {
                    return TCL_ERROR;
                }
                switch (index) {
                    case 0:             /* -base */
                        baseObjPtr = objPtr[1];
                        break;
                    case 1:             /* -gmt */
                        if (Tcl_GetBooleanFromObj(interp, objPtr[1],
                                &useGMT) != TCL_OK) {
                            return TCL_ERROR;
                        }
                        break;
                }
                objPtr += 2;
                objc -= 2;
            }
            if (objc != 0) {
                goto wrongScanArgs;
            }

            if (baseObjPtr != NULL) {
                if (Tcl_GetLongFromObj(interp, baseObjPtr,
                        (long*) &baseClock) != TCL_OK) {
                    return TCL_ERROR;
                }
            } else {
                baseClock = TclpGetSeconds();
            }

            if (useGMT) {
                zone = -50000; /* Force GMT */
            } else {
                zone = TclpGetTimeZone((unsigned long) baseClock);
            }

            scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
            Tcl_MutexLock(&clockMutex);
            if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
                    (unsigned long *) &clockVal) < 0) {
                Tcl_MutexUnlock(&clockMutex);
                Tcl_AppendStringsToObj(resultPtr,
                        "unable to convert date-time string \"",
                        scanStr, "\"", (char *) NULL);
                return TCL_ERROR;
            }
            Tcl_MutexUnlock(&clockMutex);

            Tcl_SetLongObj(resultPtr, (long) clockVal);
            return TCL_OK;

        case COMMAND_SECONDS:                   /* seconds */
            if (objc != 2) {
                Tcl_WrongNumArgs(interp, 2, objv, NULL);
                return TCL_ERROR;
            }
            Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
            return TCL_OK;
        default:
            return TCL_ERROR;   /* Should never be reached. */
    }
}

/*
 *-----------------------------------------------------------------------------
 *
 * FormatClock --
 *
 *      Formats a time value based on seconds into a human readable
 *      string.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      None.
 *
 *-----------------------------------------------------------------------------
 */

static int
FormatClock(interp, clockVal, useGMT, format)
    Tcl_Interp *interp;                 /* Current interpreter. */
    unsigned long clockVal;             /* Time in seconds. */
    int useGMT;                         /* Boolean */
    char *format;                       /* Format string */
{
    struct tm *timeDataPtr;
    Tcl_DString buffer;
    int bufSize;
    char *p;
    int result;
    time_t tclockVal;
#ifndef HAVE_TM_ZONE
    int savedTimeZone = 0;      /* lint. */
    char *savedTZEnv = NULL;    /* lint. */
#endif

#ifdef HAVE_TZSET
    /*
     * Some systems forgot to call tzset in localtime, make sure its done.
     */
    static int  calledTzset = 0;

    Tcl_MutexLock(&clockMutex);
    if (!calledTzset) {
        tzset();
        calledTzset = 1;
    }
    Tcl_MutexUnlock(&clockMutex);
#endif

    /*
     * If the user gave us -format "", just return now
     */
    if (*format == '\0') {
        return TCL_OK;
    }

#ifndef HAVE_TM_ZONE
    /*
     * This is a kludge for systems not having the timezone string in
     * struct tm.  No matter what was specified, they use the local
     * timezone string.
     */

    if (useGMT) {
        char *varValue;

        varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
        if (varValue != NULL) {
            savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
        } else {
            savedTZEnv = NULL;
        }
        Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY);
        savedTimeZone = timezone;
        timezone = 0;
        tzset();
    }
#endif

    tclockVal = clockVal;
    timeDataPtr = TclpGetDate((TclpTime_t) &tclockVal, useGMT);
    
    /*
     * Make a guess at the upper limit on the substituted string size
     * based on the number of percents in the string.
     */

    for (bufSize = 1, p = format; *p != '\0'; p++) {
        if (*p == '%') {
            bufSize += 40;
        } else {
            bufSize++;
        }
    }
    Tcl_DStringInit(&buffer);
    Tcl_DStringSetLength(&buffer, bufSize);

    Tcl_MutexLock(&clockMutex);
    result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
            timeDataPtr);
    Tcl_MutexUnlock(&clockMutex);

#ifndef HAVE_TM_ZONE
    if (useGMT) {
        if (savedTZEnv != NULL) {
            Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
            ckfree(savedTZEnv);
        } else {
            Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
        }
        timezone = savedTimeZone;
        tzset();
    }
#endif

    if (result == 0) {
        /*
         * A zero return is the error case (can also mean the strftime
         * didn't get enough space to write into).  We know it doesn't
         * mean that we wrote zero chars because the check for an empty
         * format string is above.
         */
        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad format string \"", format, "\"", (char *) NULL);
        return TCL_ERROR;
    }

    Tcl_SetStringObj(Tcl_GetObjResult(interp), buffer.string, -1);
    Tcl_DStringFree(&buffer);
    return TCL_OK;
}


/* $History: tclclock.c $
 * 
 * *****************  Version 1  *****************
 * User: Dtashley     Date: 1/02/01    Time: 1:31a
 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
 * Initial check-in.
 */ 

/* End of TCLCLOCK.C */
1	dashley	25	/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclclock.c,v 1.1.1.1 2001/06/13 04:34:06 dtashley Exp $ */
2
3			/*
4			* tclClock.c --
5			*
6			* Contains the time and date related commands. This code
7			* is derived from the time and date facilities of TclX,
8			* by Mark Diekhans and Karl Lehenbauer.
9			*
10			* Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
11			* Copyright (c) 1995 Sun Microsystems, Inc.
12			*
13			* See the file "license.terms" for information on usage and redistribution
14			* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15			*
16			* RCS: @(#) $Id: tclclock.c,v 1.1.1.1 2001/06/13 04:34:06 dtashley Exp $
17			*/
18
19			#include "tcl.h"
20			#include "tclInt.h"
21			#include "tclPort.h"
22
23			/*
24			* The date parsing stuff uses lexx and has tons o statics.
25			*/
26
27			TCL_DECLARE_MUTEX(clockMutex)
28
29			/*
30			* Function prototypes for local procedures in this file:
31			*/
32
33			static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
34			unsigned long clockVal, int useGMT,
35			char *format));
36
37			/*
38			*-------------------------------------------------------------------------
39			*
40			* Tcl_ClockObjCmd --
41			*
42			* This procedure is invoked to process the "clock" Tcl command.
43			* See the user documentation for details on what it does.
44			*
45			* Results:
46			* A standard Tcl result.
47			*
48			* Side effects:
49			* See the user documentation.
50			*
51			*-------------------------------------------------------------------------
52			*/
53
54			int
55			Tcl_ClockObjCmd (client, interp, objc, objv)
56			ClientData client; /* Not used. */
57			Tcl_Interp interp; / Current interpreter. */
58			int objc; /* Number of arguments. */
59			Tcl_Obj CONST objv[]; / Argument values. */
60			{
61			Tcl_Obj *resultPtr;
62			int index;
63			Tcl_Obj CONST objPtr;
64			int useGMT = 0;
65			char *format = "%a %b %d %X %Z %Y";
66			int dummy;
67			unsigned long baseClock, clockVal;
68			long zone;
69			Tcl_Obj *baseObjPtr = NULL;
70			char *scanStr;
71
72			static char *switches[] =
73			{"clicks", "format", "scan", "seconds", (char *) NULL};
74			enum command { COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN,
75			COMMAND_SECONDS
76			};
77			static char formatSwitches[] = {"-format", "-gmt", (char ) NULL};
78			static char scanSwitches[] = {"-base", "-gmt", (char ) NULL};
79
80			resultPtr = Tcl_GetObjResult(interp);
81			if (objc < 2) {
82			Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
83			return TCL_ERROR;
84			}
85
86			if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
87			!= TCL_OK) {
88			return TCL_ERROR;
89			}
90			switch ((enum command) index) {
91			case COMMAND_CLICKS: { /* clicks */
92			int forceMilli = 0;
93
94			if (objc == 3) {
95			format = Tcl_GetStringFromObj(objv[2], &index);
96			if (strncmp(format, "-milliseconds",
97			(unsigned int) index) == 0) {
98			forceMilli = 1;
99			} else {
100			Tcl_AppendStringsToObj(resultPtr,
101			"bad switch \"", format,
102			"\": must be -milliseconds", (char *) NULL);
103			return TCL_ERROR;
104			}
105			} else if (objc != 2) {
106			Tcl_WrongNumArgs(interp, 2, objv, "?-milliseconds?");
107			return TCL_ERROR;
108			}
109			if (forceMilli) {
110			/*
111			* We can enforce at least millisecond granularity
112			*/
113			Tcl_Time time;
114			TclpGetTime(&time);
115			Tcl_SetLongObj(resultPtr,
116			(long) (time.sec*1000 + time.usec/1000));
117			} else {
118			Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
119			}
120			return TCL_OK;
121			}
122
123			case COMMAND_FORMAT: /* format */
124			if ((objc < 3) \|\| (objc > 7)) {
125			wrongFmtArgs:
126			Tcl_WrongNumArgs(interp, 2, objv,
127			"clockval ?-format string? ?-gmt boolean?");
128			return TCL_ERROR;
129			}
130
131			if (Tcl_GetLongFromObj(interp, objv[2], (long*) &clockVal)
132			!= TCL_OK) {
133			return TCL_ERROR;
134			}
135
136			objPtr = objv+3;
137			objc -= 3;
138			while (objc > 1) {
139			if (Tcl_GetIndexFromObj(interp, objPtr[0], formatSwitches,
140			"switch", 0, &index) != TCL_OK) {
141			return TCL_ERROR;
142			}
143			switch (index) {
144			case 0: /* -format */
145			format = Tcl_GetStringFromObj(objPtr[1], &dummy);
146			break;
147			case 1: /* -gmt */
148			if (Tcl_GetBooleanFromObj(interp, objPtr[1],
149			&useGMT) != TCL_OK) {
150			return TCL_ERROR;
151			}
152			break;
153			}
154			objPtr += 2;
155			objc -= 2;
156			}
157			if (objc != 0) {
158			goto wrongFmtArgs;
159			}
160			return FormatClock(interp, (unsigned long) clockVal, useGMT,
161			format);
162
163			case COMMAND_SCAN: /* scan */
164			if ((objc < 3) \|\| (objc > 7)) {
165			wrongScanArgs:
166			Tcl_WrongNumArgs(interp, 2, objv,
167			"dateString ?-base clockValue? ?-gmt boolean?");
168			return TCL_ERROR;
169			}
170
171			objPtr = objv+3;
172			objc -= 3;
173			while (objc > 1) {
174			if (Tcl_GetIndexFromObj(interp, objPtr[0], scanSwitches,
175			"switch", 0, &index) != TCL_OK) {
176			return TCL_ERROR;
177			}
178			switch (index) {
179			case 0: /* -base */
180			baseObjPtr = objPtr[1];
181			break;
182			case 1: /* -gmt */
183			if (Tcl_GetBooleanFromObj(interp, objPtr[1],
184			&useGMT) != TCL_OK) {
185			return TCL_ERROR;
186			}
187			break;
188			}
189			objPtr += 2;
190			objc -= 2;
191			}
192			if (objc != 0) {
193			goto wrongScanArgs;
194			}
195
196			if (baseObjPtr != NULL) {
197			if (Tcl_GetLongFromObj(interp, baseObjPtr,
198			(long*) &baseClock) != TCL_OK) {
199			return TCL_ERROR;
200			}
201			} else {
202			baseClock = TclpGetSeconds();
203			}
204
205			if (useGMT) {
206			zone = -50000; /* Force GMT */
207			} else {
208			zone = TclpGetTimeZone((unsigned long) baseClock);
209			}
210
211			scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
212			Tcl_MutexLock(&clockMutex);
213			if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
214			(unsigned long *) &clockVal) < 0) {
215			Tcl_MutexUnlock(&clockMutex);
216			Tcl_AppendStringsToObj(resultPtr,
217			"unable to convert date-time string \"",
218			scanStr, "\"", (char *) NULL);
219			return TCL_ERROR;
220			}
221			Tcl_MutexUnlock(&clockMutex);
222
223			Tcl_SetLongObj(resultPtr, (long) clockVal);
224			return TCL_OK;
225
226			case COMMAND_SECONDS: /* seconds */
227			if (objc != 2) {
228			Tcl_WrongNumArgs(interp, 2, objv, NULL);
229			return TCL_ERROR;
230			}
231			Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
232			return TCL_OK;
233			default:
234			return TCL_ERROR; /* Should never be reached. */
235			}
236			}
237
238			/*
239			*-----------------------------------------------------------------------------
240			*
241			* FormatClock --
242			*
243			* Formats a time value based on seconds into a human readable
244			* string.
245			*
246			* Results:
247			* Standard Tcl result.
248			*
249			* Side effects:
250			* None.
251			*
252			*-----------------------------------------------------------------------------
253			*/
254
255			static int
256			FormatClock(interp, clockVal, useGMT, format)
257			Tcl_Interp interp; / Current interpreter. */
258			unsigned long clockVal; /* Time in seconds. */
259			int useGMT; /* Boolean */
260			char format; / Format string */
261			{
262			struct tm *timeDataPtr;
263			Tcl_DString buffer;
264			int bufSize;
265			char *p;
266			int result;
267			time_t tclockVal;
268			#ifndef HAVE_TM_ZONE
269			int savedTimeZone = 0; /* lint. */
270			char savedTZEnv = NULL; / lint. */
271			#endif
272
273			#ifdef HAVE_TZSET
274			/*
275			* Some systems forgot to call tzset in localtime, make sure its done.
276			*/
277			static int calledTzset = 0;
278
279			Tcl_MutexLock(&clockMutex);
280			if (!calledTzset) {
281			tzset();
282			calledTzset = 1;
283			}
284			Tcl_MutexUnlock(&clockMutex);
285			#endif
286
287			/*
288			* If the user gave us -format "", just return now
289			*/
290			if (*format == '\0') {
291			return TCL_OK;
292			}
293
294			#ifndef HAVE_TM_ZONE
295			/*
296			* This is a kludge for systems not having the timezone string in
297			* struct tm. No matter what was specified, they use the local
298			* timezone string.
299			*/
300
301			if (useGMT) {
302			char *varValue;
303
304			varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
305			if (varValue != NULL) {
306			savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
307			} else {
308			savedTZEnv = NULL;
309			}
310			Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY);
311			savedTimeZone = timezone;
312			timezone = 0;
313			tzset();
314			}
315			#endif
316
317			tclockVal = clockVal;
318			timeDataPtr = TclpGetDate((TclpTime_t) &tclockVal, useGMT);
319
320			/*
321			* Make a guess at the upper limit on the substituted string size
322			* based on the number of percents in the string.
323			*/
324
325			for (bufSize = 1, p = format; *p != '\0'; p++) {
326			if (*p == '%') {
327			bufSize += 40;
328			} else {
329			bufSize++;
330			}
331			}
332			Tcl_DStringInit(&buffer);
333			Tcl_DStringSetLength(&buffer, bufSize);
334
335			Tcl_MutexLock(&clockMutex);
336			result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
337			timeDataPtr);
338			Tcl_MutexUnlock(&clockMutex);
339
340			#ifndef HAVE_TM_ZONE
341			if (useGMT) {
342			if (savedTZEnv != NULL) {
343			Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
344			ckfree(savedTZEnv);
345			} else {
346			Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
347			}
348			timezone = savedTimeZone;
349			tzset();
350			}
351			#endif
352
353			if (result == 0) {
354			/*
355			* A zero return is the error case (can also mean the strftime
356			* didn't get enough space to write into). We know it doesn't
357			* mean that we wrote zero chars because the check for an empty
358			* format string is above.
359			*/
360			Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
361			"bad format string \"", format, "\"", (char *) NULL);
362			return TCL_ERROR;
363			}
364
365			Tcl_SetStringObj(Tcl_GetObjResult(interp), buffer.string, -1);
366			Tcl_DStringFree(&buffer);
367			return TCL_OK;
368			}
369
370
371			/* $History: tclclock.c $
372			*
373			* *************** Version 1 ***************
374			* User: Dtashley Date: 1/02/01 Time: 1:31a
375			* Created in $/IjuScripter, IjuConsole/Source/Tcl Base
376			* Initial check-in.
377			*/
378
379			/* End of TCLCLOCK.C */