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"
added
removed
libguile/stime.c
