1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005 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 /* _POSIX_C_SOURCE is not defined always, because it causes problems on some
24 - FreeBSD loses all BSD and XOPEN defines.
25 - glibc loses some things like CLK_TCK.
26 - On MINGW it conflicts with the pthread headers.
28 But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r.
30 Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and
31 what it takes away, and decide from that whether to use it, instead of
32 hard coding __hpux. */
34 #define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
36 #define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
46 #include "libguile/_scm.h"
47 #include "libguile/async.h"
48 #include "libguile/feature.h"
49 #include "libguile/strings.h"
50 #include "libguile/vectors.h"
51 #include "libguile/dynwind.h"
53 #include "libguile/validate.h"
54 #include "libguile/stime.h"
61 # ifdef HAVE_SYS_TYPES_H
62 # include <sys/types.h>
69 #ifdef HAVE_SYS_TIMES_H
70 # include <sys/times.h>
73 #ifdef HAVE_SYS_TIMEB_H
74 # include <sys/timeb.h>
77 #if HAVE_CRT_EXTERNS_H
78 #include <crt_externs.h> /* for Darwin _NSGetEnviron */
81 #ifndef tzname /* For SGI. */
82 extern char *tzname
[]; /* RS6000 and others reject char **tzname. */
84 #if defined (__MINGW32__)
85 # define tzname _tzname
88 #if ! HAVE_DECL_STRPTIME
89 extern char *strptime ();
98 extern char ** environ
;
100 /* On Apple Darwin in a shared library there's no "environ" to access
101 directly, instead the address of that variable must be obtained with
103 #if HAVE__NSGETENVIRON && defined (PIC)
104 #define environ (*_NSGetEnviron())
112 struct tms time_buffer
;
114 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
118 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
120 # define mytime clock
125 struct timeb scm_your_base
= {0};
127 timet scm_your_base
= 0;
130 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
132 "Return the number of time units since the interpreter was\n"
134 #define FUNC_NAME s_scm_get_internal_real_time
137 struct timeb time_buffer
;
140 ftime (&time_buffer
);
141 time_buffer
.time
-= scm_your_base
.time
;
142 tmp
= scm_from_long (time_buffer
.millitm
- scm_your_base
.millitm
);
144 scm_product (scm_from_int (1000),
145 scm_from_int (time_buffer
.time
)));
146 return scm_quotient (scm_product (tmp
,
147 scm_from_int (SCM_TIME_UNITS_PER_SECOND
)),
148 scm_from_int (1000));
150 return scm_from_long ((time((timet
*)0) - scm_your_base
)
151 * (int)SCM_TIME_UNITS_PER_SECOND
);
152 #endif /* HAVE_FTIME */
158 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
160 "Return an object with information about real and processor\n"
161 "time. The following procedures accept such an object as an\n"
162 "argument and return a selected component:\n"
166 "The current real time, expressed as time units relative to an\n"
169 "The CPU time units used by the calling process.\n"
171 "The CPU time units used by the system on behalf of the calling\n"
174 "The CPU time units used by terminated child processes of the\n"
175 "calling process, whose status has been collected (e.g., using\n"
178 "Similarly, the CPU times units used by the system on behalf of\n"
179 "terminated child processes.\n"
181 #define FUNC_NAME s_scm_times
186 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
190 SCM_SIMPLE_VECTOR_SET (result
, 0, scm_from_long (rv
));
191 SCM_SIMPLE_VECTOR_SET (result
, 1, scm_from_long (t
.tms_utime
));
192 SCM_SIMPLE_VECTOR_SET (result
, 2, scm_from_long (t
.tms_stime
));
193 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_long (t
.tms_cutime
));
194 SCM_SIMPLE_VECTOR_SET (result
, 4, scm_from_long (t
.tms_cstime
));
198 #endif /* HAVE_TIMES */
200 static long scm_my_base
= 0;
203 scm_c_get_internal_run_time ()
205 return mytime () - scm_my_base
;
208 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
210 "Return the number of time units of processor time used by the\n"
211 "interpreter. Both @emph{system} and @emph{user} time are\n"
212 "included but subprocesses are not.")
213 #define FUNC_NAME s_scm_get_internal_run_time
215 return scm_from_long (scm_c_get_internal_run_time ());
219 /* For reference, note that current-time and gettimeofday both should be
220 protected against setzone/restorezone changes in another thread, since on
221 DOS the system time is normally kept as local time, which means TZ
222 affects the return from current-time and gettimeofday. Not sure if DJGPP
223 etc actually has concurrent multi-threading, but it seems prudent not to
224 make assumptions about this. */
226 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
228 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
229 "excluding leap seconds.")
230 #define FUNC_NAME s_scm_current_time
234 SCM_CRITICAL_SECTION_START
;
236 SCM_CRITICAL_SECTION_END
;
238 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
239 return scm_from_long (timv
);
243 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
245 "Return a pair containing the number of seconds and microseconds\n"
246 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
247 "whether true microsecond resolution is available depends on the\n"
249 #define FUNC_NAME s_scm_gettimeofday
251 #ifdef HAVE_GETTIMEOFDAY
255 SCM_CRITICAL_SECTION_START
;
256 ret
= gettimeofday (&time
, NULL
);
258 SCM_CRITICAL_SECTION_END
;
264 return scm_cons (scm_from_long (time
.tv_sec
),
265 scm_from_long (time
.tv_usec
));
271 return scm_cons (scm_from_long (time
.time
),
272 scm_from_int (time
.millitm
* 1000));
277 SCM_CRITICAL_SECTION_START
;
280 SCM_CRITICAL_SECTION_END
;
286 return scm_cons (scm_from_long (timv
), scm_from_int (0));
293 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
295 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
297 SCM_SIMPLE_VECTOR_SET (result
,0, scm_from_int (bd_time
->tm_sec
));
298 SCM_SIMPLE_VECTOR_SET (result
,1, scm_from_int (bd_time
->tm_min
));
299 SCM_SIMPLE_VECTOR_SET (result
,2, scm_from_int (bd_time
->tm_hour
));
300 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_int (bd_time
->tm_mday
));
301 SCM_SIMPLE_VECTOR_SET (result
,4, scm_from_int (bd_time
->tm_mon
));
302 SCM_SIMPLE_VECTOR_SET (result
,5, scm_from_int (bd_time
->tm_year
));
303 SCM_SIMPLE_VECTOR_SET (result
,6, scm_from_int (bd_time
->tm_wday
));
304 SCM_SIMPLE_VECTOR_SET (result
,7, scm_from_int (bd_time
->tm_yday
));
305 SCM_SIMPLE_VECTOR_SET (result
,8, scm_from_int (bd_time
->tm_isdst
));
306 SCM_SIMPLE_VECTOR_SET (result
,9, scm_from_int (zoff
));
307 SCM_SIMPLE_VECTOR_SET (result
,10, (zname
308 ? scm_from_locale_string (zname
)
313 static char tzvar
[3] = "TZ";
315 /* if zone is set, create a temporary environment with only a TZ
316 string. other threads or interrupt handlers shouldn't be allowed
317 to run until the corresponding restorezone is called. hence the use
318 of a static variable for tmpenv is no big deal. */
320 setzone (SCM zone
, int pos
, const char *subr
)
324 if (!SCM_UNBNDP (zone
))
326 static char *tmpenv
[2];
330 zone_len
= scm_to_locale_stringbuf (zone
, NULL
, 0);
331 buf
= scm_malloc (zone_len
+ sizeof (tzvar
) + 1);
333 buf
[sizeof(tzvar
)-1] = '=';
334 scm_to_locale_stringbuf (zone
, buf
+sizeof(tzvar
), zone_len
);
335 buf
[sizeof(tzvar
)+zone_len
] = '\0';
345 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
347 if (!SCM_UNBNDP (zone
))
352 /* for the possible benefit of user code linked with libguile. */
358 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
359 (SCM time
, SCM zone
),
360 "Return an object representing the broken down components of\n"
361 "@var{time}, an integer like the one returned by\n"
362 "@code{current-time}. The time zone for the calculation is\n"
363 "optionally specified by @var{zone} (a string), otherwise the\n"
364 "@code{TZ} environment variable or the system default is used.")
365 #define FUNC_NAME s_scm_localtime
368 struct tm
*ltptr
, lt
, *utc
;
375 itime
= SCM_NUM2LONG (1, time
);
377 /* deferring interupts is essential since a) setzone may install a temporary
378 environment b) localtime uses a static buffer. */
379 SCM_CRITICAL_SECTION_START
;
380 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
381 #ifdef LOCALTIME_CACHE
384 /* POSIX says localtime sets errno, but C99 doesn't say that.
385 Give a sensible default value in case localtime doesn't set it. */
387 ltptr
= localtime (&itime
);
393 /* copy zone name before calling gmtime or restoring zone. */
394 #if defined (HAVE_TM_ZONE)
395 ptr
= ltptr
->tm_zone
;
396 #elif defined (HAVE_TZNAME)
397 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
401 zname
= scm_malloc (strlen (ptr
) + 1);
404 /* the struct is copied in case localtime and gmtime share a buffer. */
407 /* POSIX says gmtime sets errno, but C99 doesn't say that.
408 Give a sensible default value in case gmtime doesn't set it. */
410 utc
= gmtime (&itime
);
413 restorezone (zone
, oldenv
, FUNC_NAME
);
414 /* delayed until zone has been restored. */
416 if (utc
== NULL
|| ltptr
== NULL
)
419 /* calculate timezone offset in seconds west of UTC. */
420 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
421 + utc
->tm_sec
- lt
.tm_sec
;
422 if (utc
->tm_year
< lt
.tm_year
)
423 zoff
-= 24 * 60 * 60;
424 else if (utc
->tm_year
> lt
.tm_year
)
425 zoff
+= 24 * 60 * 60;
426 else if (utc
->tm_yday
< lt
.tm_yday
)
427 zoff
-= 24 * 60 * 60;
428 else if (utc
->tm_yday
> lt
.tm_yday
)
429 zoff
+= 24 * 60 * 60;
431 result
= filltime (<
, zoff
, zname
);
432 SCM_CRITICAL_SECTION_END
;
439 /* tm_zone is normally a pointer, not an array within struct tm, so we might
440 have to worry about the lifespan of what it points to. The posix specs
441 don't seem to say anything about this, let's assume here that tm_zone
442 will be a constant and therefore no protection or anything is needed
443 until we copy it in filltime(). */
445 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
447 "Return an object representing the broken down components of\n"
448 "@var{time}, an integer like the one returned by\n"
449 "@code{current-time}. The values are calculated for UTC.")
450 #define FUNC_NAME s_scm_gmtime
453 struct tm bd_buf
, *bd_time
;
456 itime
= SCM_NUM2LONG (1, time
);
458 /* POSIX says gmtime sets errno, but C99 doesn't say that.
459 Give a sensible default value in case gmtime doesn't set it. */
463 bd_time
= gmtime_r (&itime
, &bd_buf
);
465 SCM_CRITICAL_SECTION_START
;
466 bd_time
= gmtime (&itime
);
469 SCM_CRITICAL_SECTION_END
;
474 #if HAVE_STRUCT_TM_TM_ZONE
475 zname
= bd_buf
.tm_zone
;
479 return filltime (&bd_buf
, 0, zname
);
483 /* copy time components from a Scheme object to a struct tm. */
485 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
487 SCM_ASSERT (scm_is_simple_vector (sbd_time
)
488 && SCM_SIMPLE_VECTOR_LENGTH (sbd_time
) == 11,
489 sbd_time
, pos
, subr
);
491 lt
->tm_sec
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 0));
492 lt
->tm_min
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 1));
493 lt
->tm_hour
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 2));
494 lt
->tm_mday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 3));
495 lt
->tm_mon
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 4));
496 lt
->tm_year
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 5));
497 lt
->tm_wday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 6));
498 lt
->tm_yday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 7));
499 lt
->tm_isdst
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 8));
501 lt
->tm_gmtoff
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 9));
502 if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10)))
505 lt
->tm_zone
= scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10));
509 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
510 (SCM sbd_time
, SCM zone
),
511 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
512 "is an optional time zone specifier (otherwise the TZ environment variable\n"
513 "or the system default is used).\n\n"
514 "Returns a pair: the car is a corresponding\n"
515 "integer time value like that returned\n"
516 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
517 "as @var{bd-time} but with normalized values.")
518 #define FUNC_NAME s_scm_mktime
530 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
531 #if HAVE_STRUCT_TM_TM_ZONE
532 scm_frame_free ((char *)lt
.tm_zone
);
535 SCM_CRITICAL_SECTION_START
;
536 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
537 #ifdef LOCALTIME_CACHE
540 itime
= mktime (<
);
541 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
542 doesn't. Force a sensible value for our error message. */
549 /* copy zone name before calling gmtime or restoring the zone. */
550 #if defined (HAVE_TM_ZONE)
552 #elif defined (HAVE_TZNAME)
553 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
557 zname
= scm_malloc (strlen (ptr
) + 1);
561 /* get timezone offset in seconds west of UTC. */
562 /* POSIX says gmtime sets errno, but C99 doesn't say that.
563 Give a sensible default value in case gmtime doesn't set it. */
565 utc
= gmtime (&itime
);
569 restorezone (zone
, oldenv
, FUNC_NAME
);
570 /* delayed until zone has been restored. */
572 if (utc
== NULL
|| itime
== -1)
575 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
576 + utc
->tm_sec
- lt
.tm_sec
;
577 if (utc
->tm_year
< lt
.tm_year
)
578 zoff
-= 24 * 60 * 60;
579 else if (utc
->tm_year
> lt
.tm_year
)
580 zoff
+= 24 * 60 * 60;
581 else if (utc
->tm_yday
< lt
.tm_yday
)
582 zoff
-= 24 * 60 * 60;
583 else if (utc
->tm_yday
> lt
.tm_yday
)
584 zoff
+= 24 * 60 * 60;
586 result
= scm_cons (scm_from_long (itime
),
587 filltime (<
, zoff
, zname
));
588 SCM_CRITICAL_SECTION_END
;
598 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
600 "Initialize the timezone from the TZ environment variable\n"
601 "or the system default. It's not usually necessary to call this procedure\n"
602 "since it's done automatically by other procedures that depend on the\n"
604 #define FUNC_NAME s_scm_tzset
607 return SCM_UNSPECIFIED
;
610 #endif /* HAVE_TZSET */
612 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
613 (SCM format
, SCM stime
),
614 "Formats a time specification @var{time} using @var{template}. @var{time}\n"
615 "is an object with time components in the form returned by @code{localtime}\n"
616 "or @code{gmtime}. @var{template} is a string which can include formatting\n"
617 "specifications introduced by a @code{%} character. The formatting of\n"
618 "month and day names is dependent on the current locale. The value returned\n"
619 "is the formatted string.\n"
620 "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
621 #define FUNC_NAME s_scm_strftime
632 SCM_VALIDATE_STRING (1, format
);
633 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
635 fmt
= scm_i_string_chars (format
);
636 len
= scm_i_string_length (format
);
638 /* Ugly hack: strftime can return 0 if its buffer is too small,
639 but some valid time strings (e.g. "%p") can sometimes produce
640 a zero-byte output string! Workaround is to prepend a junk
641 character to the format string, so that valid returns are always
643 myfmt
= scm_malloc (len
+2);
645 strncpy(myfmt
+1, fmt
, len
);
648 tbuf
= scm_malloc (size
);
650 #if !defined (HAVE_TM_ZONE)
651 /* it seems the only way to tell non-GNU versions of strftime what
652 zone to use (for the %Z format) is to set TZ in the
653 environment. interrupts and thread switching must be deferred
654 until TZ is restored. */
655 char **oldenv
= NULL
;
656 SCM
*velts
= (SCM
*) SCM_VELTS (stime
);
659 if (scm_is_true (velts
[10]) && *SCM_STRING_CHARS (velts
[10]) != 0)
661 /* it's not required that the TZ setting be correct, just that
662 it has the right name. so try something like TZ=EST0.
663 using only TZ=EST would be simpler but it doesn't work on
664 some OSs, e.g., Solaris. */
666 scm_string_append (scm_cons (velts
[10],
667 scm_cons (scm_from_locale_string ("0"),
671 SCM_CRITICAL_SECTION_START
;
672 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
676 #ifdef LOCALTIME_CACHE
680 /* POSIX says strftime returns 0 on buffer overrun, but old
681 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
683 while ((len
= strftime (tbuf
, size
, myfmt
, &t
)) == 0 || len
== size
)
687 tbuf
= scm_malloc (size
);
690 #if !defined (HAVE_TM_ZONE)
693 restorezone (velts
[10], oldenv
, FUNC_NAME
);
694 SCM_CRITICAL_SECTION_END
;
699 result
= scm_from_locale_stringn (tbuf
+ 1, len
- 1);
702 #if HAVE_STRUCT_TM_TM_ZONE
703 free ((char *) t
.tm_zone
);
710 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
711 (SCM format
, SCM string
),
712 "Performs the reverse action to @code{strftime}, parsing\n"
713 "@var{string} according to the specification supplied in\n"
714 "@var{template}. The interpretation of month and day names is\n"
715 "dependent on the current locale. The value returned is a pair.\n"
716 "The car has an object with time components\n"
717 "in the form returned by @code{localtime} or @code{gmtime},\n"
718 "but the time zone components\n"
719 "are not usefully set.\n"
720 "The cdr reports the number of characters from @var{string}\n"
721 "which were used for the conversion.")
722 #define FUNC_NAME s_scm_strptime
725 const char *fmt
, *str
, *rest
;
727 SCM_VALIDATE_STRING (1, format
);
728 SCM_VALIDATE_STRING (2, string
);
730 fmt
= scm_i_string_chars (format
);
731 str
= scm_i_string_chars (string
);
733 /* initialize the struct tm */
734 #define tm_init(field) t.field = 0
745 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
746 reads a UTC time_t value and converts with localtime_r() to set the tm
747 fields, hence the use of SCM_CRITICAL_SECTION_START. */
749 SCM_CRITICAL_SECTION_START
;
750 rest
= strptime (str
, fmt
, &t
);
751 SCM_CRITICAL_SECTION_END
;
754 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
755 instance it doesn't. Force a sensible value for our error
761 return scm_cons (filltime (&t
, 0, NULL
),
762 scm_from_signed_integer (rest
- str
));
765 #endif /* HAVE_STRPTIME */
770 scm_c_define ("internal-time-units-per-second",
771 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
774 if (!scm_your_base
.time
) ftime(&scm_your_base
);
776 if (!scm_your_base
) time(&scm_your_base
);
779 if (!scm_my_base
) scm_my_base
= mytime();
781 scm_add_feature ("current-time");
782 #include "libguile/stime.x"