/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclclock.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclclock.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 44 - (show annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 9901 byte(s)
Rename for reorganization.
1 /* $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 */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25