X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f244dee1a1c80002fceec54545e58f7e3ff13178..77c2594f2f88fc8c2ec79126c9f04c9eb8b2d057:/libguile/stime.c diff --git a/libguile/stime.c b/libguile/stime.c dissimilarity index 69% index 37042f8a5..dce728053 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -1,559 +1,795 @@ -/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2, or (at your option) - * any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, - * Boston, MA 02111-1307 USA - * - * As a special exception, the Free Software Foundation gives permission - * for additional uses of the text contained in its release of GUILE. - * - * The exception is that, if you link the GUILE library with other files - * to produce an executable, this does not by itself cause the - * resulting executable to be covered by the GNU General Public License. - * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. - * - * This exception does not however invalidate any other reasons why - * the executable file might be covered by the GNU General Public License. - * - * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy - * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does - * not apply to the code that you add in this way. To avoid misleading - * anyone as to the status of such modified files, you must delete - * this exception notice from them. - * - * If you write modifications of your own for GUILE, it is your choice - * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. */ - - -#include -#include "_scm.h" -#include "feature.h" -#include "sequences.h" - -#include "stime.h" - -#ifdef HAVE_UNISTD_H -#include -#endif - - -# ifdef HAVE_SYS_TYPES_H -# include -# endif - -# ifdef TIME_WITH_SYS_TIME -# include -# include -# else -# ifdef HAVE_SYS_TIME_H -# include -# else -# ifdef HAVE_TIME_H -# include -# endif -# endif -# endif - -#ifdef HAVE_SYS_TIMES_H -# include -#endif - -#ifdef HAVE_SYS_TIMEB_H -# include -#endif - -#ifndef tzname /* For SGI. */ -extern char *tzname[]; /* RS6000 and others reject char **tzname. */ -#endif - -char *strptime (); - -/* This should be figured out by autoconf. */ -#ifdef CLK_TCK -# define CLKTCK CLK_TCK -# ifdef CLOCKS_PER_SEC -# if defined (unix) || defined (__unix) -# ifndef ARM_ULIB -# include -# endif -# define LACK_CLOCK - /* This is because clock() might be POSIX rather than ANSI. - This occurs on HP-UX machines */ -# endif -# endif -#else -# ifdef CLOCKS_PER_SEC -# define CLKTCK CLOCKS_PER_SEC -# else -# define LACK_CLOCK -# define CLKTCK 60 -# endif -#endif - -#ifdef __STDC__ -# define timet time_t -#else -# define timet long -#endif - -#ifdef HAVE_TIMES -static -long mytime() -{ - struct tms time_buffer; - times(&time_buffer); - return time_buffer.tms_utime + time_buffer.tms_stime; -} -#else -# ifdef LACK_CLOCK -# define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK) -# else -# define mytime clock -# endif -#endif - -extern int errno; - -#ifdef HAVE_FTIME - -extern int ftime (struct timeb *); - -struct timeb scm_your_base = {0}; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - struct timeb time_buffer; - long tmp; - ftime(&time_buffer); - time_buffer.time -= scm_your_base.time; - tmp = time_buffer.millitm - scm_your_base.millitm; - tmp = time_buffer.time*1000L + tmp; - tmp *= CLKTCK; - tmp /= 1000; - return scm_long2num (tmp); -} - -#else - -timet scm_your_base = 0; -SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time); -SCM -scm_get_internal_real_time() -{ - return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK); -} -#endif - - - -static long scm_my_base = 0; - -SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time); -SCM -scm_get_internal_run_time() -{ - return scm_long2num(mytime()-scm_my_base); -} - -SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time); -SCM -scm_current_time() -{ - timet timv; - - SCM_DEFER_INTS; - if ((timv = time (0)) == -1) - scm_syserror (s_current_time); - SCM_ALLOW_INTS; - return scm_long2num((long) timv); -} - -SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday); -SCM -scm_gettimeofday (void) -{ -#ifdef HAVE_GETTIMEOFDAY - struct timeval time; - - SCM_DEFER_INTS; - if (gettimeofday (&time, NULL) == -1) - scm_syserror (s_gettimeofday); - SCM_ALLOW_INTS; - return scm_cons (scm_long2num ((long) time.tv_sec), - scm_long2num ((long) time.tv_usec)); -#else -# ifdef HAVE_FTIME - struct timeb time; - - ftime(&time); - return scm_cons (scm_long2num ((long) time.time), - SCM_MAKINUM (time.millitm * 1000)); -# else - timet timv; - - SCM_DEFER_INTS; - if ((timv = time (0)) == -1) - scm_syserror (s_gettimeofday); - SCM_ALLOW_INTS; - return scm_cons (scm_long2num (timv), SCM_MAKINUM (0)); -# endif -#endif -} - -static SCM -filltime (struct tm *bd_time, int zoff, char *zname) -{ - SCM result = scm_make_vector(SCM_MAKINUM(11), SCM_UNDEFINED, SCM_UNDEFINED); - - SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec); - SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min); - SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour); - SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday); - SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon); - SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year); - SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday); - SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday); - SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst); - SCM_VELTS (result)[9] = SCM_MAKINUM (zoff); - SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F; - return result; -} - -static char * -setzone (SCM zone, int pos, char *subr) -{ - char *oldtz = 0; - - if (!SCM_UNBNDP (zone)) - { - char *buf; - - /* if zone was supplied, set the environment variable TZ temporarily. */ - SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr); - SCM_COERCE_SUBSTR (zone); - buf = malloc (SCM_LENGTH (zone) + 4); - if (buf == 0) - scm_memory_error (subr); - oldtz = getenv ("TZ"); - if (oldtz != NULL) - oldtz = oldtz - 3; - sprintf (buf, "TZ=%s", SCM_ROCHARS (zone)); - if (putenv (buf) < 0) - scm_syserror (subr); - tzset(); - } - return oldtz; -} - -static void -restorezone (SCM zone, char *oldzone) -{ - if (!SCM_UNBNDP (zone)) - { - int rv; - - if (oldzone) - rv = putenv (oldzone); - else - rv = putenv ("TZ"); - if (rv < 0) - scm_syserror ("restorezone"); - tzset(); - } -} - - -SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime); -SCM -scm_localtime (SCM time, SCM zone) -{ - timet itime; - struct tm *ltptr, lt, *utc; - SCM result; - int zoff; - char *zname = 0; - char *oldtz; - int err; - - itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime); - SCM_DEFER_INTS; - oldtz = setzone (zone, SCM_ARG2, s_localtime); - ltptr = localtime (&itime); - err = errno; - /* copied in case localtime and gmtime share a buffer. */ - if (ltptr) - lt = *ltptr; - utc = gmtime (&itime); - if (utc == NULL) - err = errno; - if (ltptr) - { -#ifdef HAVE_TM_ZONE - zname = lt.tm_zone; -#else -# ifdef HAVE_TZNAME - /* must be copied before calling tzset again. */ - char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; - - zname = scm_must_malloc (strlen (ptr) + 1, s_localtime); - strcpy (zname, ptr); -# else - scm_misc_error (s_localtime, "Not fully implemented on this platform", - SCM_EOF); -# endif -#endif - } - restorezone (zone, oldtz); - /* delayed until zone has been restored. */ - errno = err; - if (utc == NULL || ltptr == NULL) - scm_syserror (s_localtime); - - /* calculate timezone offset in seconds west of UTC. */ - zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 - + utc->tm_sec - lt.tm_sec; - if (utc->tm_year < lt.tm_year) - zoff -= 24 * 60 * 60; - else if (utc->tm_year > lt.tm_year) - zoff += 24 * 60 * 60; - else if (utc->tm_yday < lt.tm_yday) - zoff -= 24 * 60 * 60; - else if (utc->tm_yday > lt.tm_yday) - zoff += 24 * 60 * 60; - - result = filltime (<, zoff, zname); - SCM_ALLOW_INTS; - return result; -} - -SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime); -SCM -scm_gmtime (SCM time) -{ - timet itime; - struct tm *bd_time; - SCM result; - - itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime); - SCM_DEFER_INTS; - bd_time = gmtime (&itime); - if (bd_time == NULL) - scm_syserror (s_gmtime); - result = filltime (bd_time, 0, "GMT"); - SCM_ALLOW_INTS; - return result; -} - -/* copy time components from a Scheme object to a struct tm. */ -static void -bdtime2c (SCM sbd_time, struct tm *lt, int pos, char *subr) -{ - SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time) - && scm_obj_length (sbd_time) == 11 - && SCM_INUMP (SCM_VELTS (sbd_time)[0]) - && SCM_INUMP (SCM_VELTS (sbd_time)[1]) - && SCM_INUMP (SCM_VELTS (sbd_time)[2]) - && SCM_INUMP (SCM_VELTS (sbd_time)[3]) - && SCM_INUMP (SCM_VELTS (sbd_time)[4]) - && SCM_INUMP (SCM_VELTS (sbd_time)[5]) - && SCM_INUMP (SCM_VELTS (sbd_time)[6]) - && SCM_INUMP (SCM_VELTS (sbd_time)[7]) - && SCM_INUMP (SCM_VELTS (sbd_time)[8]), - sbd_time, pos, subr); - lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]); - lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]); - lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]); - lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]); - lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]); - lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]); - lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]); - lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]); - lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]); -} - -SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime); -SCM -scm_mktime (SCM sbd_time, SCM zone) -{ - timet itime; - struct tm lt, *utc; - SCM result; - int zoff; - char *zname = 0; - char *oldtz = 0; - int err; - - SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time, - SCM_ARG1, s_mktime); - bdtime2c (sbd_time, <, SCM_ARG1, s_mktime); - - SCM_DEFER_INTS; - oldtz = setzone (zone, SCM_ARG2, s_mktime); - itime = mktime (<); - err = errno; - - /* timezone offset in seconds west of UTC. */ - utc = gmtime (&itime); - if (utc == NULL) - err = errno; - - if (itime != -1) - { -#ifdef HAVE_TM_ZONE - zname = lt.tm_zone; -#else -# ifdef HAVE_TZNAME - /* must be copied before calling tzset again. */ - char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; - - zname = scm_must_malloc (strlen (ptr) + 1, s_mktime); - strcpy (zname, ptr); -# else - scm_misc_error (s_localtime, "Not fully implemented on this platform", - SCM_EOF); -# endif -#endif - } - restorezone (zone, oldtz); - /* delayed until zone has been restored. */ - errno = err; - if (utc == NULL || itime == -1) - scm_syserror (s_mktime); - - zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 - + utc->tm_sec - lt.tm_sec; - if (utc->tm_year < lt.tm_year) - zoff -= 24 * 60 * 60; - else if (utc->tm_year > lt.tm_year) - zoff += 24 * 60 * 60; - else if (utc->tm_yday < lt.tm_yday) - zoff -= 24 * 60 * 60; - else if (utc->tm_yday > lt.tm_yday) - zoff += 24 * 60 * 60; - - result = scm_cons (scm_long2num ((long) itime), - filltime (<, zoff, zname)); - SCM_ALLOW_INTS; - return result; -} - -SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset); -SCM -scm_tzset (void) -{ - tzset(); - return SCM_UNSPECIFIED; -} - -SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime); - -SCM -scm_strftime (format, stime) - SCM format; - SCM stime; -{ - struct tm t; - - char *tbuf; - int size = 50; - char *fmt; - int len; - - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, - s_strftime); - bdtime2c (stime, &t, SCM_ARG2, s_strftime); - - SCM_COERCE_SUBSTR (format); - fmt = SCM_ROCHARS (format); - len = SCM_ROLENGTH (format); - - tbuf = scm_must_malloc (size, s_strftime); - while ((len = strftime (tbuf, size, fmt, &t)) == size) - { - scm_must_free (tbuf); - size *= 2; - tbuf = scm_must_malloc (size, s_strftime); - } - return scm_makfromstr (tbuf, len, 0); -} - -SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime); - -SCM -scm_strptime (format, string) - SCM format; - SCM string; -{ -#ifdef HAVE_STRPTIME - struct tm t; - char *fmt, *str, *rest; - - SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1, - s_strptime); - SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2, - s_strptime); - - SCM_COERCE_SUBSTR (format); - SCM_COERCE_SUBSTR (string); - fmt = SCM_ROCHARS (format); - str = SCM_ROCHARS (string); - - /* initialize the struct tm */ -#define tm_init(field) t.field = 0 - tm_init (tm_sec); - tm_init (tm_min); - tm_init (tm_hour); - tm_init (tm_mday); - tm_init (tm_mon); - tm_init (tm_year); - tm_init (tm_wday); - tm_init (tm_yday); -#undef tm_init - - t.tm_isdst = -1; - SCM_DEFER_INTS; - if ((rest = strptime (str, fmt, &t)) == NULL) - scm_syserror (s_strptime); - - SCM_ALLOW_INTS; - return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str)); - -#else - scm_sysmissing (s_strptime); -#endif -} - -void -scm_init_stime() -{ - scm_sysintern("internal-time-units-per-second", - scm_long2num((long)CLKTCK)); - -#ifdef HAVE_FTIME - if (!scm_your_base.time) ftime(&scm_your_base); -#else - if (!scm_your_base) time(&scm_your_base); -#endif - - if (!scm_my_base) scm_my_base = mytime(); - - scm_add_feature ("current-time"); -#include "stime.x" -} - +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + */ + + + + +/* _POSIX_C_SOURCE is not defined always, because it causes problems on some + systems, notably + + - FreeBSD loses all BSD and XOPEN defines. + - glibc loses some things like CLK_TCK. + - On MINGW it conflicts with the pthread headers. + + But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r. + + Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and + what it takes away, and decide from that whether to use it, instead of + hard coding __hpux. */ + +#define _GNU_SOURCE /* ask glibc for everything, in particular strptime */ +#ifdef __hpux +#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */ +#endif + +#if HAVE_CONFIG_H +# include +#endif + +#include +#include + +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/strings.h" +#include "libguile/vectors.h" +#include "libguile/dynwind.h" + +#include "libguile/validate.h" +#include "libguile/stime.h" + +#ifdef HAVE_UNISTD_H +#include +#endif + + +# ifdef HAVE_SYS_TYPES_H +# include +# endif + +#ifdef HAVE_STRING_H +#include +#endif + +#ifdef HAVE_SYS_TIMES_H +# include +#endif + +#ifdef HAVE_SYS_TIMEB_H +# include +#endif + +#if HAVE_CRT_EXTERNS_H +#include /* for Darwin _NSGetEnviron */ +#endif + +#ifndef tzname /* For SGI. */ +extern char *tzname[]; /* RS6000 and others reject char **tzname. */ +#endif +#if defined (__MINGW32__) +# define tzname _tzname +#endif + +#if ! HAVE_DECL_STRPTIME +extern char *strptime (); +#endif + +#ifdef __STDC__ +# define timet time_t +#else +# define timet long +#endif + +extern char ** environ; + +/* On Apple Darwin in a shared library there's no "environ" to access + directly, instead the address of that variable must be obtained with + _NSGetEnviron(). */ +#if HAVE__NSGETENVIRON && defined (PIC) +#define environ (*_NSGetEnviron()) +#endif + + +#ifdef HAVE_TIMES +static +timet mytime() +{ + struct tms time_buffer; + times(&time_buffer); + return time_buffer.tms_utime + time_buffer.tms_stime; +} +#else +# ifdef LACK_CLOCK +# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND) +# else +# define mytime clock +# endif +#endif + +#ifdef HAVE_FTIME +struct timeb scm_your_base = {0}; +#else +timet scm_your_base = 0; +#endif + +SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, + (), + "Return the number of time units since the interpreter was\n" + "started.") +#define FUNC_NAME s_scm_get_internal_real_time +{ +#ifdef HAVE_FTIME + struct timeb time_buffer; + + SCM tmp; + ftime (&time_buffer); + time_buffer.time -= scm_your_base.time; + tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm); + tmp = scm_sum (tmp, + scm_product (scm_from_int (1000), + scm_from_int (time_buffer.time))); + return scm_quotient (scm_product (tmp, + scm_from_int (SCM_TIME_UNITS_PER_SECOND)), + scm_from_int (1000)); +#else + return scm_from_long ((time((timet*)0) - scm_your_base) + * (int)SCM_TIME_UNITS_PER_SECOND); +#endif /* HAVE_FTIME */ +} +#undef FUNC_NAME + + +#ifdef HAVE_TIMES +SCM_DEFINE (scm_times, "times", 0, 0, 0, + (void), + "Return an object with information about real and processor\n" + "time. The following procedures accept such an object as an\n" + "argument and return a selected component:\n" + "\n" + "@table @code\n" + "@item tms:clock\n" + "The current real time, expressed as time units relative to an\n" + "arbitrary base.\n" + "@item tms:utime\n" + "The CPU time units used by the calling process.\n" + "@item tms:stime\n" + "The CPU time units used by the system on behalf of the calling\n" + "process.\n" + "@item tms:cutime\n" + "The CPU time units used by terminated child processes of the\n" + "calling process, whose status has been collected (e.g., using\n" + "@code{waitpid}).\n" + "@item tms:cstime\n" + "Similarly, the CPU times units used by the system on behalf of\n" + "terminated child processes.\n" + "@end table") +#define FUNC_NAME s_scm_times +{ + struct tms t; + clock_t rv; + + SCM result = scm_c_make_vector (5, SCM_UNDEFINED); + rv = times (&t); + if (rv == -1) + SCM_SYSERROR; + SCM_VECTOR_SET (result, 0, scm_from_long (rv)); + SCM_VECTOR_SET (result, 1, scm_from_long (t.tms_utime)); + SCM_VECTOR_SET (result, 2, scm_from_long (t.tms_stime)); + SCM_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime)); + SCM_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime)); + return result; +} +#undef FUNC_NAME +#endif /* HAVE_TIMES */ + +static long scm_my_base = 0; + +long +scm_c_get_internal_run_time () +{ + return mytime () - scm_my_base; +} + +SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, + (void), + "Return the number of time units of processor time used by the\n" + "interpreter. Both @emph{system} and @emph{user} time are\n" + "included but subprocesses are not.") +#define FUNC_NAME s_scm_get_internal_run_time +{ + return scm_from_long (scm_c_get_internal_run_time ()); +} +#undef FUNC_NAME + +/* For reference, note that current-time and gettimeofday both should be + protected against setzone/restorezone changes in another thread, since on + DOS the system time is normally kept as local time, which means TZ + affects the return from current-time and gettimeofday. Not sure if DJGPP + etc actually has concurrent multi-threading, but it seems prudent not to + make assumptions about this. */ + +SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, + (void), + "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n" + "excluding leap seconds.") +#define FUNC_NAME s_scm_current_time +{ + timet timv; + + SCM_DEFER_INTS; + timv = time (NULL); + SCM_ALLOW_INTS; + if (timv == -1) + SCM_MISC_ERROR ("current time not available", SCM_EOL); + return scm_from_long (timv); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0, + (void), + "Return a pair containing the number of seconds and microseconds\n" + "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n" + "whether true microsecond resolution is available depends on the\n" + "operating system.") +#define FUNC_NAME s_scm_gettimeofday +{ +#ifdef HAVE_GETTIMEOFDAY + struct timeval time; + int ret, err; + + SCM_DEFER_INTS; + ret = gettimeofday (&time, NULL); + err = errno; + SCM_ALLOW_INTS; + if (ret == -1) + { + errno = err; + SCM_SYSERROR; + } + return scm_cons (scm_from_long (time.tv_sec), + scm_from_long (time.tv_usec)); +#else +# ifdef HAVE_FTIME + struct timeb time; + + ftime(&time); + return scm_cons (scm_from_long (time.time), + scm_from_int (time.millitm * 1000)); +# else + timet timv; + int err; + + SCM_DEFER_INTS; + timv = time (NULL); + err = errno; + SCM_ALLOW_INTS; + if (timv == -1) + { + errno = err; + SCM_SYSERROR; + } + return scm_cons (scm_from_long (timv), scm_from_int (0)); +# endif +#endif +} +#undef FUNC_NAME + +static SCM +filltime (struct tm *bd_time, int zoff, const char *zname) +{ + SCM result = scm_c_make_vector (11, SCM_UNDEFINED); + + SCM_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec)); + SCM_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min)); + SCM_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour)); + SCM_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday)); + SCM_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon)); + SCM_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year)); + SCM_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday)); + SCM_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday)); + SCM_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst)); + SCM_VECTOR_SET (result,9, scm_from_int (zoff)); + SCM_VECTOR_SET (result,10, (zname + ? scm_from_locale_string (zname) + : SCM_BOOL_F)); + return result; +} + +static char tzvar[3] = "TZ"; + +/* if zone is set, create a temporary environment with only a TZ + string. other threads or interrupt handlers shouldn't be allowed + to run until the corresponding restorezone is called. hence the use + of a static variable for tmpenv is no big deal. */ +static char ** +setzone (SCM zone, int pos, const char *subr) +{ + char **oldenv = 0; + + if (!SCM_UNBNDP (zone)) + { + static char *tmpenv[2]; + char *buf; + size_t zone_len; + + zone_len = scm_to_locale_stringbuf (zone, NULL, 0); + buf = scm_malloc (zone_len + sizeof (tzvar) + 1); + strcpy (buf, tzvar); + buf[sizeof(tzvar)-1] = '='; + scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len); + buf[sizeof(tzvar)+zone_len] = '\0'; + oldenv = environ; + tmpenv[0] = buf; + tmpenv[1] = 0; + environ = tmpenv; + } + return oldenv; +} + +static void +restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED) +{ + if (!SCM_UNBNDP (zone)) + { + free (environ[0]); + environ = oldenv; +#ifdef HAVE_TZSET + /* for the possible benefit of user code linked with libguile. */ + tzset(); +#endif + } +} + +SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, + (SCM time, SCM zone), + "Return an object representing the broken down components of\n" + "@var{time}, an integer like the one returned by\n" + "@code{current-time}. The time zone for the calculation is\n" + "optionally specified by @var{zone} (a string), otherwise the\n" + "@code{TZ} environment variable or the system default is used.") +#define FUNC_NAME s_scm_localtime +{ + timet itime; + struct tm *ltptr, lt, *utc; + SCM result; + int zoff; + char *zname = 0; + char **oldenv; + int err; + + itime = SCM_NUM2LONG (1, time); + + /* deferring interupts is essential since a) setzone may install a temporary + environment b) localtime uses a static buffer. */ + SCM_DEFER_INTS; + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); +#ifdef LOCALTIME_CACHE + tzset (); +#endif + /* POSIX says localtime sets errno, but C99 doesn't say that. + Give a sensible default value in case localtime doesn't set it. */ + errno = EINVAL; + ltptr = localtime (&itime); + err = errno; + if (ltptr) + { + const char *ptr; + + /* copy zone name before calling gmtime or restoring zone. */ +#if defined (HAVE_TM_ZONE) + ptr = ltptr->tm_zone; +#elif defined (HAVE_TZNAME) + ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ]; +#else + ptr = ""; +#endif + zname = scm_malloc (strlen (ptr) + 1); + strcpy (zname, ptr); + } + /* the struct is copied in case localtime and gmtime share a buffer. */ + if (ltptr) + lt = *ltptr; + /* POSIX says gmtime sets errno, but C99 doesn't say that. + Give a sensible default value in case gmtime doesn't set it. */ + errno = EINVAL; + utc = gmtime (&itime); + if (utc == NULL) + err = errno; + restorezone (zone, oldenv, FUNC_NAME); + /* delayed until zone has been restored. */ + errno = err; + if (utc == NULL || ltptr == NULL) + SCM_SYSERROR; + + /* calculate timezone offset in seconds west of UTC. */ + zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 + + utc->tm_sec - lt.tm_sec; + if (utc->tm_year < lt.tm_year) + zoff -= 24 * 60 * 60; + else if (utc->tm_year > lt.tm_year) + zoff += 24 * 60 * 60; + else if (utc->tm_yday < lt.tm_yday) + zoff -= 24 * 60 * 60; + else if (utc->tm_yday > lt.tm_yday) + zoff += 24 * 60 * 60; + + result = filltime (<, zoff, zname); + SCM_ALLOW_INTS; + if (zname) + free (zname); + return result; +} +#undef FUNC_NAME + +/* tm_zone is normally a pointer, not an array within struct tm, so we might + have to worry about the lifespan of what it points to. The posix specs + don't seem to say anything about this, let's assume here that tm_zone + will be a constant and therefore no protection or anything is needed + until we copy it in filltime(). */ + +SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, + (SCM time), + "Return an object representing the broken down components of\n" + "@var{time}, an integer like the one returned by\n" + "@code{current-time}. The values are calculated for UTC.") +#define FUNC_NAME s_scm_gmtime +{ + timet itime; + struct tm bd_buf, *bd_time; + const char *zname; + + itime = SCM_NUM2LONG (1, time); + + /* POSIX says gmtime sets errno, but C99 doesn't say that. + Give a sensible default value in case gmtime doesn't set it. */ + errno = EINVAL; + +#if HAVE_GMTIME_R + bd_time = gmtime_r (&itime, &bd_buf); +#else + SCM_DEFER_INTS; + bd_time = gmtime (&itime); + if (bd_time != NULL) + bd_buf = *bd_time; + SCM_ALLOW_INTS; +#endif + if (bd_time == NULL) + SCM_SYSERROR; + +#if HAVE_STRUCT_TM_TM_ZONE + zname = bd_buf.tm_zone; +#else + zname = "GMT"; +#endif + return filltime (&bd_buf, 0, zname); +} +#undef FUNC_NAME + +/* copy time components from a Scheme object to a struct tm. */ +static void +bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) +{ + SCM const *velts; + int i; + + SCM_ASSERT (SCM_VECTORP (sbd_time) + && SCM_VECTOR_LENGTH (sbd_time) == 11, + sbd_time, pos, subr); + velts = SCM_VELTS (sbd_time); + for (i = 0; i < 10; i++) + { + SCM_ASSERT (scm_is_integer (velts[i]), sbd_time, pos, subr); + } + SCM_ASSERT (scm_is_false (velts[10]) || scm_is_string (velts[10]), + sbd_time, pos, subr); + + lt->tm_sec = scm_to_int (velts[0]); + lt->tm_min = scm_to_int (velts[1]); + lt->tm_hour = scm_to_int (velts[2]); + lt->tm_mday = scm_to_int (velts[3]); + lt->tm_mon = scm_to_int (velts[4]); + lt->tm_year = scm_to_int (velts[5]); + lt->tm_wday = scm_to_int (velts[6]); + lt->tm_yday = scm_to_int (velts[7]); + lt->tm_isdst = scm_to_int (velts[8]); +#ifdef HAVE_TM_ZONE + lt->tm_gmtoff = scm_to_int (velts[9]); + if (scm_is_false (velts[10])) + lt->tm_zone = NULL; + else + lt->tm_zone = scm_to_locale_string (velts[10]); +#endif +} + +SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, + (SCM sbd_time, SCM zone), + "@var{bd-time} is an object representing broken down time and @code{zone}\n" + "is an optional time zone specifier (otherwise the TZ environment variable\n" + "or the system default is used).\n\n" + "Returns a pair: the car is a corresponding\n" + "integer time value like that returned\n" + "by @code{current-time}; the cdr is a broken down time object, similar to\n" + "as @var{bd-time} but with normalized values.") +#define FUNC_NAME s_scm_mktime +{ + timet itime; + struct tm lt, *utc; + SCM result; + int zoff; + char *zname = 0; + char **oldenv; + int err; + + scm_frame_begin (0); + + bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME); +#if HAVE_STRUCT_TM_TM_ZONE + scm_frame_free ((char *)lt.tm_zone); +#endif + + SCM_DEFER_INTS; + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); +#ifdef LOCALTIME_CACHE + tzset (); +#endif + itime = mktime (<); + /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it + doesn't. Force a sensible value for our error message. */ + err = EINVAL; + + if (itime != -1) + { + const char *ptr; + + /* copy zone name before calling gmtime or restoring the zone. */ +#if defined (HAVE_TM_ZONE) + ptr = lt.tm_zone; +#elif defined (HAVE_TZNAME) + ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; +#else + ptr = ""; +#endif + zname = scm_malloc (strlen (ptr) + 1); + strcpy (zname, ptr); + } + + /* get timezone offset in seconds west of UTC. */ + /* POSIX says gmtime sets errno, but C99 doesn't say that. + Give a sensible default value in case gmtime doesn't set it. */ + utc = gmtime (&itime); + if (utc == NULL) + err = errno; + + restorezone (zone, oldenv, FUNC_NAME); + /* delayed until zone has been restored. */ + errno = err; + if (utc == NULL || itime == -1) + SCM_SYSERROR; + + zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60 + + utc->tm_sec - lt.tm_sec; + if (utc->tm_year < lt.tm_year) + zoff -= 24 * 60 * 60; + else if (utc->tm_year > lt.tm_year) + zoff += 24 * 60 * 60; + else if (utc->tm_yday < lt.tm_yday) + zoff -= 24 * 60 * 60; + else if (utc->tm_yday > lt.tm_yday) + zoff += 24 * 60 * 60; + + result = scm_cons (scm_from_long (itime), + filltime (<, zoff, zname)); + SCM_ALLOW_INTS; + if (zname) + free (zname); + + scm_frame_end (); + return result; +} +#undef FUNC_NAME + +#ifdef HAVE_TZSET +SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0, + (void), + "Initialize the timezone from the TZ environment variable\n" + "or the system default. It's not usually necessary to call this procedure\n" + "since it's done automatically by other procedures that depend on the\n" + "timezone.") +#define FUNC_NAME s_scm_tzset +{ + tzset(); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif /* HAVE_TZSET */ + +SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, + (SCM format, SCM stime), + "Formats a time specification @var{time} using @var{template}. @var{time}\n" + "is an object with time components in the form returned by @code{localtime}\n" + "or @code{gmtime}. @var{template} is a string which can include formatting\n" + "specifications introduced by a @code{%} character. The formatting of\n" + "month and day names is dependent on the current locale. The value returned\n" + "is the formatted string.\n" + "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)") +#define FUNC_NAME s_scm_strftime +{ + struct tm t; + + char *tbuf; + int size = 50; + const char *fmt; + char *myfmt; + int len; + SCM result; + + SCM_VALIDATE_STRING (1, format); + bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); + + fmt = scm_i_string_chars (format); + len = scm_i_string_length (format); + + /* Ugly hack: strftime can return 0 if its buffer is too small, + but some valid time strings (e.g. "%p") can sometimes produce + a zero-byte output string! Workaround is to prepend a junk + character to the format string, so that valid returns are always + nonzero. */ + myfmt = scm_malloc (len+2); + *myfmt = 'x'; + strncpy(myfmt+1, fmt, len); + myfmt[len+1] = 0; + + tbuf = scm_malloc (size); + { +#if !defined (HAVE_TM_ZONE) + /* it seems the only way to tell non-GNU versions of strftime what + zone to use (for the %Z format) is to set TZ in the + environment. interrupts and thread switching must be deferred + until TZ is restored. */ + char **oldenv = NULL; + SCM *velts = (SCM *) SCM_VELTS (stime); + int have_zone = 0; + + if (scm_is_true (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0) + { + /* it's not required that the TZ setting be correct, just that + it has the right name. so try something like TZ=EST0. + using only TZ=EST would be simpler but it doesn't work on + some OSs, e.g., Solaris. */ + SCM zone = + scm_string_append (scm_cons (velts[10], + scm_cons (scm_from_locale_string ("0"), + SCM_EOL))); + + have_zone = 1; + SCM_DEFER_INTS; + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); + } +#endif + +#ifdef LOCALTIME_CACHE + tzset (); +#endif + + /* POSIX says strftime returns 0 on buffer overrun, but old + systems (i.e. libc 4 on GNU/Linux) might return `size' in that + case. */ + while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size) + { + free (tbuf); + size *= 2; + tbuf = scm_malloc (size); + } + +#if !defined (HAVE_TM_ZONE) + if (have_zone) + { + restorezone (velts[10], oldenv, FUNC_NAME); + SCM_ALLOW_INTS; + } +#endif + } + + result = scm_from_locale_stringn (tbuf + 1, len - 1); + free (tbuf); + free (myfmt); + return result; +} +#undef FUNC_NAME + +#ifdef HAVE_STRPTIME +SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, + (SCM format, SCM string), + "Performs the reverse action to @code{strftime}, parsing\n" + "@var{string} according to the specification supplied in\n" + "@var{template}. The interpretation of month and day names is\n" + "dependent on the current locale. The value returned is a pair.\n" + "The car has an object with time components\n" + "in the form returned by @code{localtime} or @code{gmtime},\n" + "but the time zone components\n" + "are not usefully set.\n" + "The cdr reports the number of characters from @var{string}\n" + "which were used for the conversion.") +#define FUNC_NAME s_scm_strptime +{ + struct tm t; + const char *fmt, *str, *rest; + + SCM_VALIDATE_STRING (1, format); + SCM_VALIDATE_STRING (2, string); + + fmt = scm_i_string_chars (format); + str = scm_i_string_chars (string); + + /* initialize the struct tm */ +#define tm_init(field) t.field = 0 + tm_init (tm_sec); + tm_init (tm_min); + tm_init (tm_hour); + tm_init (tm_mday); + tm_init (tm_mon); + tm_init (tm_year); + tm_init (tm_wday); + tm_init (tm_yday); +#undef tm_init + + /* GNU glibc strptime() "%s" is affected by the current timezone, since it + reads a UTC time_t value and converts with localtime_r() to set the tm + fields, hence the use of SCM_DEFER_INTS. */ + t.tm_isdst = -1; + SCM_DEFER_INTS; + rest = strptime (str, fmt, &t); + SCM_ALLOW_INTS; + if (rest == NULL) + { + /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for + instance it doesn't. Force a sensible value for our error + message. */ + errno = EINVAL; + SCM_SYSERROR; + } + + return scm_cons (filltime (&t, 0, NULL), + scm_from_signed_integer (rest - str)); +} +#undef FUNC_NAME +#endif /* HAVE_STRPTIME */ + +void +scm_init_stime() +{ + scm_c_define ("internal-time-units-per-second", + scm_from_long (SCM_TIME_UNITS_PER_SECOND)); + +#ifdef HAVE_FTIME + if (!scm_your_base.time) ftime(&scm_your_base); +#else + if (!scm_your_base) time(&scm_your_base); +#endif + + if (!scm_my_base) scm_my_base = mytime(); + + scm_add_feature ("current-time"); +#include "libguile/stime.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/