1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library 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 GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 #define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
22 #define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
31 #include "libguile/_scm.h"
32 #include "libguile/feature.h"
33 #include "libguile/strings.h"
34 #include "libguile/vectors.h"
36 #include "libguile/validate.h"
37 #include "libguile/stime.h"
44 # ifdef HAVE_SYS_TYPES_H
45 # include <sys/types.h>
52 #ifdef HAVE_SYS_TIMES_H
53 # include <sys/times.h>
56 #ifdef HAVE_SYS_TIMEB_H
57 # include <sys/timeb.h>
60 #if HAVE_CRT_EXTERNS_H
61 #include <crt_externs.h> /* for Darwin _NSGetEnviron */
64 #ifndef tzname /* For SGI. */
65 extern char *tzname
[]; /* RS6000 and others reject char **tzname. */
67 #if defined (__MINGW32__)
68 # define tzname _tzname
71 #if ! HAVE_DECL_STRPTIME
72 extern char *strptime ();
81 extern char ** environ
;
83 /* On Apple Darwin in a shared library there's no "environ" to access
84 directly, instead the address of that variable must be obtained with
86 #if HAVE__NSGETENVIRON && defined (PIC)
87 #define environ (*_NSGetEnviron())
95 struct tms time_buffer
;
97 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
101 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
103 # define mytime clock
108 struct timeb scm_your_base
= {0};
110 timet scm_your_base
= 0;
113 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
115 "Return the number of time units since the interpreter was\n"
117 #define FUNC_NAME s_scm_get_internal_real_time
120 struct timeb time_buffer
;
123 ftime (&time_buffer
);
124 time_buffer
.time
-= scm_your_base
.time
;
125 tmp
= scm_long2num (time_buffer
.millitm
- scm_your_base
.millitm
);
127 scm_product (SCM_I_MAKINUM (1000),
128 SCM_I_MAKINUM (time_buffer
.time
)));
129 return scm_quotient (scm_product (tmp
, SCM_I_MAKINUM (SCM_TIME_UNITS_PER_SECOND
)),
130 SCM_I_MAKINUM (1000));
132 return scm_long2num((time((timet
*)0) - scm_your_base
) * (int)SCM_TIME_UNITS_PER_SECOND
);
133 #endif /* HAVE_FTIME */
139 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
141 "Return an object with information about real and processor\n"
142 "time. The following procedures accept such an object as an\n"
143 "argument and return a selected component:\n"
147 "The current real time, expressed as time units relative to an\n"
150 "The CPU time units used by the calling process.\n"
152 "The CPU time units used by the system on behalf of the calling\n"
155 "The CPU time units used by terminated child processes of the\n"
156 "calling process, whose status has been collected (e.g., using\n"
159 "Similarly, the CPU times units used by the system on behalf of\n"
160 "terminated child processes.\n"
162 #define FUNC_NAME s_scm_times
167 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
171 SCM_VECTOR_SET (result
, 0, scm_long2num (rv
));
172 SCM_VECTOR_SET (result
, 1, scm_long2num (t
.tms_utime
));
173 SCM_VECTOR_SET (result
, 2, scm_long2num (t
.tms_stime
));
174 SCM_VECTOR_SET (result
,3, scm_long2num (t
.tms_cutime
));
175 SCM_VECTOR_SET (result
, 4, scm_long2num (t
.tms_cstime
));
179 #endif /* HAVE_TIMES */
181 static long scm_my_base
= 0;
184 scm_c_get_internal_run_time ()
186 return mytime () - scm_my_base
;
189 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
191 "Return the number of time units of processor time used by the\n"
192 "interpreter. Both @emph{system} and @emph{user} time are\n"
193 "included but subprocesses are not.")
194 #define FUNC_NAME s_scm_get_internal_run_time
196 return scm_long2num (scm_c_get_internal_run_time ());
200 /* For reference, note that current-time and gettimeofday both should be
201 protected against setzone/restorezone changes in another thread, since on
202 DOS the system time is normally kept as local time, which means TZ
203 affects the return from current-time and gettimeofday. Not sure if DJGPP
204 etc actually has concurrent multi-threading, but it seems prudent not to
205 make assumptions about this. */
207 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
209 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
210 "excluding leap seconds.")
211 #define FUNC_NAME s_scm_current_time
216 if ((timv
= time (0)) == -1)
217 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
219 return scm_long2num((long) timv
);
223 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
225 "Return a pair containing the number of seconds and microseconds\n"
226 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
227 "whether true microsecond resolution is available depends on the\n"
229 #define FUNC_NAME s_scm_gettimeofday
231 #ifdef HAVE_GETTIMEOFDAY
235 if (gettimeofday (&time
, NULL
) == -1)
238 return scm_cons (scm_long2num ((long) time
.tv_sec
),
239 scm_long2num ((long) time
.tv_usec
));
245 return scm_cons (scm_long2num ((long) time
.time
),
246 SCM_I_MAKINUM (time
.millitm
* 1000));
251 if ((timv
= time (0)) == -1)
254 return scm_cons (scm_long2num (timv
), SCM_I_MAKINUM (0));
261 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
263 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
265 SCM_VECTOR_SET (result
,0, SCM_I_MAKINUM (bd_time
->tm_sec
));
266 SCM_VECTOR_SET (result
,1, SCM_I_MAKINUM (bd_time
->tm_min
));
267 SCM_VECTOR_SET (result
,2, SCM_I_MAKINUM (bd_time
->tm_hour
));
268 SCM_VECTOR_SET (result
,3, SCM_I_MAKINUM (bd_time
->tm_mday
));
269 SCM_VECTOR_SET (result
,4, SCM_I_MAKINUM (bd_time
->tm_mon
));
270 SCM_VECTOR_SET (result
,5, SCM_I_MAKINUM (bd_time
->tm_year
));
271 SCM_VECTOR_SET (result
,6, SCM_I_MAKINUM (bd_time
->tm_wday
));
272 SCM_VECTOR_SET (result
,7, SCM_I_MAKINUM (bd_time
->tm_yday
));
273 SCM_VECTOR_SET (result
,8, SCM_I_MAKINUM (bd_time
->tm_isdst
));
274 SCM_VECTOR_SET (result
,9, SCM_I_MAKINUM (zoff
));
275 SCM_VECTOR_SET (result
,10, zname
? scm_makfrom0str (zname
) : SCM_BOOL_F
);
279 static char tzvar
[3] = "TZ";
281 /* if zone is set, create a temporary environment with only a TZ
282 string. other threads or interrupt handlers shouldn't be allowed
283 to run until the corresponding restorezone is called. hence the use
284 of a static variable for tmpenv is no big deal. */
286 setzone (SCM zone
, int pos
, const char *subr
)
290 if (!SCM_UNBNDP (zone
))
292 static char *tmpenv
[2];
295 SCM_ASSERT (SCM_STRINGP (zone
), zone
, pos
, subr
);
296 buf
= scm_malloc (SCM_STRING_LENGTH (zone
) + sizeof (tzvar
) + 1);
297 sprintf (buf
, "%s=%s", tzvar
, SCM_STRING_CHARS (zone
));
307 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
309 if (!SCM_UNBNDP (zone
))
314 /* for the possible benefit of user code linked with libguile. */
320 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
321 (SCM time
, SCM zone
),
322 "Return an object representing the broken down components of\n"
323 "@var{time}, an integer like the one returned by\n"
324 "@code{current-time}. The time zone for the calculation is\n"
325 "optionally specified by @var{zone} (a string), otherwise the\n"
326 "@code{TZ} environment variable or the system default is used.")
327 #define FUNC_NAME s_scm_localtime
330 struct tm
*ltptr
, lt
, *utc
;
337 itime
= SCM_NUM2LONG (1, time
);
339 /* deferring interupts is essential since a) setzone may install a temporary
340 environment b) localtime uses a static buffer. */
342 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
343 #ifdef LOCALTIME_CACHE
346 /* POSIX says localtime sets errno, but C99 doesn't say that.
347 Give a sensible default value in case localtime doesn't set it. */
349 ltptr
= localtime (&itime
);
355 /* copy zone name before calling gmtime or restoring zone. */
356 #if defined (HAVE_TM_ZONE)
357 ptr
= ltptr
->tm_zone
;
358 #elif defined (HAVE_TZNAME)
359 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
363 zname
= scm_malloc (strlen (ptr
) + 1);
366 /* the struct is copied in case localtime and gmtime share a buffer. */
369 /* POSIX says gmtime sets errno, but C99 doesn't say that.
370 Give a sensible default value in case gmtime doesn't set it. */
372 utc
= gmtime (&itime
);
375 restorezone (zone
, oldenv
, FUNC_NAME
);
376 /* delayed until zone has been restored. */
378 if (utc
== NULL
|| ltptr
== NULL
)
381 /* calculate timezone offset in seconds west of UTC. */
382 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
383 + utc
->tm_sec
- lt
.tm_sec
;
384 if (utc
->tm_year
< lt
.tm_year
)
385 zoff
-= 24 * 60 * 60;
386 else if (utc
->tm_year
> lt
.tm_year
)
387 zoff
+= 24 * 60 * 60;
388 else if (utc
->tm_yday
< lt
.tm_yday
)
389 zoff
-= 24 * 60 * 60;
390 else if (utc
->tm_yday
> lt
.tm_yday
)
391 zoff
+= 24 * 60 * 60;
393 result
= filltime (<
, zoff
, zname
);
401 /* tm_zone is normally a pointer, not an array within struct tm, so we might
402 have to worry about the lifespan of what it points to. The posix specs
403 don't seem to say anything about this, let's assume here that tm_zone
404 will be a constant and therefore no protection or anything is needed
405 until we copy it in filltime(). */
407 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
409 "Return an object representing the broken down components of\n"
410 "@var{time}, an integer like the one returned by\n"
411 "@code{current-time}. The values are calculated for UTC.")
412 #define FUNC_NAME s_scm_gmtime
415 struct tm bd_buf
, *bd_time
;
418 itime
= SCM_NUM2LONG (1, time
);
420 /* POSIX says gmtime sets errno, but C99 doesn't say that.
421 Give a sensible default value in case gmtime doesn't set it. */
425 bd_time
= gmtime_r (&itime
, &bd_buf
);
428 bd_time
= gmtime (&itime
);
436 #if HAVE_STRUCT_TM_TM_ZONE
437 zname
= bd_buf
.tm_zone
;
441 return filltime (&bd_buf
, 0, zname
);
445 /* copy time components from a Scheme object to a struct tm. */
447 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
452 SCM_ASSERT (SCM_VECTORP (sbd_time
)
453 && SCM_VECTOR_LENGTH (sbd_time
) == 11,
454 sbd_time
, pos
, subr
);
455 velts
= SCM_VELTS (sbd_time
);
456 for (i
= 0; i
< 10; i
++)
458 SCM_ASSERT (SCM_INUMP (velts
[i
]), sbd_time
, pos
, subr
);
460 SCM_ASSERT (scm_is_false (velts
[10]) || SCM_STRINGP (velts
[10]),
461 sbd_time
, pos
, subr
);
463 lt
->tm_sec
= SCM_INUM (velts
[0]);
464 lt
->tm_min
= SCM_INUM (velts
[1]);
465 lt
->tm_hour
= SCM_INUM (velts
[2]);
466 lt
->tm_mday
= SCM_INUM (velts
[3]);
467 lt
->tm_mon
= SCM_INUM (velts
[4]);
468 lt
->tm_year
= SCM_INUM (velts
[5]);
469 lt
->tm_wday
= SCM_INUM (velts
[6]);
470 lt
->tm_yday
= SCM_INUM (velts
[7]);
471 lt
->tm_isdst
= SCM_INUM (velts
[8]);
473 lt
->tm_gmtoff
= SCM_INUM (velts
[9]);
474 if (scm_is_false (velts
[10]))
477 lt
->tm_zone
= SCM_STRING_CHARS (velts
[10]);
481 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
482 (SCM sbd_time
, SCM zone
),
483 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
484 "is an optional time zone specifier (otherwise the TZ environment variable\n"
485 "or the system default is used).\n\n"
486 "Returns a pair: the car is a corresponding\n"
487 "integer time value like that returned\n"
488 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
489 "as @var{bd-time} but with normalized values.")
490 #define FUNC_NAME s_scm_mktime
500 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
503 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
504 #ifdef LOCALTIME_CACHE
507 itime
= mktime (<
);
508 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
509 doesn't. Force a sensible value for our error message. */
516 /* copy zone name before calling gmtime or restoring the zone. */
517 #if defined (HAVE_TM_ZONE)
519 #elif defined (HAVE_TZNAME)
520 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
524 zname
= scm_malloc (strlen (ptr
) + 1);
528 /* get timezone offset in seconds west of UTC. */
529 /* POSIX says gmtime sets errno, but C99 doesn't say that.
530 Give a sensible default value in case gmtime doesn't set it. */
531 utc
= gmtime (&itime
);
535 restorezone (zone
, oldenv
, FUNC_NAME
);
536 /* delayed until zone has been restored. */
538 if (utc
== NULL
|| itime
== -1)
541 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
542 + utc
->tm_sec
- lt
.tm_sec
;
543 if (utc
->tm_year
< lt
.tm_year
)
544 zoff
-= 24 * 60 * 60;
545 else if (utc
->tm_year
> lt
.tm_year
)
546 zoff
+= 24 * 60 * 60;
547 else if (utc
->tm_yday
< lt
.tm_yday
)
548 zoff
-= 24 * 60 * 60;
549 else if (utc
->tm_yday
> lt
.tm_yday
)
550 zoff
+= 24 * 60 * 60;
552 result
= scm_cons (scm_long2num ((long) itime
),
553 filltime (<
, zoff
, zname
));
562 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
564 "Initialize the timezone from the TZ environment variable\n"
565 "or the system default. It's not usually necessary to call this procedure\n"
566 "since it's done automatically by other procedures that depend on the\n"
568 #define FUNC_NAME s_scm_tzset
571 return SCM_UNSPECIFIED
;
574 #endif /* HAVE_TZSET */
576 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
577 (SCM format
, SCM stime
),
578 "Formats a time specification @var{time} using @var{template}. @var{time}\n"
579 "is an object with time components in the form returned by @code{localtime}\n"
580 "or @code{gmtime}. @var{template} is a string which can include formatting\n"
581 "specifications introduced by a @code{%} character. The formatting of\n"
582 "month and day names is dependent on the current locale. The value returned\n"
583 "is the formatted string.\n"
584 "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
585 #define FUNC_NAME s_scm_strftime
595 SCM_VALIDATE_STRING (1, format
);
596 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
598 fmt
= SCM_STRING_CHARS (format
);
599 len
= SCM_STRING_LENGTH (format
);
601 /* Ugly hack: strftime can return 0 if its buffer is too small,
602 but some valid time strings (e.g. "%p") can sometimes produce
603 a zero-byte output string! Workaround is to prepend a junk
604 character to the format string, so that valid returns are always
606 myfmt
= scm_malloc (len
+2);
608 strncpy(myfmt
+1, fmt
, len
);
611 tbuf
= scm_malloc (size
);
613 #if !defined (HAVE_TM_ZONE)
614 /* it seems the only way to tell non-GNU versions of strftime what
615 zone to use (for the %Z format) is to set TZ in the
616 environment. interrupts and thread switching must be deferred
617 until TZ is restored. */
618 char **oldenv
= NULL
;
619 SCM
*velts
= (SCM
*) SCM_VELTS (stime
);
622 if (scm_is_true (velts
[10]) && *SCM_STRING_CHARS (velts
[10]) != 0)
624 /* it's not required that the TZ setting be correct, just that
625 it has the right name. so try something like TZ=EST0.
626 using only TZ=EST would be simpler but it doesn't work on
627 some OSs, e.g., Solaris. */
629 scm_string_append (scm_cons (velts
[10],
630 scm_cons (scm_makfrom0str ("0"),
635 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
639 #ifdef LOCALTIME_CACHE
643 /* POSIX says strftime returns 0 on buffer overrun, but old
644 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
646 while ((len
= strftime (tbuf
, size
, myfmt
, &t
)) == 0 || len
== size
)
650 tbuf
= scm_malloc (size
);
653 #if !defined (HAVE_TM_ZONE)
656 restorezone (velts
[10], oldenv
, FUNC_NAME
);
662 result
= scm_mem2string (tbuf
+ 1, len
- 1);
670 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
671 (SCM format
, SCM string
),
672 "Performs the reverse action to @code{strftime}, parsing\n"
673 "@var{string} according to the specification supplied in\n"
674 "@var{template}. The interpretation of month and day names is\n"
675 "dependent on the current locale. The value returned is a pair.\n"
676 "The car has an object with time components\n"
677 "in the form returned by @code{localtime} or @code{gmtime},\n"
678 "but the time zone components\n"
679 "are not usefully set.\n"
680 "The cdr reports the number of characters from @var{string}\n"
681 "which were used for the conversion.")
682 #define FUNC_NAME s_scm_strptime
685 char *fmt
, *str
, *rest
;
687 SCM_VALIDATE_STRING (1, format
);
688 SCM_VALIDATE_STRING (2, string
);
690 fmt
= SCM_STRING_CHARS (format
);
691 str
= SCM_STRING_CHARS (string
);
693 /* initialize the struct tm */
694 #define tm_init(field) t.field = 0
705 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
706 reads a UTC time_t value and converts with localtime_r() to set the tm
707 fields, hence the use of SCM_DEFER_INTS. */
710 if ((rest
= strptime (str
, fmt
, &t
)) == NULL
)
712 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
713 instance it doesn't. Force a sensible value for our error
720 return scm_cons (filltime (&t
, 0, NULL
), SCM_I_MAKINUM (rest
- str
));
723 #endif /* HAVE_STRPTIME */
728 scm_c_define ("internal-time-units-per-second",
729 scm_long2num((long) SCM_TIME_UNITS_PER_SECOND
));
732 if (!scm_your_base
.time
) ftime(&scm_your_base
);
734 if (!scm_your_base
) time(&scm_your_base
);
737 if (!scm_my_base
) scm_my_base
= mytime();
739 scm_add_feature ("current-time");
740 #include "libguile/stime.x"