shared_source/c_tcl_base_7_5_w_mods/tclclock.c

/* $Header$ */
/* 
 * 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;
}

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