* Removed lots of deprecated stuff.
[bpt/guile.git] / libguile / stime.c
CommitLineData
e4b265d8 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc.
1c299a6b 2 *
0f2d19dd
JB
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
1c299a6b 7 *
0f2d19dd
JB
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
1c299a6b 12 *
0f2d19dd
JB
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
82892bed
JB
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84 41
1bbd0b84 42
0f2d19dd
JB
43\f
44
45#include <stdio.h>
e6e2e95a
MD
46#include <errno.h>
47
a0599745
MD
48#include "libguile/_scm.h"
49#include "libguile/feature.h"
50#include "libguile/strings.h"
51#include "libguile/vectors.h"
20e6290e 52
a0599745
MD
53#include "libguile/validate.h"
54#include "libguile/stime.h"
20e6290e 55
0f2d19dd
JB
56#ifdef HAVE_UNISTD_H
57#include <unistd.h>
58#endif
59
60\f
61# ifdef HAVE_SYS_TYPES_H
62# include <sys/types.h>
63# endif
64
a15e6dcc
MV
65#ifdef HAVE_STRING_H
66#include <string.h>
67#endif
68
0f2d19dd
JB
69# ifdef TIME_WITH_SYS_TIME
70# include <sys/time.h>
71# include <time.h>
72# else
73# ifdef HAVE_SYS_TIME_H
74# include <sys/time.h>
75# else
76# ifdef HAVE_TIME_H
77# include <time.h>
78# endif
79# endif
80# endif
81
b1978258
GH
82#ifdef HAVE_SYS_TIMES_H
83# include <sys/times.h>
84#endif
85
86#ifdef HAVE_SYS_TIMEB_H
87# include <sys/timeb.h>
88#endif
0f2d19dd 89
b9525b92
GH
90#ifndef tzname /* For SGI. */
91extern char *tzname[]; /* RS6000 and others reject char **tzname. */
92#endif
93
4d3bacdd
JB
94#ifdef MISSING_STRPTIME_DECL
95extern char *strptime ();
96#endif
97
cda55316 98/* This should be figured out by autoconf. */
a2fc27b5 99#if ! defined(CLKTCK) && defined(CLK_TCK)
82893676 100# define CLKTCK ((int) CLK_TCK)
a2fc27b5
JB
101#endif
102#if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
82893676 103# define CLKTCK ((int) CLOCKS_PER_SEC)
a2fc27b5
JB
104#endif
105#if ! defined(CLKTCK)
0f2d19dd 106# define CLKTCK 60
0f2d19dd
JB
107#endif
108
0f2d19dd
JB
109#ifdef __STDC__
110# define timet time_t
111#else
112# define timet long
113#endif
114
115#ifdef HAVE_TIMES
0f2d19dd 116static
1c299a6b 117timet mytime()
0f2d19dd
JB
118{
119 struct tms time_buffer;
120 times(&time_buffer);
121 return time_buffer.tms_utime + time_buffer.tms_stime;
122}
123#else
124# ifdef LACK_CLOCK
125# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
126# else
127# define mytime clock
128# endif
129#endif
130
0f2d19dd 131#ifdef HAVE_FTIME
0f2d19dd 132struct timeb scm_your_base = {0};
b450f070
GB
133#else
134timet scm_your_base = 0;
135#endif
1bbd0b84 136
1c299a6b 137SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
1bbd0b84 138 (),
1e6808ea
MG
139 "Return the number of time units since the interpreter was\n"
140 "started.")
1bbd0b84 141#define FUNC_NAME s_scm_get_internal_real_time
0f2d19dd 142{
b450f070 143#ifdef HAVE_FTIME
0f2d19dd 144 struct timeb time_buffer;
55c4d089
JB
145
146 SCM tmp;
147 ftime (&time_buffer);
0f2d19dd 148 time_buffer.time -= scm_your_base.time;
55c4d089
JB
149 tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
150 tmp = scm_sum (tmp,
151 scm_product (SCM_MAKINUM (1000),
152 SCM_MAKINUM (time_buffer.time)));
153 return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
154 SCM_MAKINUM (1000));
0f2d19dd 155#else
19468eff 156 return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
b450f070 157#endif /* HAVE_FTIME */
0f2d19dd 158}
1bbd0b84
GB
159#undef FUNC_NAME
160
0f2d19dd 161
f25f761d 162#ifdef HAVE_TIMES
1c299a6b 163SCM_DEFINE (scm_times, "times", 0, 0, 0,
1bbd0b84 164 (void),
1e6808ea
MG
165 "Return an object with information about real and processor\n"
166 "time. The following procedures accept such an object as an\n"
167 "argument and return a selected component:\n"
168 "\n"
b380b885
MD
169 "@table @code\n"
170 "@item tms:clock\n"
171 "The current real time, expressed as time units relative to an\n"
172 "arbitrary base.\n"
173 "@item tms:utime\n"
174 "The CPU time units used by the calling process.\n"
175 "@item tms:stime\n"
1e6808ea
MG
176 "The CPU time units used by the system on behalf of the calling\n"
177 "process.\n"
b380b885 178 "@item tms:cutime\n"
1e6808ea
MG
179 "The CPU time units used by terminated child processes of the\n"
180 "calling process, whose status has been collected (e.g., using\n"
181 "@code{waitpid}).\n"
b380b885 182 "@item tms:cstime\n"
1e6808ea 183 "Similarly, the CPU times units used by the system on behalf of\n"
b380b885
MD
184 "terminated child processes.\n"
185 "@end table")
1bbd0b84 186#define FUNC_NAME s_scm_times
6afcd3b2 187{
6afcd3b2
GH
188 struct tms t;
189 clock_t rv;
190
00ffa0e7 191 SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
6afcd3b2
GH
192 rv = times (&t);
193 if (rv == -1)
1bbd0b84 194 SCM_SYSERROR;
6afcd3b2
GH
195 SCM_VELTS (result)[0] = scm_long2num (rv);
196 SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
197 SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
198 SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
199 SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
200 return result;
6afcd3b2 201}
1bbd0b84 202#undef FUNC_NAME
f25f761d 203#endif /* HAVE_TIMES */
6afcd3b2 204
0f2d19dd
JB
205static long scm_my_base = 0;
206
1c299a6b
ML
207long
208scm_c_get_internal_run_time ()
209{
210 return mytime () - scm_my_base;
211}
212
213SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
1bbd0b84 214 (void),
1e6808ea
MG
215 "Return the number of time units of processor time used by the\n"
216 "interpreter. Both @emph{system} and @emph{user} time are\n"
217 "included but subprocesses are not.")
1bbd0b84 218#define FUNC_NAME s_scm_get_internal_run_time
0f2d19dd 219{
1c299a6b 220 return scm_long2num (scm_c_get_internal_run_time ());
0f2d19dd 221}
1bbd0b84 222#undef FUNC_NAME
0f2d19dd 223
1c299a6b 224SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
1bbd0b84 225 (void),
1e6808ea
MG
226 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
227 "excluding leap seconds.")
1bbd0b84 228#define FUNC_NAME s_scm_current_time
0f2d19dd 229{
19468eff
GH
230 timet timv;
231
232 SCM_DEFER_INTS;
233 if ((timv = time (0)) == -1)
1bbd0b84 234 SCM_SYSERROR;
19468eff
GH
235 SCM_ALLOW_INTS;
236 return scm_long2num((long) timv);
237}
1bbd0b84 238#undef FUNC_NAME
19468eff 239
1c299a6b 240SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
1bbd0b84 241 (void),
1e6808ea
MG
242 "Return a pair containing the number of seconds and microseconds\n"
243 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
244 "whether true microsecond resolution is available depends on the\n"
245 "operating system.")
1bbd0b84 246#define FUNC_NAME s_scm_gettimeofday
19468eff
GH
247{
248#ifdef HAVE_GETTIMEOFDAY
249 struct timeval time;
250
251 SCM_DEFER_INTS;
252 if (gettimeofday (&time, NULL) == -1)
1bbd0b84 253 SCM_SYSERROR;
19468eff
GH
254 SCM_ALLOW_INTS;
255 return scm_cons (scm_long2num ((long) time.tv_sec),
256 scm_long2num ((long) time.tv_usec));
257#else
258# ifdef HAVE_FTIME
259 struct timeb time;
260
261 ftime(&time);
1c299a6b 262 return scm_cons (scm_long2num ((long) time.time),
9a81afca 263 SCM_MAKINUM (time.millitm * 1000));
19468eff
GH
264# else
265 timet timv;
1c299a6b 266
19468eff
GH
267 SCM_DEFER_INTS;
268 if ((timv = time (0)) == -1)
1bbd0b84 269 SCM_SYSERROR;
19468eff
GH
270 SCM_ALLOW_INTS;
271 return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
272# endif
273#endif
274}
1bbd0b84 275#undef FUNC_NAME
19468eff
GH
276
277static SCM
278filltime (struct tm *bd_time, int zoff, char *zname)
279{
00ffa0e7 280 SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
19468eff
GH
281
282 SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
283 SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
284 SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
285 SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
286 SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
287 SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
288 SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
289 SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
290 SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
291 SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
b9525b92 292 SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
19468eff
GH
293 return result;
294}
295
ef9ff3fd
GH
296static char tzvar[3] = "TZ";
297extern char ** environ;
298
38c1d3c4
GH
299/* if zone is set, create a temporary environment with only a TZ
300 string. other threads or interrupt handlers shouldn't be allowed
301 to run until the corresponding restorezone is called. hence the use
302 of a static variable for tmpenv is no big deal. */
ef9ff3fd 303static char **
3eeba8d4 304setzone (SCM zone, int pos, const char *subr)
b9525b92 305{
ef9ff3fd 306 char **oldenv = 0;
b9525b92
GH
307
308 if (!SCM_UNBNDP (zone))
309 {
ef9ff3fd 310 static char *tmpenv[2];
b9525b92
GH
311 char *buf;
312
9fd38a3d 313 SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr);
9fd38a3d 314 buf = scm_must_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1, subr);
a6d9e5ab 315 sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone));
ef9ff3fd
GH
316 oldenv = environ;
317 tmpenv[0] = buf;
318 tmpenv[1] = 0;
319 environ = tmpenv;
b9525b92 320 }
ef9ff3fd 321 return oldenv;
b9525b92
GH
322}
323
324static void
e81d98ec 325restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
b9525b92
GH
326{
327 if (!SCM_UNBNDP (zone))
328 {
ef9ff3fd
GH
329 scm_must_free (environ[0]);
330 environ = oldenv;
38c1d3c4
GH
331#ifdef HAVE_TZSET
332 /* for the possible benefit of user code linked with libguile. */
b9525b92 333 tzset();
38c1d3c4 334#endif
b9525b92
GH
335 }
336}
337
1c299a6b 338SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
1bbd0b84 339 (SCM time, SCM zone),
1e6808ea
MG
340 "Return an object representing the broken down components of\n"
341 "@var{time}, an integer like the one returned by\n"
342 "@code{current-time}. The time zone for the calculation is\n"
343 "optionally specified by @var{zone} (a string), otherwise the\n"
344 "@code{TZ} environment variable or the system default is used.")
1bbd0b84 345#define FUNC_NAME s_scm_localtime
19468eff
GH
346{
347 timet itime;
4edc089c 348 struct tm *ltptr, lt, *utc;
19468eff
GH
349 SCM result;
350 int zoff;
351 char *zname = 0;
ef9ff3fd 352 char **oldenv;
19468eff
GH
353 int err;
354
e4b265d8 355 itime = SCM_NUM2LONG (1, time);
38c1d3c4
GH
356
357 /* deferring interupts is essential since a) setzone may install a temporary
358 environment b) localtime uses a static buffer. */
19468eff 359 SCM_DEFER_INTS;
1bbd0b84 360 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
38c1d3c4
GH
361#ifdef LOCALTIME_CACHE
362 tzset ();
363#endif
4edc089c 364 ltptr = localtime (&itime);
19468eff 365 err = errno;
4edc089c 366 if (ltptr)
19468eff 367 {
4d3bacdd 368 const char *ptr;
ef9ff3fd 369
43ff3170
GH
370 /* copy zone name before calling gmtime or restoring zone. */
371#if defined (HAVE_TM_ZONE)
ef9ff3fd 372 ptr = ltptr->tm_zone;
43ff3170 373#elif defined (HAVE_TZNAME)
ef9ff3fd 374 ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
43ff3170
GH
375#else
376 ptr = "";
b9525b92 377#endif
1bbd0b84 378 zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
ef9ff3fd 379 strcpy (zname, ptr);
19468eff 380 }
ef9ff3fd
GH
381 /* the struct is copied in case localtime and gmtime share a buffer. */
382 if (ltptr)
383 lt = *ltptr;
384 utc = gmtime (&itime);
385 if (utc == NULL)
386 err = errno;
1bbd0b84 387 restorezone (zone, oldenv, FUNC_NAME);
b9525b92 388 /* delayed until zone has been restored. */
19468eff 389 errno = err;
4edc089c 390 if (utc == NULL || ltptr == NULL)
1bbd0b84 391 SCM_SYSERROR;
19468eff
GH
392
393 /* calculate timezone offset in seconds west of UTC. */
4edc089c
GH
394 zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
395 + utc->tm_sec - lt.tm_sec;
396 if (utc->tm_year < lt.tm_year)
19468eff 397 zoff -= 24 * 60 * 60;
4edc089c 398 else if (utc->tm_year > lt.tm_year)
19468eff 399 zoff += 24 * 60 * 60;
4edc089c 400 else if (utc->tm_yday < lt.tm_yday)
19468eff 401 zoff -= 24 * 60 * 60;
4edc089c 402 else if (utc->tm_yday > lt.tm_yday)
19468eff 403 zoff += 24 * 60 * 60;
1c299a6b 404
4edc089c 405 result = filltime (&lt, zoff, zname);
19468eff 406 SCM_ALLOW_INTS;
ef9ff3fd 407 scm_must_free (zname);
19468eff
GH
408 return result;
409}
1bbd0b84 410#undef FUNC_NAME
19468eff 411
1c299a6b 412SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
1bbd0b84 413 (SCM time),
1e6808ea
MG
414 "Return an object representing the broken down components of\n"
415 "@var{time}, an integer like the one returned by\n"
416 "@code{current-time}. The values are calculated for UTC.")
1bbd0b84 417#define FUNC_NAME s_scm_gmtime
19468eff
GH
418{
419 timet itime;
420 struct tm *bd_time;
421 SCM result;
422
e4b265d8 423 itime = SCM_NUM2LONG (1, time);
19468eff
GH
424 SCM_DEFER_INTS;
425 bd_time = gmtime (&itime);
426 if (bd_time == NULL)
1bbd0b84 427 SCM_SYSERROR;
19468eff
GH
428 result = filltime (bd_time, 0, "GMT");
429 SCM_ALLOW_INTS;
430 return result;
431}
1bbd0b84 432#undef FUNC_NAME
19468eff 433
b9525b92
GH
434/* copy time components from a Scheme object to a struct tm. */
435static void
3eeba8d4 436bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
19468eff 437{
55a7fc62
GH
438 SCM *velts;
439 int i;
440
0c95b57d 441 SCM_ASSERT (SCM_VECTORP (sbd_time)
9fd38a3d 442 && SCM_VECTOR_LENGTH (sbd_time) == 11,
b9525b92 443 sbd_time, pos, subr);
55a7fc62
GH
444 velts = SCM_VELTS (sbd_time);
445 for (i = 0; i < 10; i++)
446 {
447 SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr);
448 }
0c95b57d 449 SCM_ASSERT (SCM_FALSEP (velts[10]) || SCM_STRINGP (velts[10]),
55a7fc62
GH
450 sbd_time, pos, subr);
451
452 lt->tm_sec = SCM_INUM (velts[0]);
453 lt->tm_min = SCM_INUM (velts[1]);
454 lt->tm_hour = SCM_INUM (velts[2]);
455 lt->tm_mday = SCM_INUM (velts[3]);
456 lt->tm_mon = SCM_INUM (velts[4]);
457 lt->tm_year = SCM_INUM (velts[5]);
458 lt->tm_wday = SCM_INUM (velts[6]);
459 lt->tm_yday = SCM_INUM (velts[7]);
460 lt->tm_isdst = SCM_INUM (velts[8]);
c7abe4f3 461#ifdef HAVE_TM_ZONE
55a7fc62
GH
462 lt->tm_gmtoff = SCM_INUM (velts[9]);
463 if (SCM_FALSEP (velts[10]))
464 lt->tm_zone = NULL;
465 else
a002f1a2 466 lt->tm_zone = SCM_STRING_CHARS (velts[10]);
c7abe4f3 467#endif
b9525b92
GH
468}
469
1c299a6b 470SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
1bbd0b84 471 (SCM sbd_time, SCM zone),
a3c8b9fc
MD
472 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
473 "is an optional time zone specifier (otherwise the TZ environment variable\n"
474 "or the system default is used).\n\n"
a8eac221 475 "Returns a pair: the car is a corresponding\n"
a3c8b9fc 476 "integer time value like that returned\n"
a8eac221 477 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
a3c8b9fc 478 "as @var{bd-time} but with normalized values.")
1bbd0b84 479#define FUNC_NAME s_scm_mktime
b9525b92
GH
480{
481 timet itime;
482 struct tm lt, *utc;
483 SCM result;
484 int zoff;
485 char *zname = 0;
ef9ff3fd 486 char **oldenv;
b9525b92
GH
487 int err;
488
1bbd0b84 489 bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
19468eff
GH
490
491 SCM_DEFER_INTS;
1bbd0b84 492 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
38c1d3c4
GH
493#ifdef LOCALTIME_CACHE
494 tzset ();
495#endif
19468eff 496 itime = mktime (&lt);
b9525b92 497 err = errno;
19468eff 498
b9525b92
GH
499 if (itime != -1)
500 {
4d3bacdd 501 const char *ptr;
ef9ff3fd 502
43ff3170
GH
503 /* copy zone name before calling gmtime or restoring the zone. */
504#if defined (HAVE_TM_ZONE)
ef9ff3fd 505 ptr = lt.tm_zone;
43ff3170 506#elif defined (HAVE_TZNAME)
ef9ff3fd 507 ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
43ff3170
GH
508#else
509 ptr = "";
b9525b92 510#endif
1bbd0b84 511 zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
ef9ff3fd 512 strcpy (zname, ptr);
b9525b92 513 }
ef9ff3fd
GH
514
515 /* get timezone offset in seconds west of UTC. */
516 utc = gmtime (&itime);
517 if (utc == NULL)
518 err = errno;
519
1bbd0b84 520 restorezone (zone, oldenv, FUNC_NAME);
b9525b92
GH
521 /* delayed until zone has been restored. */
522 errno = err;
523 if (utc == NULL || itime == -1)
1bbd0b84 524 SCM_SYSERROR;
b9525b92 525
19468eff
GH
526 zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
527 + utc->tm_sec - lt.tm_sec;
528 if (utc->tm_year < lt.tm_year)
529 zoff -= 24 * 60 * 60;
530 else if (utc->tm_year > lt.tm_year)
531 zoff += 24 * 60 * 60;
532 else if (utc->tm_yday < lt.tm_yday)
533 zoff -= 24 * 60 * 60;
534 else if (utc->tm_yday > lt.tm_yday)
535 zoff += 24 * 60 * 60;
536
19468eff
GH
537 result = scm_cons (scm_long2num ((long) itime),
538 filltime (&lt, zoff, zname));
539 SCM_ALLOW_INTS;
ef9ff3fd 540 scm_must_free (zname);
19468eff 541 return result;
0f2d19dd 542}
1bbd0b84 543#undef FUNC_NAME
0f2d19dd 544
38c1d3c4 545#ifdef HAVE_TZSET
1c299a6b 546SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
1bbd0b84 547 (void),
a3c8b9fc
MD
548 "Initialize the timezone from the TZ environment variable\n"
549 "or the system default. It's not usually necessary to call this procedure\n"
550 "since it's done automatically by other procedures that depend on the\n"
551 "timezone.")
1bbd0b84 552#define FUNC_NAME s_scm_tzset
0f2d19dd 553{
19468eff
GH
554 tzset();
555 return SCM_UNSPECIFIED;
0f2d19dd 556}
1bbd0b84 557#undef FUNC_NAME
38c1d3c4 558#endif /* HAVE_TZSET */
0f2d19dd 559
a1ec6916 560SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
1bbd0b84 561 (SCM format, SCM stime),
a3c8b9fc
MD
562 "Formats a time specification @var{time} using @var{template}. @var{time}\n"
563 "is an object with time components in the form returned by @code{localtime}\n"
564 "or @code{gmtime}. @var{template} is a string which can include formatting\n"
565 "specifications introduced by a @code{%} character. The formatting of\n"
566 "month and day names is dependent on the current locale. The value returned\n"
567 "is the formatted string.\n"
568 "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
1bbd0b84 569#define FUNC_NAME s_scm_strftime
b9525b92
GH
570{
571 struct tm t;
572
573 char *tbuf;
574 int size = 50;
a15e6dcc 575 char *fmt, *myfmt;
b9525b92 576 int len;
ef9ff3fd 577 SCM result;
b9525b92 578
a6d9e5ab 579 SCM_VALIDATE_STRING (1, format);
1bbd0b84 580 bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
b9525b92 581
a6d9e5ab
DH
582 fmt = SCM_STRING_CHARS (format);
583 len = SCM_STRING_LENGTH (format);
b9525b92 584
a15e6dcc
MV
585 /* Ugly hack: strftime can return 0 if its buffer is too small,
586 but some valid time strings (e.g. "%p") can sometimes produce
587 a zero-byte output string! Workaround is to prepend a junk
588 character to the format string, so that valid returns are always
589 nonzero. */
590 myfmt = SCM_MUST_MALLOC (len+2);
591 *myfmt = 'x';
592 strncpy(myfmt+1, fmt, len);
593 myfmt[len+1] = 0;
594
1bbd0b84 595 tbuf = SCM_MUST_MALLOC (size);
b8a1b29b
GH
596 {
597#if !defined (HAVE_TM_ZONE)
598 /* it seems the only way to tell non-GNU versions of strftime what
599 zone to use (for the %Z format) is to set TZ in the
600 environment. interrupts and thread switching must be deferred
601 until TZ is restored. */
602 char **oldenv = NULL;
603 SCM *velts = SCM_VELTS (stime);
e652b54f 604 int have_zone = 0;
b8a1b29b 605
36284627 606 if (!SCM_FALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0)
b8a1b29b
GH
607 {
608 /* it's not required that the TZ setting be correct, just that
e652b54f
GH
609 it has the right name. so try something like TZ=EST0.
610 using only TZ=EST would be simpler but it doesn't work on
611 some OSs, e.g., Solaris. */
612 SCM zone =
613 scm_string_append (scm_cons (velts[10],
614 scm_cons (scm_makfrom0str ("0"),
615 SCM_EOL)));
1c299a6b 616
e652b54f 617 have_zone = 1;
b8a1b29b 618 SCM_DEFER_INTS;
e652b54f 619 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
b8a1b29b
GH
620 }
621#endif
622
38c1d3c4 623#ifdef LOCALTIME_CACHE
b8a1b29b
GH
624 tzset ();
625#endif
626
a15e6dcc
MV
627 /* POSIX says strftime returns 0 on buffer overrun, but old
628 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
629 case. */
630 while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
b8a1b29b
GH
631 {
632 scm_must_free (tbuf);
633 size *= 2;
634 tbuf = SCM_MUST_MALLOC (size);
635 }
636
637#if !defined (HAVE_TM_ZONE)
e652b54f 638 if (have_zone)
b8a1b29b
GH
639 {
640 restorezone (velts[10], oldenv, FUNC_NAME);
641 SCM_ALLOW_INTS;
642 }
38c1d3c4 643#endif
b9525b92 644 }
b8a1b29b 645
36284627 646 result = scm_mem2string (tbuf + 1, len - 1);
ef9ff3fd 647 scm_must_free (tbuf);
a15e6dcc 648 scm_must_free(myfmt);
ef9ff3fd 649 return result;
b9525b92 650}
1bbd0b84 651#undef FUNC_NAME
b9525b92 652
f25f761d 653#ifdef HAVE_STRPTIME
a1ec6916 654SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
1bbd0b84 655 (SCM format, SCM string),
a8eac221
MG
656 "Performs the reverse action to @code{strftime}, parsing\n"
657 "@var{string} according to the specification supplied in\n"
658 "@var{template}. The interpretation of month and day names is\n"
659 "dependent on the current locale. The value returned is a pair.\n"
660 "The car has an object with time components\n"
a3c8b9fc
MD
661 "in the form returned by @code{localtime} or @code{gmtime},\n"
662 "but the time zone components\n"
663 "are not usefully set.\n"
a8eac221
MG
664 "The cdr reports the number of characters from @var{string}\n"
665 "which were used for the conversion.")
1bbd0b84 666#define FUNC_NAME s_scm_strptime
b9525b92 667{
b9525b92
GH
668 struct tm t;
669 char *fmt, *str, *rest;
670
a6d9e5ab
DH
671 SCM_VALIDATE_STRING (1, format);
672 SCM_VALIDATE_STRING (2, string);
b9525b92 673
a6d9e5ab
DH
674 fmt = SCM_STRING_CHARS (format);
675 str = SCM_STRING_CHARS (string);
b9525b92
GH
676
677 /* initialize the struct tm */
678#define tm_init(field) t.field = 0
679 tm_init (tm_sec);
680 tm_init (tm_min);
681 tm_init (tm_hour);
682 tm_init (tm_mday);
683 tm_init (tm_mon);
684 tm_init (tm_year);
685 tm_init (tm_wday);
686 tm_init (tm_yday);
687#undef tm_init
688
689 t.tm_isdst = -1;
690 SCM_DEFER_INTS;
691 if ((rest = strptime (str, fmt, &t)) == NULL)
1bbd0b84 692 SCM_SYSERROR;
b9525b92
GH
693
694 SCM_ALLOW_INTS;
695 return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
b9525b92 696}
1bbd0b84 697#undef FUNC_NAME
f25f761d 698#endif /* HAVE_STRPTIME */
b9525b92 699
0f2d19dd
JB
700void
701scm_init_stime()
0f2d19dd 702{
86d31dfe 703 scm_c_define ("internal-time-units-per-second",
19468eff 704 scm_long2num((long)CLKTCK));
0f2d19dd
JB
705
706#ifdef HAVE_FTIME
707 if (!scm_your_base.time) ftime(&scm_your_base);
708#else
709 if (!scm_your_base) time(&scm_your_base);
710#endif
711
712 if (!scm_my_base) scm_my_base = mytime();
713
876c87ce 714 scm_add_feature ("current-time");
8dc9439f 715#ifndef SCM_MAGIC_SNARFER
a0599745 716#include "libguile/stime.x"
8dc9439f 717#endif
0f2d19dd
JB
718}
719
89e00824
ML
720
721/*
722 Local Variables:
723 c-file-style: "gnu"
724 End:
725*/