1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006 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. */
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));
500 #if HAVE_STRUCT_TM_TM_GMTOFF
501 lt
->tm_gmtoff
= - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time
, 9));
504 if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10)))
507 lt
->tm_zone
= scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time
, 10));
511 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
512 (SCM sbd_time
, SCM zone
),
513 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
514 "is an optional time zone specifier (otherwise the TZ environment variable\n"
515 "or the system default is used).\n\n"
516 "Returns a pair: the car is a corresponding\n"
517 "integer time value like that returned\n"
518 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
519 "as @var{bd-time} but with normalized values.")
520 #define FUNC_NAME s_scm_mktime
530 scm_dynwind_begin (0);
532 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
533 #if HAVE_STRUCT_TM_TM_ZONE
534 scm_dynwind_free ((char *)lt
.tm_zone
);
537 scm_dynwind_critical_section (SCM_BOOL_F
);
539 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
540 #ifdef LOCALTIME_CACHE
543 itime
= mktime (<
);
544 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
545 doesn't. Force a sensible value for our error message. */
552 /* copy zone name before calling gmtime or restoring the zone. */
553 #if defined (HAVE_TM_ZONE)
555 #elif defined (HAVE_TZNAME)
556 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
560 zname
= scm_malloc (strlen (ptr
) + 1);
564 /* get timezone offset in seconds west of UTC. */
565 /* POSIX says gmtime sets errno, but C99 doesn't say that.
566 Give a sensible default value in case gmtime doesn't set it. */
568 utc
= gmtime (&itime
);
572 restorezone (zone
, oldenv
, FUNC_NAME
);
573 /* delayed until zone has been restored. */
575 if (utc
== NULL
|| itime
== -1)
578 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
579 + utc
->tm_sec
- lt
.tm_sec
;
580 if (utc
->tm_year
< lt
.tm_year
)
581 zoff
-= 24 * 60 * 60;
582 else if (utc
->tm_year
> lt
.tm_year
)
583 zoff
+= 24 * 60 * 60;
584 else if (utc
->tm_yday
< lt
.tm_yday
)
585 zoff
-= 24 * 60 * 60;
586 else if (utc
->tm_yday
> lt
.tm_yday
)
587 zoff
+= 24 * 60 * 60;
589 result
= scm_cons (scm_from_long (itime
),
590 filltime (<
, zoff
, zname
));
600 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
602 "Initialize the timezone from the TZ environment variable\n"
603 "or the system default. It's not usually necessary to call this procedure\n"
604 "since it's done automatically by other procedures that depend on the\n"
606 #define FUNC_NAME s_scm_tzset
609 return SCM_UNSPECIFIED
;
612 #endif /* HAVE_TZSET */
614 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
615 (SCM format
, SCM stime
),
616 "Return a string which is broken-down time structure @var{stime}\n"
617 "formatted according to the given @var{format} string.\n"
619 "@var{format} contains field specifications introduced by a\n"
620 "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n"
621 "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
622 "for the available formatting.\n"
625 "(strftime \"%c\" (localtime (current-time)))\n"
626 "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
629 "If @code{setlocale} has been called (@pxref{Locales}), month\n"
630 "and day names are from the current locale and in the locale\n"
632 #define FUNC_NAME s_scm_strftime
643 SCM_VALIDATE_STRING (1, format
);
644 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
646 fmt
= scm_i_string_chars (format
);
647 len
= scm_i_string_length (format
);
649 /* Ugly hack: strftime can return 0 if its buffer is too small,
650 but some valid time strings (e.g. "%p") can sometimes produce
651 a zero-byte output string! Workaround is to prepend a junk
652 character to the format string, so that valid returns are always
654 myfmt
= scm_malloc (len
+2);
656 strncpy(myfmt
+1, fmt
, len
);
659 tbuf
= scm_malloc (size
);
661 #if !defined (HAVE_TM_ZONE)
662 /* it seems the only way to tell non-GNU versions of strftime what
663 zone to use (for the %Z format) is to set TZ in the
664 environment. interrupts and thread switching must be deferred
665 until TZ is restored. */
666 char **oldenv
= NULL
;
667 SCM zone_spec
= SCM_SIMPLE_VECTOR_REF (stime
, 10);
670 if (scm_is_true (zone_spec
) && scm_c_string_length (zone_spec
) > 0)
672 /* it's not required that the TZ setting be correct, just that
673 it has the right name. so try something like TZ=EST0.
674 using only TZ=EST would be simpler but it doesn't work on
675 some OSs, e.g., Solaris. */
677 scm_string_append (scm_list_2 (zone_spec
,
678 scm_from_locale_string ("0")));
681 SCM_CRITICAL_SECTION_START
;
682 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
686 #ifdef LOCALTIME_CACHE
690 /* POSIX says strftime returns 0 on buffer overrun, but old
691 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
693 while ((len
= strftime (tbuf
, size
, myfmt
, &t
)) == 0 || len
== size
)
697 tbuf
= scm_malloc (size
);
700 #if !defined (HAVE_TM_ZONE)
703 restorezone (zone_spec
, oldenv
, FUNC_NAME
);
704 SCM_CRITICAL_SECTION_END
;
709 result
= scm_from_locale_stringn (tbuf
+ 1, len
- 1);
712 #if HAVE_STRUCT_TM_TM_ZONE
713 free ((char *) t
.tm_zone
);
720 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
721 (SCM format
, SCM string
),
722 "Performs the reverse action to @code{strftime}, parsing\n"
723 "@var{string} according to the specification supplied in\n"
724 "@var{template}. The interpretation of month and day names is\n"
725 "dependent on the current locale. The value returned is a pair.\n"
726 "The car has an object with time components\n"
727 "in the form returned by @code{localtime} or @code{gmtime},\n"
728 "but the time zone components\n"
729 "are not usefully set.\n"
730 "The cdr reports the number of characters from @var{string}\n"
731 "which were used for the conversion.")
732 #define FUNC_NAME s_scm_strptime
735 const char *fmt
, *str
, *rest
;
738 SCM_VALIDATE_STRING (1, format
);
739 SCM_VALIDATE_STRING (2, string
);
741 fmt
= scm_i_string_chars (format
);
742 str
= scm_i_string_chars (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
= strptime (str
, fmt
, &t
);
765 SCM_CRITICAL_SECTION_END
;
768 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
769 instance it doesn't. Force a sensible value for our error
775 /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
777 #if HAVE_STRUCT_TM_TM_GMTOFF
778 zoff
= - t
.tm_gmtoff
; /* seconds west, not east */
783 return scm_cons (filltime (&t
, zoff
, NULL
),
784 scm_from_signed_integer (rest
- str
));
787 #endif /* HAVE_STRPTIME */
792 scm_c_define ("internal-time-units-per-second",
793 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
796 if (!scm_your_base
.time
) ftime(&scm_your_base
);
798 if (!scm_your_base
) time(&scm_your_base
);
801 if (!scm_my_base
) scm_my_base
= mytime();
803 scm_add_feature ("current-time");
804 #include "libguile/stime.x"