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 */
48 #include "libguile/_scm.h"
49 #include "libguile/async.h"
50 #include "libguile/feature.h"
51 #include "libguile/strings.h"
52 #include "libguile/vectors.h"
53 #include "libguile/dynwind.h"
55 #include "libguile/validate.h"
56 #include "libguile/stime.h"
63 # ifdef HAVE_SYS_TYPES_H
64 # include <sys/types.h>
71 #ifdef HAVE_SYS_TIMES_H
72 # include <sys/times.h>
75 #ifdef HAVE_SYS_TIMEB_H
76 # include <sys/timeb.h>
79 #if HAVE_CRT_EXTERNS_H
80 #include <crt_externs.h> /* for Darwin _NSGetEnviron */
83 #if defined (__MINGW32__)
84 # define tzname _tzname
86 #ifndef tzname /* For SGI. */
87 extern char *tzname[]; /* RS6000 and others reject char **tzname. */
91 #if ! HAVE_DECL_STRPTIME
92 extern char *strptime ();
101 extern char ** environ;
103 /* On Apple Darwin in a shared library there's no "environ" to access
104 directly, instead the address of that variable must be obtained with
106 #if HAVE__NSGETENVIRON && defined (PIC)
107 #define environ (*_NSGetEnviron())
115 struct tms time_buffer;
117 return time_buffer.tms_utime + time_buffer.tms_stime;
121 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
123 # define mytime clock
128 struct timeb scm_your_base = {0};
130 timet scm_your_base = 0;
133 SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
135 "Return the number of time units since the interpreter was\n"
137 #define FUNC_NAME s_scm_get_internal_real_time
140 struct timeb time_buffer;
143 ftime (&time_buffer);
144 time_buffer.time -= scm_your_base.time;
145 tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
147 scm_product (scm_from_int (1000),
148 scm_from_int (time_buffer.time)));
149 return scm_quotient (scm_product (tmp,
150 scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
151 scm_from_int (1000));
153 return scm_from_long ((time((timet*)0) - scm_your_base)
154 * (int)SCM_TIME_UNITS_PER_SECOND);
155 #endif /* HAVE_FTIME */
161 SCM_DEFINE (scm_times, "times", 0, 0, 0,
163 "Return an object with information about real and processor\n"
164 "time. The following procedures accept such an object as an\n"
165 "argument and return a selected component:\n"
169 "The current real time, expressed as time units relative to an\n"
172 "The CPU time units used by the calling process.\n"
174 "The CPU time units used by the system on behalf of the calling\n"
177 "The CPU time units used by terminated child processes of the\n"
178 "calling process, whose status has been collected (e.g., using\n"
181 "Similarly, the CPU times units used by the system on behalf of\n"
182 "terminated child processes.\n"
184 #define FUNC_NAME s_scm_times
189 SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
193 SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
194 SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
195 SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
196 SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
197 SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
201 #endif /* HAVE_TIMES */
203 static long scm_my_base = 0;
206 scm_c_get_internal_run_time ()
208 return mytime () - scm_my_base;
211 SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
213 "Return the number of time units of processor time used by the\n"
214 "interpreter. Both @emph{system} and @emph{user} time are\n"
215 "included but subprocesses are not.")
216 #define FUNC_NAME s_scm_get_internal_run_time
218 return scm_from_long (scm_c_get_internal_run_time ());
222 /* For reference, note that current-time and gettimeofday both should be
223 protected against setzone/restorezone changes in another thread, since on
224 DOS the system time is normally kept as local time, which means TZ
225 affects the return from current-time and gettimeofday. Not sure if DJGPP
226 etc actually has concurrent multi-threading, but it seems prudent not to
227 make assumptions about this. */
229 SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
231 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
232 "excluding leap seconds.")
233 #define FUNC_NAME s_scm_current_time
237 SCM_CRITICAL_SECTION_START;
239 SCM_CRITICAL_SECTION_END;
241 SCM_MISC_ERROR ("current time not available", SCM_EOL);
242 return scm_from_long (timv);
246 SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
248 "Return a pair containing the number of seconds and microseconds\n"
249 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
250 "whether true microsecond resolution is available depends on the\n"
252 #define FUNC_NAME s_scm_gettimeofday
254 #ifdef HAVE_GETTIMEOFDAY
258 SCM_CRITICAL_SECTION_START;
259 ret = gettimeofday (&time, NULL);
261 SCM_CRITICAL_SECTION_END;
267 return scm_cons (scm_from_long (time.tv_sec),
268 scm_from_long (time.tv_usec));
274 return scm_cons (scm_from_long (time.time),
275 scm_from_int (time.millitm * 1000));
280 SCM_CRITICAL_SECTION_START;
283 SCM_CRITICAL_SECTION_END;
289 return scm_cons (scm_from_long (timv), scm_from_int (0));
296 filltime (struct tm *bd_time, int zoff, const char *zname)
298 SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
300 SCM_SIMPLE_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec));
301 SCM_SIMPLE_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min));
302 SCM_SIMPLE_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour));
303 SCM_SIMPLE_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday));
304 SCM_SIMPLE_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon));
305 SCM_SIMPLE_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year));
306 SCM_SIMPLE_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday));
307 SCM_SIMPLE_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday));
308 SCM_SIMPLE_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst));
309 SCM_SIMPLE_VECTOR_SET (result,9, scm_from_int (zoff));
310 SCM_SIMPLE_VECTOR_SET (result,10, (zname
311 ? scm_from_locale_string (zname)
316 static char tzvar[3] = "TZ";
318 /* if zone is set, create a temporary environment with only a TZ
319 string. other threads or interrupt handlers shouldn't be allowed
320 to run until the corresponding restorezone is called. hence the use
321 of a static variable for tmpenv is no big deal. */
323 setzone (SCM zone, int pos, const char *subr)
327 if (!SCM_UNBNDP (zone))
329 static char *tmpenv[2];
333 zone_len = scm_to_locale_stringbuf (zone, NULL, 0);
334 buf = scm_malloc (zone_len + sizeof (tzvar) + 1);
336 buf[sizeof(tzvar)-1] = '=';
337 scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len);
338 buf[sizeof(tzvar)+zone_len] = '\0';
348 restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
350 if (!SCM_UNBNDP (zone))
355 /* for the possible benefit of user code linked with libguile. */
361 SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
362 (SCM time, SCM zone),
363 "Return an object representing the broken down components of\n"
364 "@var{time}, an integer like the one returned by\n"
365 "@code{current-time}. The time zone for the calculation is\n"
366 "optionally specified by @var{zone} (a string), otherwise the\n"
367 "@code{TZ} environment variable or the system default is used.")
368 #define FUNC_NAME s_scm_localtime
371 struct tm *ltptr, lt, *utc;
378 itime = SCM_NUM2LONG (1, time);
380 /* deferring interupts is essential since a) setzone may install a temporary
381 environment b) localtime uses a static buffer. */
382 SCM_CRITICAL_SECTION_START;
383 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
384 #ifdef LOCALTIME_CACHE
387 /* POSIX says localtime sets errno, but C99 doesn't say that.
388 Give a sensible default value in case localtime doesn't set it. */
390 ltptr = localtime (&itime);
396 /* copy zone name before calling gmtime or restoring zone. */
397 #if defined (HAVE_TM_ZONE)
398 ptr = ltptr->tm_zone;
399 #elif defined (HAVE_TZNAME)
400 ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
404 zname = scm_malloc (strlen (ptr) + 1);
407 /* the struct is copied in case localtime and gmtime share a buffer. */
410 /* POSIX says gmtime sets errno, but C99 doesn't say that.
411 Give a sensible default value in case gmtime doesn't set it. */
413 utc = gmtime (&itime);
416 restorezone (zone, oldenv, FUNC_NAME);
417 /* delayed until zone has been restored. */
419 if (utc == NULL || ltptr == NULL)
422 /* calculate timezone offset in seconds west of UTC. */
423 zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
424 + utc->tm_sec - lt.tm_sec;
425 if (utc->tm_year < lt.tm_year)
426 zoff -= 24 * 60 * 60;
427 else if (utc->tm_year > lt.tm_year)
428 zoff += 24 * 60 * 60;
429 else if (utc->tm_yday < lt.tm_yday)
430 zoff -= 24 * 60 * 60;
431 else if (utc->tm_yday > lt.tm_yday)
432 zoff += 24 * 60 * 60;
434 result = filltime (<, zoff, zname);
435 SCM_CRITICAL_SECTION_END;
442 /* tm_zone is normally a pointer, not an array within struct tm, so we might
443 have to worry about the lifespan of what it points to. The posix specs
444 don't seem to say anything about this, let's assume here that tm_zone
445 will be a constant and therefore no protection or anything is needed
446 until we copy it in filltime(). */
448 SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
450 "Return an object representing the broken down components of\n"
451 "@var{time}, an integer like the one returned by\n"
452 "@code{current-time}. The values are calculated for UTC.")
453 #define FUNC_NAME s_scm_gmtime
456 struct tm bd_buf, *bd_time;
459 itime = SCM_NUM2LONG (1, time);
461 /* POSIX says gmtime sets errno, but C99 doesn't say that.
462 Give a sensible default value in case gmtime doesn't set it. */
466 bd_time = gmtime_r (&itime, &bd_buf);
468 SCM_CRITICAL_SECTION_START;
469 bd_time = gmtime (&itime);
472 SCM_CRITICAL_SECTION_END;
477 #if HAVE_STRUCT_TM_TM_ZONE
478 zname = bd_buf.tm_zone;
482 return filltime (&bd_buf, 0, zname);
486 /* copy time components from a Scheme object to a struct tm. */
488 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
490 SCM_ASSERT (scm_is_simple_vector (sbd_time)
491 && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
492 sbd_time, pos, subr);
494 lt->tm_sec = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 0));
495 lt->tm_min = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 1));
496 lt->tm_hour = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 2));
497 lt->tm_mday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 3));
498 lt->tm_mon = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 4));
499 lt->tm_year = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 5));
500 lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6));
501 lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
502 lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8));
503 #if HAVE_STRUCT_TM_TM_GMTOFF
504 lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
507 if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
510 lt->tm_zone = scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time, 10));
514 SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
515 (SCM sbd_time, SCM zone),
516 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
517 "is an optional time zone specifier (otherwise the TZ environment variable\n"
518 "or the system default is used).\n\n"
519 "Returns a pair: the car is a corresponding\n"
520 "integer time value like that returned\n"
521 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
522 "as @var{bd-time} but with normalized values.")
523 #define FUNC_NAME s_scm_mktime
533 scm_dynwind_begin (0);
535 bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME);
536 #if HAVE_STRUCT_TM_TM_ZONE
537 scm_dynwind_free ((char *)lt.tm_zone);
540 scm_dynwind_critical_section (SCM_BOOL_F);
542 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
543 #ifdef LOCALTIME_CACHE
546 itime = mktime (<);
547 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
548 doesn't. Force a sensible value for our error message. */
555 /* copy zone name before calling gmtime or restoring the zone. */
556 #if defined (HAVE_TM_ZONE)
558 #elif defined (HAVE_TZNAME)
559 ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
563 zname = scm_malloc (strlen (ptr) + 1);
567 /* get timezone offset in seconds west of UTC. */
568 /* POSIX says gmtime sets errno, but C99 doesn't say that.
569 Give a sensible default value in case gmtime doesn't set it. */
571 utc = gmtime (&itime);
575 restorezone (zone, oldenv, FUNC_NAME);
576 /* delayed until zone has been restored. */
578 if (utc == NULL || itime == -1)
581 zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
582 + utc->tm_sec - lt.tm_sec;
583 if (utc->tm_year < lt.tm_year)
584 zoff -= 24 * 60 * 60;
585 else if (utc->tm_year > lt.tm_year)
586 zoff += 24 * 60 * 60;
587 else if (utc->tm_yday < lt.tm_yday)
588 zoff -= 24 * 60 * 60;
589 else if (utc->tm_yday > lt.tm_yday)
590 zoff += 24 * 60 * 60;
592 result = scm_cons (scm_from_long (itime),
593 filltime (<, zoff, zname));
603 SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
605 "Initialize the timezone from the TZ environment variable\n"
606 "or the system default. It's not usually necessary to call this procedure\n"
607 "since it's done automatically by other procedures that depend on the\n"
609 #define FUNC_NAME s_scm_tzset
612 return SCM_UNSPECIFIED;
615 #endif /* HAVE_TZSET */
617 SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
618 (SCM format, SCM stime),
619 "Return a string which is broken-down time structure @var{stime}\n"
620 "formatted according to the given @var{format} string.\n"
622 "@var{format} contains field specifications introduced by a\n"
623 "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n"
624 "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
625 "for the available formatting.\n"
628 "(strftime \"%c\" (localtime (current-time)))\n"
629 "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
632 "If @code{setlocale} has been called (@pxref{Locales}), month\n"
633 "and day names are from the current locale and in the locale\n"
635 #define FUNC_NAME s_scm_strftime
646 SCM_VALIDATE_STRING (1, format);
647 bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
649 fmt = scm_i_string_chars (format);
650 len = scm_i_string_length (format);
652 /* Ugly hack: strftime can return 0 if its buffer is too small,
653 but some valid time strings (e.g. "%p") can sometimes produce
654 a zero-byte output string! Workaround is to prepend a junk
655 character to the format string, so that valid returns are always
657 myfmt = scm_malloc (len+2);
659 strncpy(myfmt+1, fmt, len);
662 tbuf = scm_malloc (size);
664 #if !defined (HAVE_TM_ZONE)
665 /* it seems the only way to tell non-GNU versions of strftime what
666 zone to use (for the %Z format) is to set TZ in the
667 environment. interrupts and thread switching must be deferred
668 until TZ is restored. */
669 char **oldenv = NULL;
670 SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10);
673 if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0)
675 /* it's not required that the TZ setting be correct, just that
676 it has the right name. so try something like TZ=EST0.
677 using only TZ=EST would be simpler but it doesn't work on
678 some OSs, e.g., Solaris. */
680 scm_string_append (scm_list_2 (zone_spec,
681 scm_from_locale_string ("0")));
684 SCM_CRITICAL_SECTION_START;
685 oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
689 #ifdef LOCALTIME_CACHE
693 /* POSIX says strftime returns 0 on buffer overrun, but old
694 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
696 while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
700 tbuf = scm_malloc (size);
703 #if !defined (HAVE_TM_ZONE)
706 restorezone (zone_spec, oldenv, FUNC_NAME);
707 SCM_CRITICAL_SECTION_END;
712 result = scm_from_locale_stringn (tbuf + 1, len - 1);
715 #if HAVE_STRUCT_TM_TM_ZONE
716 free ((char *) t.tm_zone);
723 SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
724 (SCM format, SCM string),
725 "Performs the reverse action to @code{strftime}, parsing\n"
726 "@var{string} according to the specification supplied in\n"
727 "@var{template}. The interpretation of month and day names is\n"
728 "dependent on the current locale. The value returned is a pair.\n"
729 "The car has an object with time components\n"
730 "in the form returned by @code{localtime} or @code{gmtime},\n"
731 "but the time zone components\n"
732 "are not usefully set.\n"
733 "The cdr reports the number of characters from @var{string}\n"
734 "which were used for the conversion.")
735 #define FUNC_NAME s_scm_strptime
738 const char *fmt, *str, *rest;
741 SCM_VALIDATE_STRING (1, format);
742 SCM_VALIDATE_STRING (2, string);
744 fmt = scm_i_string_chars (format);
745 str = scm_i_string_chars (string);
747 /* initialize the struct tm */
748 #define tm_init(field) t.field = 0
757 #if HAVE_STRUCT_TM_TM_GMTOFF
762 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
763 reads a UTC time_t value and converts with localtime_r() to set the tm
764 fields, hence the use of SCM_CRITICAL_SECTION_START. */
766 SCM_CRITICAL_SECTION_START;
767 rest = strptime (str, fmt, &t);
768 SCM_CRITICAL_SECTION_END;
771 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
772 instance it doesn't. Force a sensible value for our error
778 /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
780 #if HAVE_STRUCT_TM_TM_GMTOFF
781 zoff = - t.tm_gmtoff; /* seconds west, not east */
786 return scm_cons (filltime (&t, zoff, NULL),
787 scm_from_signed_integer (rest - str));
790 #endif /* HAVE_STRPTIME */
795 scm_c_define ("internal-time-units-per-second",
796 scm_from_long (SCM_TIME_UNITS_PER_SECOND));
799 if (!scm_your_base.time) ftime(&scm_your_base);
801 if (!scm_your_base) time(&scm_your_base);
804 if (!scm_my_base) scm_my_base = mytime();
806 scm_add_feature ("current-time");
807 #include "libguile/stime.x"