1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 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/feature.h"
48 #include "libguile/strings.h"
49 #include "libguile/vectors.h"
50 #include "libguile/dynwind.h"
52 #include "libguile/validate.h"
53 #include "libguile/stime.h"
60 # ifdef HAVE_SYS_TYPES_H
61 # include <sys/types.h>
68 #ifdef HAVE_SYS_TIMES_H
69 # include <sys/times.h>
72 #ifdef HAVE_SYS_TIMEB_H
73 # include <sys/timeb.h>
76 #if HAVE_CRT_EXTERNS_H
77 #include <crt_externs.h> /* for Darwin _NSGetEnviron */
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 ();
97 extern char ** environ
;
99 /* On Apple Darwin in a shared library there's no "environ" to access
100 directly, instead the address of that variable must be obtained with
102 #if HAVE__NSGETENVIRON && defined (PIC)
103 #define environ (*_NSGetEnviron())
111 struct tms time_buffer
;
113 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
117 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
119 # define mytime clock
124 struct timeb scm_your_base
= {0};
126 timet scm_your_base
= 0;
129 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
131 "Return the number of time units since the interpreter was\n"
133 #define FUNC_NAME s_scm_get_internal_real_time
136 struct timeb time_buffer
;
139 ftime (&time_buffer
);
140 time_buffer
.time
-= scm_your_base
.time
;
141 tmp
= scm_from_long (time_buffer
.millitm
- scm_your_base
.millitm
);
143 scm_product (scm_from_int (1000),
144 scm_from_int (time_buffer
.time
)));
145 return scm_quotient (scm_product (tmp
,
146 scm_from_int (SCM_TIME_UNITS_PER_SECOND
)),
147 scm_from_int (1000));
149 return scm_from_long ((time((timet
*)0) - scm_your_base
)
150 * (int)SCM_TIME_UNITS_PER_SECOND
);
151 #endif /* HAVE_FTIME */
157 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
159 "Return an object with information about real and processor\n"
160 "time. The following procedures accept such an object as an\n"
161 "argument and return a selected component:\n"
165 "The current real time, expressed as time units relative to an\n"
168 "The CPU time units used by the calling process.\n"
170 "The CPU time units used by the system on behalf of the calling\n"
173 "The CPU time units used by terminated child processes of the\n"
174 "calling process, whose status has been collected (e.g., using\n"
177 "Similarly, the CPU times units used by the system on behalf of\n"
178 "terminated child processes.\n"
180 #define FUNC_NAME s_scm_times
185 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
189 SCM_VECTOR_SET (result
, 0, scm_from_long (rv
));
190 SCM_VECTOR_SET (result
, 1, scm_from_long (t
.tms_utime
));
191 SCM_VECTOR_SET (result
, 2, scm_from_long (t
.tms_stime
));
192 SCM_VECTOR_SET (result
,3, scm_from_long (t
.tms_cutime
));
193 SCM_VECTOR_SET (result
, 4, scm_from_long (t
.tms_cstime
));
197 #endif /* HAVE_TIMES */
199 static long scm_my_base
= 0;
202 scm_c_get_internal_run_time ()
204 return mytime () - scm_my_base
;
207 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
209 "Return the number of time units of processor time used by the\n"
210 "interpreter. Both @emph{system} and @emph{user} time are\n"
211 "included but subprocesses are not.")
212 #define FUNC_NAME s_scm_get_internal_run_time
214 return scm_from_long (scm_c_get_internal_run_time ());
218 /* For reference, note that current-time and gettimeofday both should be
219 protected against setzone/restorezone changes in another thread, since on
220 DOS the system time is normally kept as local time, which means TZ
221 affects the return from current-time and gettimeofday. Not sure if DJGPP
222 etc actually has concurrent multi-threading, but it seems prudent not to
223 make assumptions about this. */
225 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
227 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
228 "excluding leap seconds.")
229 #define FUNC_NAME s_scm_current_time
237 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
238 return scm_from_long (timv
);
242 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
244 "Return a pair containing the number of seconds and microseconds\n"
245 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
246 "whether true microsecond resolution is available depends on the\n"
248 #define FUNC_NAME s_scm_gettimeofday
250 #ifdef HAVE_GETTIMEOFDAY
255 ret
= gettimeofday (&time
, NULL
);
263 return scm_cons (scm_from_long (time
.tv_sec
),
264 scm_from_long (time
.tv_usec
));
270 return scm_cons (scm_from_long (time
.time
),
271 scm_from_int (time
.millitm
* 1000));
285 return scm_cons (scm_from_long (timv
), scm_from_int (0));
292 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
294 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
296 SCM_VECTOR_SET (result
,0, scm_from_int (bd_time
->tm_sec
));
297 SCM_VECTOR_SET (result
,1, scm_from_int (bd_time
->tm_min
));
298 SCM_VECTOR_SET (result
,2, scm_from_int (bd_time
->tm_hour
));
299 SCM_VECTOR_SET (result
,3, scm_from_int (bd_time
->tm_mday
));
300 SCM_VECTOR_SET (result
,4, scm_from_int (bd_time
->tm_mon
));
301 SCM_VECTOR_SET (result
,5, scm_from_int (bd_time
->tm_year
));
302 SCM_VECTOR_SET (result
,6, scm_from_int (bd_time
->tm_wday
));
303 SCM_VECTOR_SET (result
,7, scm_from_int (bd_time
->tm_yday
));
304 SCM_VECTOR_SET (result
,8, scm_from_int (bd_time
->tm_isdst
));
305 SCM_VECTOR_SET (result
,9, scm_from_int (zoff
));
306 SCM_VECTOR_SET (result
,10, (zname
307 ? scm_from_locale_string (zname
)
312 static char tzvar
[3] = "TZ";
314 /* if zone is set, create a temporary environment with only a TZ
315 string. other threads or interrupt handlers shouldn't be allowed
316 to run until the corresponding restorezone is called. hence the use
317 of a static variable for tmpenv is no big deal. */
319 setzone (SCM zone
, int pos
, const char *subr
)
323 if (!SCM_UNBNDP (zone
))
325 static char *tmpenv
[2];
329 zone_len
= scm_to_locale_stringbuf (zone
, NULL
, 0);
330 buf
= scm_malloc (zone_len
+ sizeof (tzvar
) + 1);
332 buf
[sizeof(tzvar
)-1] = '=';
333 scm_to_locale_stringbuf (zone
, buf
+sizeof(tzvar
), zone_len
);
334 buf
[sizeof(tzvar
)+zone_len
] = '\0';
344 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
346 if (!SCM_UNBNDP (zone
))
351 /* for the possible benefit of user code linked with libguile. */
357 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
358 (SCM time
, SCM zone
),
359 "Return an object representing the broken down components of\n"
360 "@var{time}, an integer like the one returned by\n"
361 "@code{current-time}. The time zone for the calculation is\n"
362 "optionally specified by @var{zone} (a string), otherwise the\n"
363 "@code{TZ} environment variable or the system default is used.")
364 #define FUNC_NAME s_scm_localtime
367 struct tm
*ltptr
, lt
, *utc
;
374 itime
= SCM_NUM2LONG (1, time
);
376 /* deferring interupts is essential since a) setzone may install a temporary
377 environment b) localtime uses a static buffer. */
379 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
380 #ifdef LOCALTIME_CACHE
383 /* POSIX says localtime sets errno, but C99 doesn't say that.
384 Give a sensible default value in case localtime doesn't set it. */
386 ltptr
= localtime (&itime
);
392 /* copy zone name before calling gmtime or restoring zone. */
393 #if defined (HAVE_TM_ZONE)
394 ptr
= ltptr
->tm_zone
;
395 #elif defined (HAVE_TZNAME)
396 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
400 zname
= scm_malloc (strlen (ptr
) + 1);
403 /* the struct is copied in case localtime and gmtime share a buffer. */
406 /* POSIX says gmtime sets errno, but C99 doesn't say that.
407 Give a sensible default value in case gmtime doesn't set it. */
409 utc
= gmtime (&itime
);
412 restorezone (zone
, oldenv
, FUNC_NAME
);
413 /* delayed until zone has been restored. */
415 if (utc
== NULL
|| ltptr
== NULL
)
418 /* calculate timezone offset in seconds west of UTC. */
419 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
420 + utc
->tm_sec
- lt
.tm_sec
;
421 if (utc
->tm_year
< lt
.tm_year
)
422 zoff
-= 24 * 60 * 60;
423 else if (utc
->tm_year
> lt
.tm_year
)
424 zoff
+= 24 * 60 * 60;
425 else if (utc
->tm_yday
< lt
.tm_yday
)
426 zoff
-= 24 * 60 * 60;
427 else if (utc
->tm_yday
> lt
.tm_yday
)
428 zoff
+= 24 * 60 * 60;
430 result
= filltime (<
, zoff
, zname
);
438 /* tm_zone is normally a pointer, not an array within struct tm, so we might
439 have to worry about the lifespan of what it points to. The posix specs
440 don't seem to say anything about this, let's assume here that tm_zone
441 will be a constant and therefore no protection or anything is needed
442 until we copy it in filltime(). */
444 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
446 "Return an object representing the broken down components of\n"
447 "@var{time}, an integer like the one returned by\n"
448 "@code{current-time}. The values are calculated for UTC.")
449 #define FUNC_NAME s_scm_gmtime
452 struct tm bd_buf
, *bd_time
;
455 itime
= SCM_NUM2LONG (1, time
);
457 /* POSIX says gmtime sets errno, but C99 doesn't say that.
458 Give a sensible default value in case gmtime doesn't set it. */
462 bd_time
= gmtime_r (&itime
, &bd_buf
);
465 bd_time
= gmtime (&itime
);
473 #if HAVE_STRUCT_TM_TM_ZONE
474 zname
= bd_buf
.tm_zone
;
478 return filltime (&bd_buf
, 0, zname
);
482 /* copy time components from a Scheme object to a struct tm. */
484 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
489 SCM_ASSERT (SCM_VECTORP (sbd_time
)
490 && SCM_VECTOR_LENGTH (sbd_time
) == 11,
491 sbd_time
, pos
, subr
);
492 velts
= SCM_VELTS (sbd_time
);
493 for (i
= 0; i
< 10; i
++)
495 SCM_ASSERT (scm_is_integer (velts
[i
]), sbd_time
, pos
, subr
);
497 SCM_ASSERT (scm_is_false (velts
[10]) || scm_is_string (velts
[10]),
498 sbd_time
, pos
, subr
);
500 lt
->tm_sec
= scm_to_int (velts
[0]);
501 lt
->tm_min
= scm_to_int (velts
[1]);
502 lt
->tm_hour
= scm_to_int (velts
[2]);
503 lt
->tm_mday
= scm_to_int (velts
[3]);
504 lt
->tm_mon
= scm_to_int (velts
[4]);
505 lt
->tm_year
= scm_to_int (velts
[5]);
506 lt
->tm_wday
= scm_to_int (velts
[6]);
507 lt
->tm_yday
= scm_to_int (velts
[7]);
508 lt
->tm_isdst
= scm_to_int (velts
[8]);
510 lt
->tm_gmtoff
= scm_to_int (velts
[9]);
511 if (scm_is_false (velts
[10]))
514 lt
->tm_zone
= scm_to_locale_string (velts
[10]);
518 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
519 (SCM sbd_time
, SCM zone
),
520 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
521 "is an optional time zone specifier (otherwise the TZ environment variable\n"
522 "or the system default is used).\n\n"
523 "Returns a pair: the car is a corresponding\n"
524 "integer time value like that returned\n"
525 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
526 "as @var{bd-time} but with normalized values.")
527 #define FUNC_NAME s_scm_mktime
539 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
540 #if HAVE_STRUCT_TM_TM_ZONE
541 scm_frame_free ((char *)lt
.tm_zone
);
545 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
546 #ifdef LOCALTIME_CACHE
549 itime
= mktime (<
);
550 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
551 doesn't. Force a sensible value for our error message. */
558 /* copy zone name before calling gmtime or restoring the zone. */
559 #if defined (HAVE_TM_ZONE)
561 #elif defined (HAVE_TZNAME)
562 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
566 zname
= scm_malloc (strlen (ptr
) + 1);
570 /* get timezone offset in seconds west of UTC. */
571 /* POSIX says gmtime sets errno, but C99 doesn't say that.
572 Give a sensible default value in case gmtime doesn't set it. */
573 utc
= gmtime (&itime
);
577 restorezone (zone
, oldenv
, FUNC_NAME
);
578 /* delayed until zone has been restored. */
580 if (utc
== NULL
|| itime
== -1)
583 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
584 + utc
->tm_sec
- lt
.tm_sec
;
585 if (utc
->tm_year
< lt
.tm_year
)
586 zoff
-= 24 * 60 * 60;
587 else if (utc
->tm_year
> lt
.tm_year
)
588 zoff
+= 24 * 60 * 60;
589 else if (utc
->tm_yday
< lt
.tm_yday
)
590 zoff
-= 24 * 60 * 60;
591 else if (utc
->tm_yday
> lt
.tm_yday
)
592 zoff
+= 24 * 60 * 60;
594 result
= scm_cons (scm_from_long (itime
),
595 filltime (<
, zoff
, zname
));
606 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
608 "Initialize the timezone from the TZ environment variable\n"
609 "or the system default. It's not usually necessary to call this procedure\n"
610 "since it's done automatically by other procedures that depend on the\n"
612 #define FUNC_NAME s_scm_tzset
615 return SCM_UNSPECIFIED
;
618 #endif /* HAVE_TZSET */
620 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
621 (SCM format
, SCM stime
),
622 "Formats a time specification @var{time} using @var{template}. @var{time}\n"
623 "is an object with time components in the form returned by @code{localtime}\n"
624 "or @code{gmtime}. @var{template} is a string which can include formatting\n"
625 "specifications introduced by a @code{%} character. The formatting of\n"
626 "month and day names is dependent on the current locale. The value returned\n"
627 "is the formatted string.\n"
628 "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
629 #define FUNC_NAME s_scm_strftime
640 SCM_VALIDATE_STRING (1, format
);
641 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
643 fmt
= scm_i_string_chars (format
);
644 len
= scm_i_string_length (format
);
646 /* Ugly hack: strftime can return 0 if its buffer is too small,
647 but some valid time strings (e.g. "%p") can sometimes produce
648 a zero-byte output string! Workaround is to prepend a junk
649 character to the format string, so that valid returns are always
651 myfmt
= scm_malloc (len
+2);
653 strncpy(myfmt
+1, fmt
, len
);
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
*velts
= (SCM
*) SCM_VELTS (stime
);
667 if (scm_is_true (velts
[10]) && *SCM_STRING_CHARS (velts
[10]) != 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_cons (velts
[10],
675 scm_cons (scm_from_locale_string ("0"),
680 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
684 #ifdef LOCALTIME_CACHE
688 /* POSIX says strftime returns 0 on buffer overrun, but old
689 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
691 while ((len
= strftime (tbuf
, size
, myfmt
, &t
)) == 0 || len
== size
)
695 tbuf
= scm_malloc (size
);
698 #if !defined (HAVE_TM_ZONE)
701 restorezone (velts
[10], oldenv
, FUNC_NAME
);
707 result
= scm_from_locale_stringn (tbuf
+ 1, len
- 1);
715 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
716 (SCM format
, SCM string
),
717 "Performs the reverse action to @code{strftime}, parsing\n"
718 "@var{string} according to the specification supplied in\n"
719 "@var{template}. The interpretation of month and day names is\n"
720 "dependent on the current locale. The value returned is a pair.\n"
721 "The car has an object with time components\n"
722 "in the form returned by @code{localtime} or @code{gmtime},\n"
723 "but the time zone components\n"
724 "are not usefully set.\n"
725 "The cdr reports the number of characters from @var{string}\n"
726 "which were used for the conversion.")
727 #define FUNC_NAME s_scm_strptime
730 const char *fmt
, *str
, *rest
;
732 SCM_VALIDATE_STRING (1, format
);
733 SCM_VALIDATE_STRING (2, string
);
735 fmt
= scm_i_string_chars (format
);
736 str
= scm_i_string_chars (string
);
738 /* initialize the struct tm */
739 #define tm_init(field) t.field = 0
750 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
751 reads a UTC time_t value and converts with localtime_r() to set the tm
752 fields, hence the use of SCM_DEFER_INTS. */
755 rest
= strptime (str
, fmt
, &t
);
759 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
760 instance it doesn't. Force a sensible value for our error
766 return scm_cons (filltime (&t
, 0, NULL
),
767 scm_from_signed_integer (rest
- str
));
770 #endif /* HAVE_STRPTIME */
775 scm_c_define ("internal-time-units-per-second",
776 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
779 if (!scm_your_base
.time
) ftime(&scm_your_base
);
781 if (!scm_your_base
) time(&scm_your_base
);
784 if (!scm_my_base
) scm_my_base
= mytime();
786 scm_add_feature ("current-time");
787 #include "libguile/stime.x"