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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
22 /* _POSIX_C_SOURCE is not defined always, because it causes problems on some
25 - FreeBSD loses all BSD and XOPEN defines.
26 - glibc loses some things like CLK_TCK.
27 - On MINGW it conflicts with the pthread headers.
29 But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r.
31 Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and
32 what it takes away, and decide from that whether to use it, instead of
33 hard coding __hpux. */
36 # define _REENTRANT /* ask solaris for gmtime_r prototype */
39 #define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
51 #include "libguile/_scm.h"
52 #include "libguile/async.h"
53 #include "libguile/feature.h"
54 #include "libguile/strings.h"
55 #include "libguile/vectors.h"
56 #include "libguile/dynwind.h"
57 #include "libguile/strings.h"
59 #include "libguile/validate.h"
60 #include "libguile/stime.h"
67 # ifdef HAVE_SYS_TYPES_H
68 # include <sys/types.h>
75 #ifdef HAVE_SYS_TIMES_H
76 # include <sys/times.h>
79 #ifdef HAVE_SYS_TIMEB_H
80 # include <sys/timeb.h>
83 #ifndef tzname /* For SGI. */
84 extern char *tzname
[]; /* RS6000 and others reject char **tzname. */
86 #if defined (__MINGW32__)
87 # define tzname _tzname
90 #if ! HAVE_DECL_STRPTIME
91 extern char *strptime ();
105 struct tms time_buffer
;
107 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
111 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
113 # define mytime clock
118 struct timeb scm_your_base
= {0};
120 timet scm_your_base
= 0;
123 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
125 "Return the number of time units since the interpreter was\n"
127 #define FUNC_NAME s_scm_get_internal_real_time
130 struct timeb time_buffer
;
133 ftime (&time_buffer
);
134 time_buffer
.time
-= scm_your_base
.time
;
135 tmp
= scm_from_long (time_buffer
.millitm
- scm_your_base
.millitm
);
137 scm_product (scm_from_int (1000),
138 scm_from_int (time_buffer
.time
)));
139 return scm_quotient (scm_product (tmp
,
140 scm_from_int (SCM_TIME_UNITS_PER_SECOND
)),
141 scm_from_int (1000));
143 return scm_from_long ((time((timet
*)0) - scm_your_base
)
144 * (int)SCM_TIME_UNITS_PER_SECOND
);
145 #endif /* HAVE_FTIME */
151 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
153 "Return an object with information about real and processor\n"
154 "time. The following procedures accept such an object as an\n"
155 "argument and return a selected component:\n"
159 "The current real time, expressed as time units relative to an\n"
162 "The CPU time units used by the calling process.\n"
164 "The CPU time units used by the system on behalf of the calling\n"
167 "The CPU time units used by terminated child processes of the\n"
168 "calling process, whose status has been collected (e.g., using\n"
171 "Similarly, the CPU times units used by the system on behalf of\n"
172 "terminated child processes.\n"
174 #define FUNC_NAME s_scm_times
179 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
183 SCM_SIMPLE_VECTOR_SET (result
, 0, scm_from_long (rv
));
184 SCM_SIMPLE_VECTOR_SET (result
, 1, scm_from_long (t
.tms_utime
));
185 SCM_SIMPLE_VECTOR_SET (result
, 2, scm_from_long (t
.tms_stime
));
186 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_long (t
.tms_cutime
));
187 SCM_SIMPLE_VECTOR_SET (result
, 4, scm_from_long (t
.tms_cstime
));
191 #endif /* HAVE_TIMES */
193 static long scm_my_base
= 0;
196 scm_c_get_internal_run_time ()
198 return mytime () - scm_my_base
;
201 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
203 "Return the number of time units of processor time used by the\n"
204 "interpreter. Both @emph{system} and @emph{user} time are\n"
205 "included but subprocesses are not.")
206 #define FUNC_NAME s_scm_get_internal_run_time
208 return scm_from_long (scm_c_get_internal_run_time ());
212 /* For reference, note that current-time and gettimeofday both should be
213 protected against setzone/restorezone changes in another thread, since on
214 DOS the system time is normally kept as local time, which means TZ
215 affects the return from current-time and gettimeofday. Not sure if DJGPP
216 etc actually has concurrent multi-threading, but it seems prudent not to
217 make assumptions about this. */
219 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
221 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
222 "excluding leap seconds.")
223 #define FUNC_NAME s_scm_current_time
227 SCM_CRITICAL_SECTION_START
;
229 SCM_CRITICAL_SECTION_END
;
231 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
232 return scm_from_long (timv
);
236 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
238 "Return a pair containing the number of seconds and microseconds\n"
239 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
240 "whether true microsecond resolution is available depends on the\n"
242 #define FUNC_NAME s_scm_gettimeofday
244 #ifdef HAVE_GETTIMEOFDAY
248 SCM_CRITICAL_SECTION_START
;
249 ret
= gettimeofday (&time
, NULL
);
251 SCM_CRITICAL_SECTION_END
;
257 return scm_cons (scm_from_long (time
.tv_sec
),
258 scm_from_long (time
.tv_usec
));
264 return scm_cons (scm_from_long (time
.time
),
265 scm_from_int (time
.millitm
* 1000));
270 SCM_CRITICAL_SECTION_START
;
273 SCM_CRITICAL_SECTION_END
;
279 return scm_cons (scm_from_long (timv
), scm_from_int (0));
286 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
288 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
290 SCM_SIMPLE_VECTOR_SET (result
,0, scm_from_int (bd_time
->tm_sec
));
291 SCM_SIMPLE_VECTOR_SET (result
,1, scm_from_int (bd_time
->tm_min
));
292 SCM_SIMPLE_VECTOR_SET (result
,2, scm_from_int (bd_time
->tm_hour
));
293 SCM_SIMPLE_VECTOR_SET (result
,3, scm_from_int (bd_time
->tm_mday
));
294 SCM_SIMPLE_VECTOR_SET (result
,4, scm_from_int (bd_time
->tm_mon
));
295 SCM_SIMPLE_VECTOR_SET (result
,5, scm_from_int (bd_time
->tm_year
));
296 SCM_SIMPLE_VECTOR_SET (result
,6, scm_from_int (bd_time
->tm_wday
));
297 SCM_SIMPLE_VECTOR_SET (result
,7, scm_from_int (bd_time
->tm_yday
));
298 SCM_SIMPLE_VECTOR_SET (result
,8, scm_from_int (bd_time
->tm_isdst
));
299 SCM_SIMPLE_VECTOR_SET (result
,9, scm_from_int (zoff
));
300 SCM_SIMPLE_VECTOR_SET (result
,10, (zname
301 ? scm_from_locale_string (zname
)
306 static char tzvar
[3] = "TZ";
308 /* if zone is set, create a temporary environment with only a TZ
309 string. other threads or interrupt handlers shouldn't be allowed
310 to run until the corresponding restorezone is called. hence the use
311 of a static variable for tmpenv is no big deal. */
313 setzone (SCM zone
, int pos
, const char *subr
)
317 if (!SCM_UNBNDP (zone
))
319 static char *tmpenv
[2];
323 zone_len
= scm_to_locale_stringbuf (zone
, NULL
, 0);
324 buf
= scm_malloc (zone_len
+ sizeof (tzvar
) + 1);
326 buf
[sizeof(tzvar
)-1] = '=';
327 scm_to_locale_stringbuf (zone
, buf
+sizeof(tzvar
), zone_len
);
328 buf
[sizeof(tzvar
)+zone_len
] = '\0';
338 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
340 if (!SCM_UNBNDP (zone
))
345 /* for the possible benefit of user code linked with libguile. */
351 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
352 (SCM time
, SCM zone
),
353 "Return an object representing the broken down components of\n"
354 "@var{time}, an integer like the one returned by\n"
355 "@code{current-time}. The time zone for the calculation is\n"
356 "optionally specified by @var{zone} (a string), otherwise the\n"
357 "@code{TZ} environment variable or the system default is used.")
358 #define FUNC_NAME s_scm_localtime
361 struct tm
*ltptr
, lt
, *utc
;
368 itime
= SCM_NUM2LONG (1, time
);
370 /* deferring interupts is essential since a) setzone may install a temporary
371 environment b) localtime uses a static buffer. */
372 SCM_CRITICAL_SECTION_START
;
373 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
374 #ifdef LOCALTIME_CACHE
377 /* POSIX says localtime sets errno, but C99 doesn't say that.
378 Give a sensible default value in case localtime doesn't set it. */
380 ltptr
= localtime (&itime
);
386 /* copy zone name before calling gmtime or restoring zone. */
387 #if defined (HAVE_TM_ZONE)
388 ptr
= ltptr
->tm_zone
;
389 #elif defined (HAVE_TZNAME)
390 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
394 zname
= scm_malloc (strlen (ptr
) + 1);
397 /* the struct is copied in case localtime and gmtime share a buffer. */
400 /* POSIX says gmtime sets errno, but C99 doesn't say that.
401 Give a sensible default value in case gmtime doesn't set it. */
403 utc
= gmtime (&itime
);
406 restorezone (zone
, oldenv
, FUNC_NAME
);
407 /* delayed until zone has been restored. */
409 if (utc
== NULL
|| ltptr
== NULL
)
412 /* calculate timezone offset in seconds west of UTC. */
413 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
414 + utc
->tm_sec
- lt
.tm_sec
;
415 if (utc
->tm_year
< lt
.tm_year
)
416 zoff
-= 24 * 60 * 60;
417 else if (utc
->tm_year
> lt
.tm_year
)
418 zoff
+= 24 * 60 * 60;
419 else if (utc
->tm_yday
< lt
.tm_yday
)
420 zoff
-= 24 * 60 * 60;
421 else if (utc
->tm_yday
> lt
.tm_yday
)
422 zoff
+= 24 * 60 * 60;
424 result
= filltime (<
, zoff
, zname
);
425 SCM_CRITICAL_SECTION_END
;
432 /* tm_zone is normally a pointer, not an array within struct tm, so we might
433 have to worry about the lifespan of what it points to. The posix specs
434 don't seem to say anything about this, let's assume here that tm_zone
435 will be a constant and therefore no protection or anything is needed
436 until we copy it in filltime(). */
438 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
440 "Return an object representing the broken down components of\n"
441 "@var{time}, an integer like the one returned by\n"
442 "@code{current-time}. The values are calculated for UTC.")
443 #define FUNC_NAME s_scm_gmtime
446 struct tm bd_buf
, *bd_time
;
449 itime
= SCM_NUM2LONG (1, time
);
451 /* POSIX says gmtime sets errno, but C99 doesn't say that.
452 Give a sensible default value in case gmtime doesn't set it. */
456 bd_time
= gmtime_r (&itime
, &bd_buf
);
458 SCM_CRITICAL_SECTION_START
;
459 bd_time
= gmtime (&itime
);
462 SCM_CRITICAL_SECTION_END
;
467 #if HAVE_STRUCT_TM_TM_ZONE
468 zname
= bd_buf
.tm_zone
;
472 return filltime (&bd_buf
, 0, zname
);
476 /* copy time components from a Scheme object to a struct tm. */
478 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
480 SCM_ASSERT (scm_is_simple_vector (sbd_time
)
481 && SCM_SIMPLE_VECTOR_LENGTH (sbd_time
) == 11,
482 sbd_time
, pos
, subr
);
484 lt
->tm_sec
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 0));
485 lt
->tm_min
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 1));
486 lt
->tm_hour
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 2));
487 lt
->tm_mday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 3));
488 lt
->tm_mon
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 4));
489 lt
->tm_year
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 5));
490 lt
->tm_wday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 6));
491 lt
->tm_yday
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 7));
492 lt
->tm_isdst
= scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 8));
493 #if HAVE_STRUCT_TM_TM_GMTOFF
494 lt
->tm_gmtoff
= - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 9));
497 if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10)))
500 lt
->tm_zone
= scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10));
504 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
505 (SCM sbd_time
, SCM zone
),
506 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
507 "is an optional time zone specifier (otherwise the TZ environment variable\n"
508 "or the system default is used).\n\n"
509 "Returns a pair: the car is a corresponding\n"
510 "integer time value like that returned\n"
511 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
512 "as @var{bd-time} but with normalized values.")
513 #define FUNC_NAME s_scm_mktime
523 scm_dynwind_begin (0);
525 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
526 #if HAVE_STRUCT_TM_TM_ZONE
527 scm_dynwind_free ((char *)lt
.tm_zone
);
530 scm_dynwind_critical_section (SCM_BOOL_F
);
532 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
533 #ifdef LOCALTIME_CACHE
536 itime
= mktime (<
);
537 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
538 doesn't. Force a sensible value for our error message. */
545 /* copy zone name before calling gmtime or restoring the zone. */
546 #if defined (HAVE_TM_ZONE)
548 #elif defined (HAVE_TZNAME)
549 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
553 zname
= scm_malloc (strlen (ptr
) + 1);
557 /* get timezone offset in seconds west of UTC. */
558 /* POSIX says gmtime sets errno, but C99 doesn't say that.
559 Give a sensible default value in case gmtime doesn't set it. */
561 utc
= gmtime (&itime
);
565 restorezone (zone
, oldenv
, FUNC_NAME
);
566 /* delayed until zone has been restored. */
568 if (utc
== NULL
|| itime
== -1)
571 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
572 + utc
->tm_sec
- lt
.tm_sec
;
573 if (utc
->tm_year
< lt
.tm_year
)
574 zoff
-= 24 * 60 * 60;
575 else if (utc
->tm_year
> lt
.tm_year
)
576 zoff
+= 24 * 60 * 60;
577 else if (utc
->tm_yday
< lt
.tm_yday
)
578 zoff
-= 24 * 60 * 60;
579 else if (utc
->tm_yday
> lt
.tm_yday
)
580 zoff
+= 24 * 60 * 60;
582 result
= scm_cons (scm_from_long (itime
),
583 filltime (<
, zoff
, zname
));
593 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
595 "Initialize the timezone from the TZ environment variable\n"
596 "or the system default. It's not usually necessary to call this procedure\n"
597 "since it's done automatically by other procedures that depend on the\n"
599 #define FUNC_NAME s_scm_tzset
602 return SCM_UNSPECIFIED
;
605 #endif /* HAVE_TZSET */
607 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
608 (SCM format
, SCM stime
),
609 "Return a string which is broken-down time structure @var{stime}\n"
610 "formatted according to the given @var{format} string.\n"
612 "@var{format} contains field specifications introduced by a\n"
613 "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n"
614 "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
615 "for the available formatting.\n"
618 "(strftime \"%c\" (localtime (current-time)))\n"
619 "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
622 "If @code{setlocale} has been called (@pxref{Locales}), month\n"
623 "and day names are from the current locale and in the locale\n"
625 #define FUNC_NAME s_scm_strftime
636 SCM_VALIDATE_STRING (1, format
);
637 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
639 /* Convert string to UTF-8 so that non-ASCII characters in the
640 format are passed through unchanged. */
641 fmt
= scm_i_to_utf8_string (format
);
642 len
= strlen ((const char *) fmt
);
644 /* Ugly hack: strftime can return 0 if its buffer is too small,
645 but some valid time strings (e.g. "%p") can sometimes produce
646 a zero-byte output string! Workaround is to prepend a junk
647 character to the format string, so that valid returns are always
649 myfmt
= scm_malloc (len
+2);
650 *myfmt
= (scm_t_uint8
) 'x';
651 strncpy ((char *) myfmt
+ 1, (const char *) fmt
, len
);
653 scm_remember_upto_here_1 (format
);
656 tbuf
= scm_malloc (size
);
658 #if !defined (HAVE_TM_ZONE)
659 /* it seems the only way to tell non-GNU versions of strftime what
660 zone to use (for the %Z format) is to set TZ in the
661 environment. interrupts and thread switching must be deferred
662 until TZ is restored. */
663 char **oldenv
= NULL
;
664 SCM zone_spec
= SCM_SIMPLE_VECTOR_REF (stime
, 10);
667 if (scm_is_true (zone_spec
) && scm_c_string_length (zone_spec
) > 0)
669 /* it's not required that the TZ setting be correct, just that
670 it has the right name. so try something like TZ=EST0.
671 using only TZ=EST would be simpler but it doesn't work on
672 some OSs, e.g., Solaris. */
674 scm_string_append (scm_list_2 (zone_spec
,
675 scm_from_locale_string ("0")));
678 SCM_CRITICAL_SECTION_START
;
679 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
683 #ifdef LOCALTIME_CACHE
687 /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions
688 supported by glibc. */
689 while ((len
= nstrftime ((char *) tbuf
, size
,
690 (const char *) myfmt
, &t
, 0, 0)) == 0)
694 tbuf
= scm_malloc (size
);
697 #if !defined (HAVE_TM_ZONE)
700 restorezone (zone_spec
, oldenv
, FUNC_NAME
);
701 SCM_CRITICAL_SECTION_END
;
706 result
= scm_i_from_utf8_string ((const scm_t_uint8
*) tbuf
+ 1);
709 #if HAVE_STRUCT_TM_TM_ZONE
710 free ((char *) t
.tm_zone
);
717 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
718 (SCM format
, SCM string
),
719 "Performs the reverse action to @code{strftime}, parsing\n"
720 "@var{string} according to the specification supplied in\n"
721 "@var{template}. The interpretation of month and day names is\n"
722 "dependent on the current locale. The value returned is a pair.\n"
723 "The car has an object with time components\n"
724 "in the form returned by @code{localtime} or @code{gmtime},\n"
725 "but the time zone components\n"
726 "are not usefully set.\n"
727 "The cdr reports the number of characters from @var{string}\n"
728 "which were used for the conversion.")
729 #define FUNC_NAME s_scm_strptime
732 scm_t_uint8
*fmt
, *str
, *rest
;
736 SCM_VALIDATE_STRING (1, format
);
737 SCM_VALIDATE_STRING (2, string
);
739 /* Convert strings to UTF-8 so that non-ASCII characters are passed
740 through unchanged. */
741 fmt
= scm_i_to_utf8_string (format
);
742 str
= scm_i_to_utf8_string (string
);
744 /* initialize the struct tm */
745 #define tm_init(field) t.field = 0
754 #if HAVE_STRUCT_TM_TM_GMTOFF
759 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
760 reads a UTC time_t value and converts with localtime_r() to set the tm
761 fields, hence the use of SCM_CRITICAL_SECTION_START. */
763 SCM_CRITICAL_SECTION_START
;
764 rest
= (scm_t_uint8
*) strptime ((const char *) str
,
765 (const char *) fmt
, &t
);
766 SCM_CRITICAL_SECTION_END
;
769 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
770 instance it doesn't. Force a sensible value for our error
773 scm_remember_upto_here_2 (format
, string
);
779 /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
781 #if HAVE_STRUCT_TM_TM_GMTOFF
782 zoff
= - t
.tm_gmtoff
; /* seconds west, not east */
787 /* Compute the number of UTF-8 characters. */
788 used_len
= u8_strnlen (str
, rest
-str
);
789 scm_remember_upto_here_2 (format
, string
);
793 return scm_cons (filltime (&t
, zoff
, NULL
),
794 scm_from_signed_integer (used_len
));
797 #endif /* HAVE_STRPTIME */
802 scm_c_define ("internal-time-units-per-second",
803 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
806 if (!scm_your_base
.time
) ftime(&scm_your_base
);
808 if (!scm_your_base
) time(&scm_your_base
);
811 if (!scm_my_base
) scm_my_base
= mytime();
813 scm_add_feature ("current-time");
814 #include "libguile/stime.x"