1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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. */
35 # define _REENTRANT /* ask solaris for gmtime_r prototype */
38 #define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
49 #include "libguile/_scm.h"
50 #include "libguile/async.h"
51 #include "libguile/feature.h"
52 #include "libguile/strings.h"
53 #include "libguile/vectors.h"
54 #include "libguile/dynwind.h"
56 #include "libguile/validate.h"
57 #include "libguile/stime.h"
64 # ifdef HAVE_SYS_TYPES_H
65 # include <sys/types.h>
72 #ifdef HAVE_SYS_TIMES_H
73 # include <sys/times.h>
76 #ifdef HAVE_SYS_TIMEB_H
77 # include <sys/timeb.h>
80 #ifndef tzname /* For SGI. */
81 extern char *tzname
[]; /* RS6000 and others reject char **tzname. */
83 #if defined (__MINGW32__)
84 # define tzname _tzname
87 #if ! HAVE_DECL_STRPTIME
88 extern char *strptime ();
102 struct tms time_buffer
;
104 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
108 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
110 # define mytime clock
115 struct timeb scm_your_base
= {0};
117 timet scm_your_base
= 0;
120 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
122 "Return the number of time units since the interpreter was\n"
124 #define FUNC_NAME s_scm_get_internal_real_time
127 struct timeb time_buffer
;
130 ftime (&time_buffer
);
131 time_buffer
.time
-= scm_your_base
.time
;
132 tmp
= scm_from_long (time_buffer
.millitm
- scm_your_base
.millitm
);
134 scm_product (scm_from_int (1000),
135 scm_from_int (time_buffer
.time
)));
136 return scm_quotient (scm_product (tmp
,
137 scm_from_int (SCM_TIME_UNITS_PER_SECOND
)),
138 scm_from_int (1000));
140 return scm_from_long ((time((timet
*)0) - scm_your_base
)
141 * (int)SCM_TIME_UNITS_PER_SECOND
);
142 #endif /* HAVE_FTIME */
148 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
150 "Return an object with information about real and processor\n"
151 "time. The following procedures accept such an object as an\n"
152 "argument and return a selected component:\n"
156 "The current real time, expressed as time units relative to an\n"
159 "The CPU time units used by the calling process.\n"
161 "The CPU time units used by the system on behalf of the calling\n"
164 "The CPU time units used by terminated child processes of the\n"
165 "calling process, whose status has been collected (e.g., using\n"
168 "Similarly, the CPU times units used by the system on behalf of\n"
169 "terminated child processes.\n"
171 #define FUNC_NAME s_scm_times
176 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
180 SCM_SIMPLE_VECTOR_SET (result
, 0, scm_from_long (rv
));
181 SCM_SIMPLE_VECTOR_SET (result
, 1, scm_from_long (t
.tms_utime
));
182 SCM_SIMPLE_VECTOR_SET (result
, 2, scm_from_long (t
.tms_stime
));
183 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_long (t
.tms_cutime
));
184 SCM_SIMPLE_VECTOR_SET (result
, 4, scm_from_long (t
.tms_cstime
));
188 #endif /* HAVE_TIMES */
190 static long scm_my_base
= 0;
193 scm_c_get_internal_run_time ()
195 return mytime () - scm_my_base
;
198 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
200 "Return the number of time units of processor time used by the\n"
201 "interpreter. Both @emph{system} and @emph{user} time are\n"
202 "included but subprocesses are not.")
203 #define FUNC_NAME s_scm_get_internal_run_time
205 return scm_from_long (scm_c_get_internal_run_time ());
209 /* For reference, note that current-time and gettimeofday both should be
210 protected against setzone/restorezone changes in another thread, since on
211 DOS the system time is normally kept as local time, which means TZ
212 affects the return from current-time and gettimeofday. Not sure if DJGPP
213 etc actually has concurrent multi-threading, but it seems prudent not to
214 make assumptions about this. */
216 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
218 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
219 "excluding leap seconds.")
220 #define FUNC_NAME s_scm_current_time
224 SCM_CRITICAL_SECTION_START
;
226 SCM_CRITICAL_SECTION_END
;
228 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
229 return scm_from_long (timv
);
233 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
235 "Return a pair containing the number of seconds and microseconds\n"
236 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
237 "whether true microsecond resolution is available depends on the\n"
239 #define FUNC_NAME s_scm_gettimeofday
241 #ifdef HAVE_GETTIMEOFDAY
245 SCM_CRITICAL_SECTION_START
;
246 ret
= gettimeofday (&time
, NULL
);
248 SCM_CRITICAL_SECTION_END
;
254 return scm_cons (scm_from_long (time
.tv_sec
),
255 scm_from_long (time
.tv_usec
));
261 return scm_cons (scm_from_long (time
.time
),
262 scm_from_int (time
.millitm
* 1000));
267 SCM_CRITICAL_SECTION_START
;
270 SCM_CRITICAL_SECTION_END
;
276 return scm_cons (scm_from_long (timv
), scm_from_int (0));
283 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
285 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
287 SCM_SIMPLE_VECTOR_SET (result
,0, scm_from_int (bd_time
->tm_sec
));
288 SCM_SIMPLE_VECTOR_SET (result
,1, scm_from_int (bd_time
->tm_min
));
289 SCM_SIMPLE_VECTOR_SET (result
,2, scm_from_int (bd_time
->tm_hour
));
290 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_int (bd_time
->tm_mday
));
291 SCM_SIMPLE_VECTOR_SET (result
,4, scm_from_int (bd_time
->tm_mon
));
292 SCM_SIMPLE_VECTOR_SET (result
,5, scm_from_int (bd_time
->tm_year
));
293 SCM_SIMPLE_VECTOR_SET (result
,6, scm_from_int (bd_time
->tm_wday
));
294 SCM_SIMPLE_VECTOR_SET (result
,7, scm_from_int (bd_time
->tm_yday
));
295 SCM_SIMPLE_VECTOR_SET (result
,8, scm_from_int (bd_time
->tm_isdst
));
296 SCM_SIMPLE_VECTOR_SET (result
,9, scm_from_int (zoff
));
297 SCM_SIMPLE_VECTOR_SET (result
,10, (zname
298 ? scm_from_locale_string (zname
)
303 static char tzvar
[3] = "TZ";
305 /* if zone is set, create a temporary environment with only a TZ
306 string. other threads or interrupt handlers shouldn't be allowed
307 to run until the corresponding restorezone is called. hence the use
308 of a static variable for tmpenv is no big deal. */
310 setzone (SCM zone
, int pos
, const char *subr
)
314 if (!SCM_UNBNDP (zone
))
316 static char *tmpenv
[2];
320 zone_len
= scm_to_locale_stringbuf (zone
, NULL
, 0);
321 buf
= scm_malloc (zone_len
+ sizeof (tzvar
) + 1);
323 buf
[sizeof(tzvar
)-1] = '=';
324 scm_to_locale_stringbuf (zone
, buf
+sizeof(tzvar
), zone_len
);
325 buf
[sizeof(tzvar
)+zone_len
] = '\0';
335 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
337 if (!SCM_UNBNDP (zone
))
342 /* for the possible benefit of user code linked with libguile. */
348 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
349 (SCM time
, SCM zone
),
350 "Return an object representing the broken down components of\n"
351 "@var{time}, an integer like the one returned by\n"
352 "@code{current-time}. The time zone for the calculation is\n"
353 "optionally specified by @var{zone} (a string), otherwise the\n"
354 "@code{TZ} environment variable or the system default is used.")
355 #define FUNC_NAME s_scm_localtime
358 struct tm
*ltptr
, lt
, *utc
;
365 itime
= SCM_NUM2LONG (1, time
);
367 /* deferring interupts is essential since a) setzone may install a temporary
368 environment b) localtime uses a static buffer. */
369 SCM_CRITICAL_SECTION_START
;
370 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
371 #ifdef LOCALTIME_CACHE
374 /* POSIX says localtime sets errno, but C99 doesn't say that.
375 Give a sensible default value in case localtime doesn't set it. */
377 ltptr
= localtime (&itime
);
383 /* copy zone name before calling gmtime or restoring zone. */
384 #if defined (HAVE_TM_ZONE)
385 ptr
= ltptr
->tm_zone
;
386 #elif defined (HAVE_TZNAME)
387 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
391 zname
= scm_malloc (strlen (ptr
) + 1);
394 /* the struct is copied in case localtime and gmtime share a buffer. */
397 /* POSIX says gmtime sets errno, but C99 doesn't say that.
398 Give a sensible default value in case gmtime doesn't set it. */
400 utc
= gmtime (&itime
);
403 restorezone (zone
, oldenv
, FUNC_NAME
);
404 /* delayed until zone has been restored. */
406 if (utc
== NULL
|| ltptr
== NULL
)
409 /* calculate timezone offset in seconds west of UTC. */
410 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
411 + utc
->tm_sec
- lt
.tm_sec
;
412 if (utc
->tm_year
< lt
.tm_year
)
413 zoff
-= 24 * 60 * 60;
414 else if (utc
->tm_year
> lt
.tm_year
)
415 zoff
+= 24 * 60 * 60;
416 else if (utc
->tm_yday
< lt
.tm_yday
)
417 zoff
-= 24 * 60 * 60;
418 else if (utc
->tm_yday
> lt
.tm_yday
)
419 zoff
+= 24 * 60 * 60;
421 result
= filltime (<
, zoff
, zname
);
422 SCM_CRITICAL_SECTION_END
;
429 /* tm_zone is normally a pointer, not an array within struct tm, so we might
430 have to worry about the lifespan of what it points to. The posix specs
431 don't seem to say anything about this, let's assume here that tm_zone
432 will be a constant and therefore no protection or anything is needed
433 until we copy it in filltime(). */
435 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
437 "Return an object representing the broken down components of\n"
438 "@var{time}, an integer like the one returned by\n"
439 "@code{current-time}. The values are calculated for UTC.")
440 #define FUNC_NAME s_scm_gmtime
443 struct tm bd_buf
, *bd_time
;
446 itime
= SCM_NUM2LONG (1, time
);
448 /* POSIX says gmtime sets errno, but C99 doesn't say that.
449 Give a sensible default value in case gmtime doesn't set it. */
453 bd_time
= gmtime_r (&itime
, &bd_buf
);
455 SCM_CRITICAL_SECTION_START
;
456 bd_time
= gmtime (&itime
);
459 SCM_CRITICAL_SECTION_END
;
464 #if HAVE_STRUCT_TM_TM_ZONE
465 zname
= bd_buf
.tm_zone
;
469 return filltime (&bd_buf
, 0, zname
);
473 /* copy time components from a Scheme object to a struct tm. */
475 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
477 SCM_ASSERT (scm_is_simple_vector (sbd_time
)
478 && SCM_SIMPLE_VECTOR_LENGTH (sbd_time
) == 11,
479 sbd_time
, pos
, subr
);
481 lt
->tm_sec
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 0));
482 lt
->tm_min
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 1));
483 lt
->tm_hour
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 2));
484 lt
->tm_mday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 3));
485 lt
->tm_mon
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 4));
486 lt
->tm_year
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 5));
487 lt
->tm_wday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 6));
488 lt
->tm_yday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 7));
489 lt
->tm_isdst
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 8));
490 #if HAVE_STRUCT_TM_TM_GMTOFF
491 lt
->tm_gmtoff
= - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 9));
494 if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10)))
497 lt
->tm_zone
= scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10));
501 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
502 (SCM sbd_time
, SCM zone
),
503 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
504 "is an optional time zone specifier (otherwise the TZ environment variable\n"
505 "or the system default is used).\n\n"
506 "Returns a pair: the car is a corresponding\n"
507 "integer time value like that returned\n"
508 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
509 "as @var{bd-time} but with normalized values.")
510 #define FUNC_NAME s_scm_mktime
520 scm_dynwind_begin (0);
522 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
523 #if HAVE_STRUCT_TM_TM_ZONE
524 scm_dynwind_free ((char *)lt
.tm_zone
);
527 scm_dynwind_critical_section (SCM_BOOL_F
);
529 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
530 #ifdef LOCALTIME_CACHE
533 itime
= mktime (<
);
534 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
535 doesn't. Force a sensible value for our error message. */
542 /* copy zone name before calling gmtime or restoring the zone. */
543 #if defined (HAVE_TM_ZONE)
545 #elif defined (HAVE_TZNAME)
546 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
550 zname
= scm_malloc (strlen (ptr
) + 1);
554 /* get timezone offset in seconds west of UTC. */
555 /* POSIX says gmtime sets errno, but C99 doesn't say that.
556 Give a sensible default value in case gmtime doesn't set it. */
558 utc
= gmtime (&itime
);
562 restorezone (zone
, oldenv
, FUNC_NAME
);
563 /* delayed until zone has been restored. */
565 if (utc
== NULL
|| itime
== -1)
568 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
569 + utc
->tm_sec
- lt
.tm_sec
;
570 if (utc
->tm_year
< lt
.tm_year
)
571 zoff
-= 24 * 60 * 60;
572 else if (utc
->tm_year
> lt
.tm_year
)
573 zoff
+= 24 * 60 * 60;
574 else if (utc
->tm_yday
< lt
.tm_yday
)
575 zoff
-= 24 * 60 * 60;
576 else if (utc
->tm_yday
> lt
.tm_yday
)
577 zoff
+= 24 * 60 * 60;
579 result
= scm_cons (scm_from_long (itime
),
580 filltime (<
, zoff
, zname
));
590 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
592 "Initialize the timezone from the TZ environment variable\n"
593 "or the system default. It's not usually necessary to call this procedure\n"
594 "since it's done automatically by other procedures that depend on the\n"
596 #define FUNC_NAME s_scm_tzset
599 return SCM_UNSPECIFIED
;
602 #endif /* HAVE_TZSET */
604 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
605 (SCM format
, SCM stime
),
606 "Return a string which is broken-down time structure @var{stime}\n"
607 "formatted according to the given @var{format} string.\n"
609 "@var{format} contains field specifications introduced by a\n"
610 "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n"
611 "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
612 "for the available formatting.\n"
615 "(strftime \"%c\" (localtime (current-time)))\n"
616 "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
619 "If @code{setlocale} has been called (@pxref{Locales}), month\n"
620 "and day names are from the current locale and in the locale\n"
622 #define FUNC_NAME s_scm_strftime
633 SCM_VALIDATE_STRING (1, format
);
634 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
636 fmt
= scm_i_string_chars (format
);
637 len
= scm_i_string_length (format
);
639 /* Ugly hack: strftime can return 0 if its buffer is too small,
640 but some valid time strings (e.g. "%p") can sometimes produce
641 a zero-byte output string! Workaround is to prepend a junk
642 character to the format string, so that valid returns are always
644 myfmt
= scm_malloc (len
+2);
646 strncpy(myfmt
+1, fmt
, len
);
649 tbuf
= scm_malloc (size
);
651 #if !defined (HAVE_TM_ZONE)
652 /* it seems the only way to tell non-GNU versions of strftime what
653 zone to use (for the %Z format) is to set TZ in the
654 environment. interrupts and thread switching must be deferred
655 until TZ is restored. */
656 char **oldenv
= NULL
;
657 SCM zone_spec
= SCM_SIMPLE_VECTOR_REF (stime
, 10);
660 if (scm_is_true (zone_spec
) && scm_c_string_length (zone_spec
) > 0)
662 /* it's not required that the TZ setting be correct, just that
663 it has the right name. so try something like TZ=EST0.
664 using only TZ=EST would be simpler but it doesn't work on
665 some OSs, e.g., Solaris. */
667 scm_string_append (scm_list_2 (zone_spec
,
668 scm_from_locale_string ("0")));
671 SCM_CRITICAL_SECTION_START
;
672 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
676 #ifdef LOCALTIME_CACHE
680 /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions
681 supported by glibc. */
682 while ((len
= nstrftime (tbuf
, size
, myfmt
, &t
, 0, 0)) == 0)
686 tbuf
= scm_malloc (size
);
689 #if !defined (HAVE_TM_ZONE)
692 restorezone (zone_spec
, oldenv
, FUNC_NAME
);
693 SCM_CRITICAL_SECTION_END
;
698 result
= scm_from_locale_stringn (tbuf
+ 1, len
- 1);
701 #if HAVE_STRUCT_TM_TM_ZONE
702 free ((char *) t
.tm_zone
);
709 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
710 (SCM format
, SCM string
),
711 "Performs the reverse action to @code{strftime}, parsing\n"
712 "@var{string} according to the specification supplied in\n"
713 "@var{template}. The interpretation of month and day names is\n"
714 "dependent on the current locale. The value returned is a pair.\n"
715 "The car has an object with time components\n"
716 "in the form returned by @code{localtime} or @code{gmtime},\n"
717 "but the time zone components\n"
718 "are not usefully set.\n"
719 "The cdr reports the number of characters from @var{string}\n"
720 "which were used for the conversion.")
721 #define FUNC_NAME s_scm_strptime
724 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
743 #if HAVE_STRUCT_TM_TM_GMTOFF
748 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
749 reads a UTC time_t value and converts with localtime_r() to set the tm
750 fields, hence the use of SCM_CRITICAL_SECTION_START. */
752 SCM_CRITICAL_SECTION_START
;
753 rest
= strptime (str
, fmt
, &t
);
754 SCM_CRITICAL_SECTION_END
;
757 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
758 instance it doesn't. Force a sensible value for our error
764 /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
766 #if HAVE_STRUCT_TM_TM_GMTOFF
767 zoff
= - t
.tm_gmtoff
; /* seconds west, not east */
772 return scm_cons (filltime (&t
, zoff
, NULL
),
773 scm_from_signed_integer (rest
- str
));
776 #endif /* HAVE_STRPTIME */
781 scm_c_define ("internal-time-units-per-second",
782 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
785 if (!scm_your_base
.time
) ftime(&scm_your_base
);
787 if (!scm_your_base
) time(&scm_your_base
);
790 if (!scm_my_base
) scm_my_base
= mytime();
792 scm_add_feature ("current-time");
793 #include "libguile/stime.x"