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 #define _GNU_SOURCE /* ask glibc for everything, in particular strptime */
22 #define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
31 #include "libguile/_scm.h"
32 #include "libguile/feature.h"
33 #include "libguile/strings.h"
34 #include "libguile/vectors.h"
35 #include "libguile/dynwind.h"
37 #include "libguile/validate.h"
38 #include "libguile/stime.h"
45 # ifdef HAVE_SYS_TYPES_H
46 # include <sys/types.h>
53 #ifdef HAVE_SYS_TIMES_H
54 # include <sys/times.h>
57 #ifdef HAVE_SYS_TIMEB_H
58 # include <sys/timeb.h>
61 #if HAVE_CRT_EXTERNS_H
62 #include <crt_externs.h> /* for Darwin _NSGetEnviron */
65 #ifndef tzname /* For SGI. */
66 extern char *tzname
[]; /* RS6000 and others reject char **tzname. */
68 #if defined (__MINGW32__)
69 # define tzname _tzname
72 #if ! HAVE_DECL_STRPTIME
73 extern char *strptime ();
82 extern char ** environ
;
84 /* On Apple Darwin in a shared library there's no "environ" to access
85 directly, instead the address of that variable must be obtained with
87 #if HAVE__NSGETENVIRON && defined (PIC)
88 #define environ (*_NSGetEnviron())
96 struct tms time_buffer
;
98 return time_buffer
.tms_utime
+ time_buffer
.tms_stime
;
102 # define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
104 # define mytime clock
109 struct timeb scm_your_base
= {0};
111 timet scm_your_base
= 0;
114 SCM_DEFINE (scm_get_internal_real_time
, "get-internal-real-time", 0, 0, 0,
116 "Return the number of time units since the interpreter was\n"
118 #define FUNC_NAME s_scm_get_internal_real_time
121 struct timeb time_buffer
;
124 ftime (&time_buffer
);
125 time_buffer
.time
-= scm_your_base
.time
;
126 tmp
= scm_from_long (time_buffer
.millitm
- scm_your_base
.millitm
);
128 scm_product (scm_from_int (1000),
129 scm_from_int (time_buffer
.time
)));
130 return scm_quotient (scm_product (tmp
,
131 scm_from_int (SCM_TIME_UNITS_PER_SECOND
)),
132 scm_from_int (1000));
134 return scm_from_long ((time((timet
*)0) - scm_your_base
)
135 * (int)SCM_TIME_UNITS_PER_SECOND
);
136 #endif /* HAVE_FTIME */
142 SCM_DEFINE (scm_times
, "times", 0, 0, 0,
144 "Return an object with information about real and processor\n"
145 "time. The following procedures accept such an object as an\n"
146 "argument and return a selected component:\n"
150 "The current real time, expressed as time units relative to an\n"
153 "The CPU time units used by the calling process.\n"
155 "The CPU time units used by the system on behalf of the calling\n"
158 "The CPU time units used by terminated child processes of the\n"
159 "calling process, whose status has been collected (e.g., using\n"
162 "Similarly, the CPU times units used by the system on behalf of\n"
163 "terminated child processes.\n"
165 #define FUNC_NAME s_scm_times
170 SCM result
= scm_c_make_vector (5, SCM_UNDEFINED
);
174 SCM_VECTOR_SET (result
, 0, scm_from_long (rv
));
175 SCM_VECTOR_SET (result
, 1, scm_from_long (t
.tms_utime
));
176 SCM_VECTOR_SET (result
, 2, scm_from_long (t
.tms_stime
));
177 SCM_VECTOR_SET (result
,3, scm_from_long (t
.tms_cutime
));
178 SCM_VECTOR_SET (result
, 4, scm_from_long (t
.tms_cstime
));
182 #endif /* HAVE_TIMES */
184 static long scm_my_base
= 0;
187 scm_c_get_internal_run_time ()
189 return mytime () - scm_my_base
;
192 SCM_DEFINE (scm_get_internal_run_time
, "get-internal-run-time", 0, 0, 0,
194 "Return the number of time units of processor time used by the\n"
195 "interpreter. Both @emph{system} and @emph{user} time are\n"
196 "included but subprocesses are not.")
197 #define FUNC_NAME s_scm_get_internal_run_time
199 return scm_from_long (scm_c_get_internal_run_time ());
203 /* For reference, note that current-time and gettimeofday both should be
204 protected against setzone/restorezone changes in another thread, since on
205 DOS the system time is normally kept as local time, which means TZ
206 affects the return from current-time and gettimeofday. Not sure if DJGPP
207 etc actually has concurrent multi-threading, but it seems prudent not to
208 make assumptions about this. */
210 SCM_DEFINE (scm_current_time
, "current-time", 0, 0, 0,
212 "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
213 "excluding leap seconds.")
214 #define FUNC_NAME s_scm_current_time
219 if ((timv
= time (0)) == -1)
220 SCM_MISC_ERROR ("current time not available", SCM_EOL
);
222 return scm_from_long (timv
);
226 SCM_DEFINE (scm_gettimeofday
, "gettimeofday", 0, 0, 0,
228 "Return a pair containing the number of seconds and microseconds\n"
229 "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
230 "whether true microsecond resolution is available depends on the\n"
232 #define FUNC_NAME s_scm_gettimeofday
234 #ifdef HAVE_GETTIMEOFDAY
238 if (gettimeofday (&time
, NULL
) == -1)
241 return scm_cons (scm_from_long (time
.tv_sec
),
242 scm_from_long (time
.tv_usec
));
248 return scm_cons (scm_from_long (time
.time
),
249 scm_from_int (time
.millitm
* 1000));
254 if ((timv
= time (0)) == -1)
257 return scm_cons (scm_from_long (timv
), scm_from_int (0));
264 filltime (struct tm
*bd_time
, int zoff
, const char *zname
)
266 SCM result
= scm_c_make_vector (11, SCM_UNDEFINED
);
268 SCM_VECTOR_SET (result
,0, scm_from_int (bd_time
->tm_sec
));
269 SCM_VECTOR_SET (result
,1, scm_from_int (bd_time
->tm_min
));
270 SCM_VECTOR_SET (result
,2, scm_from_int (bd_time
->tm_hour
));
271 SCM_VECTOR_SET (result
,3, scm_from_int (bd_time
->tm_mday
));
272 SCM_VECTOR_SET (result
,4, scm_from_int (bd_time
->tm_mon
));
273 SCM_VECTOR_SET (result
,5, scm_from_int (bd_time
->tm_year
));
274 SCM_VECTOR_SET (result
,6, scm_from_int (bd_time
->tm_wday
));
275 SCM_VECTOR_SET (result
,7, scm_from_int (bd_time
->tm_yday
));
276 SCM_VECTOR_SET (result
,8, scm_from_int (bd_time
->tm_isdst
));
277 SCM_VECTOR_SET (result
,9, scm_from_int (zoff
));
278 SCM_VECTOR_SET (result
,10, (zname
279 ? scm_from_locale_string (zname
)
284 static char tzvar
[3] = "TZ";
286 /* if zone is set, create a temporary environment with only a TZ
287 string. other threads or interrupt handlers shouldn't be allowed
288 to run until the corresponding restorezone is called. hence the use
289 of a static variable for tmpenv is no big deal. */
291 setzone (SCM zone
, int pos
, const char *subr
)
295 if (!SCM_UNBNDP (zone
))
297 static char *tmpenv
[2];
301 zone_len
= scm_to_locale_stringbuf (zone
, NULL
, 0);
302 buf
= scm_malloc (zone_len
+ sizeof (tzvar
) + 1);
304 buf
[sizeof(tzvar
)-1] = '=';
305 scm_to_locale_stringbuf (zone
, buf
+sizeof(tzvar
), zone_len
);
306 buf
[sizeof(tzvar
)+zone_len
] = '\0';
316 restorezone (SCM zone
, char **oldenv
, const char *subr SCM_UNUSED
)
318 if (!SCM_UNBNDP (zone
))
323 /* for the possible benefit of user code linked with libguile. */
329 SCM_DEFINE (scm_localtime
, "localtime", 1, 1, 0,
330 (SCM time
, SCM zone
),
331 "Return an object representing the broken down components of\n"
332 "@var{time}, an integer like the one returned by\n"
333 "@code{current-time}. The time zone for the calculation is\n"
334 "optionally specified by @var{zone} (a string), otherwise the\n"
335 "@code{TZ} environment variable or the system default is used.")
336 #define FUNC_NAME s_scm_localtime
339 struct tm
*ltptr
, lt
, *utc
;
346 itime
= SCM_NUM2LONG (1, time
);
348 /* deferring interupts is essential since a) setzone may install a temporary
349 environment b) localtime uses a static buffer. */
351 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
352 #ifdef LOCALTIME_CACHE
355 /* POSIX says localtime sets errno, but C99 doesn't say that.
356 Give a sensible default value in case localtime doesn't set it. */
358 ltptr
= localtime (&itime
);
364 /* copy zone name before calling gmtime or restoring zone. */
365 #if defined (HAVE_TM_ZONE)
366 ptr
= ltptr
->tm_zone
;
367 #elif defined (HAVE_TZNAME)
368 ptr
= tzname
[ (ltptr
->tm_isdst
== 1) ? 1 : 0 ];
372 zname
= scm_malloc (strlen (ptr
) + 1);
375 /* the struct is copied in case localtime and gmtime share a buffer. */
378 /* POSIX says gmtime sets errno, but C99 doesn't say that.
379 Give a sensible default value in case gmtime doesn't set it. */
381 utc
= gmtime (&itime
);
384 restorezone (zone
, oldenv
, FUNC_NAME
);
385 /* delayed until zone has been restored. */
387 if (utc
== NULL
|| ltptr
== NULL
)
390 /* calculate timezone offset in seconds west of UTC. */
391 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
392 + utc
->tm_sec
- lt
.tm_sec
;
393 if (utc
->tm_year
< lt
.tm_year
)
394 zoff
-= 24 * 60 * 60;
395 else if (utc
->tm_year
> lt
.tm_year
)
396 zoff
+= 24 * 60 * 60;
397 else if (utc
->tm_yday
< lt
.tm_yday
)
398 zoff
-= 24 * 60 * 60;
399 else if (utc
->tm_yday
> lt
.tm_yday
)
400 zoff
+= 24 * 60 * 60;
402 result
= filltime (<
, zoff
, zname
);
410 /* tm_zone is normally a pointer, not an array within struct tm, so we might
411 have to worry about the lifespan of what it points to. The posix specs
412 don't seem to say anything about this, let's assume here that tm_zone
413 will be a constant and therefore no protection or anything is needed
414 until we copy it in filltime(). */
416 SCM_DEFINE (scm_gmtime
, "gmtime", 1, 0, 0,
418 "Return an object representing the broken down components of\n"
419 "@var{time}, an integer like the one returned by\n"
420 "@code{current-time}. The values are calculated for UTC.")
421 #define FUNC_NAME s_scm_gmtime
424 struct tm bd_buf
, *bd_time
;
427 itime
= SCM_NUM2LONG (1, time
);
429 /* POSIX says gmtime sets errno, but C99 doesn't say that.
430 Give a sensible default value in case gmtime doesn't set it. */
434 bd_time
= gmtime_r (&itime
, &bd_buf
);
437 bd_time
= gmtime (&itime
);
445 #if HAVE_STRUCT_TM_TM_ZONE
446 zname
= bd_buf
.tm_zone
;
450 return filltime (&bd_buf
, 0, zname
);
454 /* copy time components from a Scheme object to a struct tm. */
456 bdtime2c (SCM sbd_time
, struct tm
*lt
, int pos
, const char *subr
)
461 SCM_ASSERT (SCM_VECTORP (sbd_time
)
462 && SCM_VECTOR_LENGTH (sbd_time
) == 11,
463 sbd_time
, pos
, subr
);
464 velts
= SCM_VELTS (sbd_time
);
465 for (i
= 0; i
< 10; i
++)
467 SCM_ASSERT (scm_is_integer (velts
[i
]), sbd_time
, pos
, subr
);
469 SCM_ASSERT (scm_is_false (velts
[10]) || scm_is_string (velts
[10]),
470 sbd_time
, pos
, subr
);
472 lt
->tm_sec
= scm_to_int (velts
[0]);
473 lt
->tm_min
= scm_to_int (velts
[1]);
474 lt
->tm_hour
= scm_to_int (velts
[2]);
475 lt
->tm_mday
= scm_to_int (velts
[3]);
476 lt
->tm_mon
= scm_to_int (velts
[4]);
477 lt
->tm_year
= scm_to_int (velts
[5]);
478 lt
->tm_wday
= scm_to_int (velts
[6]);
479 lt
->tm_yday
= scm_to_int (velts
[7]);
480 lt
->tm_isdst
= scm_to_int (velts
[8]);
482 lt
->tm_gmtoff
= scm_to_int (velts
[9]);
483 if (scm_is_false (velts
[10]))
486 lt
->tm_zone
= scm_to_locale_string (velts
[10]);
490 SCM_DEFINE (scm_mktime
, "mktime", 1, 1, 0,
491 (SCM sbd_time
, SCM zone
),
492 "@var{bd-time} is an object representing broken down time and @code{zone}\n"
493 "is an optional time zone specifier (otherwise the TZ environment variable\n"
494 "or the system default is used).\n\n"
495 "Returns a pair: the car is a corresponding\n"
496 "integer time value like that returned\n"
497 "by @code{current-time}; the cdr is a broken down time object, similar to\n"
498 "as @var{bd-time} but with normalized values.")
499 #define FUNC_NAME s_scm_mktime
511 bdtime2c (sbd_time
, <
, SCM_ARG1
, FUNC_NAME
);
512 scm_frame_free ((char *)lt
.tm_zone
);
515 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
516 #ifdef LOCALTIME_CACHE
519 itime
= mktime (<
);
520 /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
521 doesn't. Force a sensible value for our error message. */
528 /* copy zone name before calling gmtime or restoring the zone. */
529 #if defined (HAVE_TM_ZONE)
531 #elif defined (HAVE_TZNAME)
532 ptr
= tzname
[ (lt
.tm_isdst
== 1) ? 1 : 0 ];
536 zname
= scm_malloc (strlen (ptr
) + 1);
540 /* get timezone offset in seconds west of UTC. */
541 /* POSIX says gmtime sets errno, but C99 doesn't say that.
542 Give a sensible default value in case gmtime doesn't set it. */
543 utc
= gmtime (&itime
);
547 restorezone (zone
, oldenv
, FUNC_NAME
);
548 /* delayed until zone has been restored. */
550 if (utc
== NULL
|| itime
== -1)
553 zoff
= (utc
->tm_hour
- lt
.tm_hour
) * 3600 + (utc
->tm_min
- lt
.tm_min
) * 60
554 + utc
->tm_sec
- lt
.tm_sec
;
555 if (utc
->tm_year
< lt
.tm_year
)
556 zoff
-= 24 * 60 * 60;
557 else if (utc
->tm_year
> lt
.tm_year
)
558 zoff
+= 24 * 60 * 60;
559 else if (utc
->tm_yday
< lt
.tm_yday
)
560 zoff
-= 24 * 60 * 60;
561 else if (utc
->tm_yday
> lt
.tm_yday
)
562 zoff
+= 24 * 60 * 60;
564 result
= scm_cons (scm_from_long (itime
),
565 filltime (<
, zoff
, zname
));
576 SCM_DEFINE (scm_tzset
, "tzset", 0, 0, 0,
578 "Initialize the timezone from the TZ environment variable\n"
579 "or the system default. It's not usually necessary to call this procedure\n"
580 "since it's done automatically by other procedures that depend on the\n"
582 #define FUNC_NAME s_scm_tzset
585 return SCM_UNSPECIFIED
;
588 #endif /* HAVE_TZSET */
590 SCM_DEFINE (scm_strftime
, "strftime", 2, 0, 0,
591 (SCM format
, SCM stime
),
592 "Formats a time specification @var{time} using @var{template}. @var{time}\n"
593 "is an object with time components in the form returned by @code{localtime}\n"
594 "or @code{gmtime}. @var{template} is a string which can include formatting\n"
595 "specifications introduced by a @code{%} character. The formatting of\n"
596 "month and day names is dependent on the current locale. The value returned\n"
597 "is the formatted string.\n"
598 "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
599 #define FUNC_NAME s_scm_strftime
610 SCM_VALIDATE_STRING (1, format
);
611 bdtime2c (stime
, &t
, SCM_ARG2
, FUNC_NAME
);
613 fmt
= scm_i_string_chars (format
);
614 len
= scm_i_string_length (format
);
616 /* Ugly hack: strftime can return 0 if its buffer is too small,
617 but some valid time strings (e.g. "%p") can sometimes produce
618 a zero-byte output string! Workaround is to prepend a junk
619 character to the format string, so that valid returns are always
621 myfmt
= scm_malloc (len
+2);
623 strncpy(myfmt
+1, fmt
, len
);
626 tbuf
= scm_malloc (size
);
628 #if !defined (HAVE_TM_ZONE)
629 /* it seems the only way to tell non-GNU versions of strftime what
630 zone to use (for the %Z format) is to set TZ in the
631 environment. interrupts and thread switching must be deferred
632 until TZ is restored. */
633 char **oldenv
= NULL
;
634 SCM
*velts
= (SCM
*) SCM_VELTS (stime
);
637 if (scm_is_true (velts
[10]) && *SCM_STRING_CHARS (velts
[10]) != 0)
639 /* it's not required that the TZ setting be correct, just that
640 it has the right name. so try something like TZ=EST0.
641 using only TZ=EST would be simpler but it doesn't work on
642 some OSs, e.g., Solaris. */
644 scm_string_append (scm_cons (velts
[10],
645 scm_cons (scm_makfrom0str ("0"),
650 oldenv
= setzone (zone
, SCM_ARG2
, FUNC_NAME
);
654 #ifdef LOCALTIME_CACHE
658 /* POSIX says strftime returns 0 on buffer overrun, but old
659 systems (i.e. libc 4 on GNU/Linux) might return `size' in that
661 while ((len
= strftime (tbuf
, size
, myfmt
, &t
)) == 0 || len
== size
)
665 tbuf
= scm_malloc (size
);
668 #if !defined (HAVE_TM_ZONE)
671 restorezone (velts
[10], oldenv
, FUNC_NAME
);
677 result
= scm_from_locale_stringn (tbuf
+ 1, len
- 1);
685 SCM_DEFINE (scm_strptime
, "strptime", 2, 0, 0,
686 (SCM format
, SCM string
),
687 "Performs the reverse action to @code{strftime}, parsing\n"
688 "@var{string} according to the specification supplied in\n"
689 "@var{template}. The interpretation of month and day names is\n"
690 "dependent on the current locale. The value returned is a pair.\n"
691 "The car has an object with time components\n"
692 "in the form returned by @code{localtime} or @code{gmtime},\n"
693 "but the time zone components\n"
694 "are not usefully set.\n"
695 "The cdr reports the number of characters from @var{string}\n"
696 "which were used for the conversion.")
697 #define FUNC_NAME s_scm_strptime
700 const char *fmt
, *str
, *rest
;
702 SCM_VALIDATE_STRING (1, format
);
703 SCM_VALIDATE_STRING (2, string
);
705 fmt
= scm_i_string_chars (format
);
706 str
= scm_i_string_chars (string
);
708 /* initialize the struct tm */
709 #define tm_init(field) t.field = 0
720 /* GNU glibc strptime() "%s" is affected by the current timezone, since it
721 reads a UTC time_t value and converts with localtime_r() to set the tm
722 fields, hence the use of SCM_DEFER_INTS. */
725 if ((rest
= strptime (str
, fmt
, &t
)) == NULL
)
727 /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
728 instance it doesn't. Force a sensible value for our error
735 return scm_cons (filltime (&t
, 0, NULL
),
736 scm_from_signed_integer (rest
- str
));
739 #endif /* HAVE_STRPTIME */
744 scm_c_define ("internal-time-units-per-second",
745 scm_from_long (SCM_TIME_UNITS_PER_SECOND
));
748 if (!scm_your_base
.time
) ftime(&scm_your_base
);
750 if (!scm_your_base
) time(&scm_your_base
);
753 if (!scm_my_base
) scm_my_base
= mytime();
755 scm_add_feature ("current-time");
756 #include "libguile/stime.x"