[bpt/guile.git] / libguile / stime.c

/*	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, 675 Mass Ave, Cambridge, MA 02139, 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.  
 */
\f

#include <stdio.h>
#include "_scm.h"
#include "feature.h"
#include "sequences.h"

#include "stime.h"

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

\f
# ifdef HAVE_SYS_TYPES_H
#  include <sys/types.h>
# endif

# ifdef TIME_WITH_SYS_TIME
#  include <sys/time.h>
#  include <time.h>
# else
#  ifdef HAVE_SYS_TIME_H
#   include <sys/time.h>
#  else
#   ifdef HAVE_TIME_H
#    include <time.h>
#   endif
#  endif
# endif

# ifdef HAVE_SYS_TIMES_H
#  include <sys/times.h>
# else
#  ifdef HAVE_SYS_TIMEB_H
#   include <sys/timeb.h>
#  endif
# 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 <sys/times.h>
#   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 HAVE_FTIME
#   include <sys/timeb.h>
# 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_STRINGP (zone), zone, pos, subr);
      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_CHARS (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 *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);
  lt = localtime (&itime);
  err = errno;
  utc = gmtime (&itime);
  if (utc == NULL)
    err = errno;
  if (lt)
    {
#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);
#endif
#endif
    }
  restorezone (zone, oldtz);
  /* delayed until zone has been restored.  */
  errno = err;
  if (utc == NULL || lt == 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 (lt, 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, &lt, SCM_ARG1, s_mktime);

  SCM_DEFER_INTS;
  oldtz = setzone (zone, SCM_ARG2, s_mktime);
  itime = mktime (&lt);
  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);
#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 (&lt, 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_STRINGP (format), format, SCM_ARG1,
	      s_strftime);
  bdtime2c (stime, &t, SCM_ARG2, s_strftime);

  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);

  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"
}
Commit	Line	Data
19468eff	1	/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
0f2d19dd JB	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program 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
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
	15	* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	16	*
	17	* As a special exception, the Free Software Foundation gives permission
	18	* for additional uses of the text contained in its release of GUILE.
	19	*
	20	* The exception is that, if you link the GUILE library with other files
	21	* to produce an executable, this does not by itself cause the
	22	* resulting executable to be covered by the GNU General Public License.
	23	* Your use of that executable is in no way restricted on account of
	24	* linking the GUILE library code into it.
	25	*
	26	* This exception does not however invalidate any other reasons why
	27	* the executable file might be covered by the GNU General Public License.
	28	*
	29	* This exception applies only to the code released by the
	30	* Free Software Foundation under the name GUILE. If you copy
	31	* code from other Free Software Foundation releases into a copy of
	32	* GUILE, as the General Public License permits, the exception does
	33	* not apply to the code that you add in this way. To avoid misleading
	34	* anyone as to the status of such modified files, you must delete
	35	* this exception notice from them.
	36	*
	37	* If you write modifications of your own for GUILE, it is your choice
	38	* whether to permit this exception to apply to your modifications.
	39	* If you do not wish that, delete this exception notice.
	40	*/
	41	\f
	42
	43	#include <stdio.h>
	44	#include "_scm.h"
876c87ce	45	#include "feature.h"
b9525b92	46	#include "sequences.h"
20e6290e JB	47
	48	#include "stime.h"
	49
0f2d19dd JB	50	#ifdef HAVE_UNISTD_H
	51	#include <unistd.h>
	52	#endif
	53
	54	\f
	55	# ifdef HAVE_SYS_TYPES_H
	56	# include <sys/types.h>
	57	# endif
	58
	59	# ifdef TIME_WITH_SYS_TIME
	60	# include <sys/time.h>
	61	# include <time.h>
	62	# else
	63	# ifdef HAVE_SYS_TIME_H
	64	# include <sys/time.h>
	65	# else
	66	# ifdef HAVE_TIME_H
	67	# include <time.h>
	68	# endif
	69	# endif
	70	# endif
	71
	72	# ifdef HAVE_SYS_TIMES_H
	73	# include <sys/times.h>
	74	# else
	75	# ifdef HAVE_SYS_TIMEB_H
	76	# include <sys/timeb.h>
	77	# endif
	78	# endif
	79
b9525b92 GH	80	#ifndef tzname /* For SGI. */
	81	extern char tzname[]; / RS6000 and others reject char *tzname. /
	82	#endif
	83
	84	char *strptime ();
	85
cda55316	86	/* This should be figured out by autoconf. */
0f2d19dd JB	87	#ifdef CLK_TCK
	88	# define CLKTCK CLK_TCK
	89	# ifdef CLOCKS_PER_SEC
cda55316	90	# if defined (unix) \|\| defined (__unix)
0f2d19dd JB	91	# ifndef ARM_ULIB
	92	# include <sys/times.h>
	93	# endif
	94	# define LACK_CLOCK
	95	/* This is because clock() might be POSIX rather than ANSI.
	96	This occurs on HP-UX machines */
	97	# endif
	98	# endif
	99	#else
	100	# ifdef CLOCKS_PER_SEC
	101	# define CLKTCK CLOCKS_PER_SEC
	102	# else
	103	# define LACK_CLOCK
	104	# define CLKTCK 60
	105	# endif
	106	#endif
	107
	108
	109	# ifdef HAVE_FTIME
	110	# include <sys/timeb.h>
	111	# endif
	112
	113
	114	#ifdef __STDC__
	115	# define timet time_t
	116	#else
	117	# define timet long
	118	#endif
	119
	120	#ifdef HAVE_TIMES
0f2d19dd JB	121	static
0f2d19dd JB	122	long mytime()
0f2d19dd JB	123	{
	124	struct tms time_buffer;
	125	times(&time_buffer);
	126	return time_buffer.tms_utime + time_buffer.tms_stime;
	127	}
	128	#else
	129	# ifdef LACK_CLOCK
	130	# define mytime() ((time((timet)0) - scm_your_base) CLKTCK)
	131	# else
	132	# define mytime clock
	133	# endif
	134	#endif
	135
19468eff	136	extern int errno;
0f2d19dd JB	137
	138	#ifdef HAVE_FTIME
	139
23858ad1 MD	140	extern int ftime (struct timeb *);
23858ad1 MD	141
0f2d19dd JB	142	struct timeb scm_your_base = {0};
0f2d19dd JB	143	SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
0f2d19dd JB	144	SCM
0f2d19dd JB	145	scm_get_internal_real_time()
0f2d19dd JB	146	{
	147	struct timeb time_buffer;
	148	long tmp;
	149	ftime(&time_buffer);
	150	time_buffer.time -= scm_your_base.time;
	151	tmp = time_buffer.millitm - scm_your_base.millitm;
	152	tmp = time_buffer.time*1000L + tmp;
	153	tmp *= CLKTCK;
	154	tmp /= 1000;
19468eff	155	return scm_long2num (tmp);
0f2d19dd JB	156	}
	157
	158	#else
	159
	160	timet scm_your_base = 0;
	161	SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
0f2d19dd JB	162	SCM
0f2d19dd JB	163	scm_get_internal_real_time()
0f2d19dd	164	{
19468eff	165	return scm_long2num((time((timet)0) - scm_your_base) (int)CLKTCK);
0f2d19dd JB	166	}
	167	#endif
	168
	169
	170
	171	static long scm_my_base = 0;
	172
	173	SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
0f2d19dd JB	174	SCM
0f2d19dd JB	175	scm_get_internal_run_time()
0f2d19dd	176	{
19468eff	177	return scm_long2num(mytime()-scm_my_base);
0f2d19dd JB	178	}
	179
	180	SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
0f2d19dd JB	181	SCM
0f2d19dd JB	182	scm_current_time()
0f2d19dd	183	{
19468eff GH	184	timet timv;
	185
	186	SCM_DEFER_INTS;
	187	if ((timv = time (0)) == -1)
	188	scm_syserror (s_current_time);
	189	SCM_ALLOW_INTS;
	190	return scm_long2num((long) timv);
	191	}
	192
1bf9865d	193	SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
19468eff	194	SCM
1bf9865d	195	scm_gettimeofday (void)
19468eff GH	196	{
	197	#ifdef HAVE_GETTIMEOFDAY
	198	struct timeval time;
	199
	200	SCM_DEFER_INTS;
	201	if (gettimeofday (&time, NULL) == -1)
1bf9865d	202	scm_syserror (s_gettimeofday);
19468eff GH	203	SCM_ALLOW_INTS;
	204	return scm_cons (scm_long2num ((long) time.tv_sec),
	205	scm_long2num ((long) time.tv_usec));
	206	#else
	207	# ifdef HAVE_FTIME
	208	struct timeb time;
	209
	210	ftime(&time);
	211	return scm_cons (scm_long2num ((long) time.time),
9a81afca	212	SCM_MAKINUM (time.millitm * 1000));
19468eff GH	213	# else
	214	timet timv;
	215
	216	SCM_DEFER_INTS;
	217	if ((timv = time (0)) == -1)
1bf9865d	218	scm_syserror (s_gettimeofday);
19468eff GH	219	SCM_ALLOW_INTS;
	220	return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
	221	# endif
	222	#endif
	223	}
	224
	225	static SCM
	226	filltime (struct tm bd_time, int zoff, char zname)
	227	{
	228	SCM result = scm_make_vector(SCM_MAKINUM(11), SCM_UNDEFINED, SCM_UNDEFINED);
	229
	230	SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
	231	SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
	232	SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
	233	SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
	234	SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
	235	SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
	236	SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
	237	SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
	238	SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
	239	SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
b9525b92	240	SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
19468eff GH	241	return result;
	242	}
	243
b9525b92 GH	244	static char *
	245	setzone (SCM zone, int pos, char *subr)
	246	{
	247	char *oldtz = 0;
	248
	249	if (!SCM_UNBNDP (zone))
	250	{
	251	char *buf;
	252
	253	/* if zone was supplied, set the environment variable TZ temporarily. */
	254	SCM_ASSERT (SCM_NIMP (zone) && SCM_STRINGP (zone), zone, pos, subr);
	255	buf = malloc (SCM_LENGTH (zone) + 4);
	256	if (buf == 0)
	257	scm_memory_error (subr);
	258	oldtz = getenv ("TZ");
	259	if (oldtz != NULL)
	260	oldtz = oldtz - 3;
	261	sprintf (buf, "TZ=%s", SCM_CHARS (zone));
	262	if (putenv (buf) < 0)
	263	scm_syserror (subr);
	264	tzset();
	265	}
	266	return oldtz;
	267	}
	268
	269	static void
	270	restorezone (SCM zone, char *oldzone)
	271	{
	272	if (!SCM_UNBNDP (zone))
	273	{
	274	int rv;
	275
	276	if (oldzone)
	277	rv = putenv (oldzone);
	278	else
	279	rv = putenv ("TZ");
	280	if (rv < 0)
	281	scm_syserror ("restorezone");
	282	tzset();
	283	}
	284	}
	285
	286
19468eff GH	287	SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
	288	SCM
	289	scm_localtime (SCM time, SCM zone)
	290	{
	291	timet itime;
	292	struct tm lt, utc;
	293	SCM result;
	294	int zoff;
	295	char *zname = 0;
b9525b92	296	char *oldtz;
19468eff GH	297	int err;
	298
	299	itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
	300	SCM_DEFER_INTS;
b9525b92	301	oldtz = setzone (zone, SCM_ARG2, s_localtime);
19468eff GH	302	lt = localtime (&itime);
	303	err = errno;
	304	utc = gmtime (&itime);
	305	if (utc == NULL)
	306	err = errno;
	307	if (lt)
	308	{
b9525b92 GH	309	#ifdef HAVE_TM_ZONE
	310	zname = lt->tm_zone;
	311	#else
	312	# ifdef HAVE_TZNAME
19468eff GH	313	/* must be copied before calling tzset again. */
	314	char *ptr = tzname[ (lt->tm_isdst == 1) ? 1 : 0 ];
	315
	316	zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
	317	strcpy (zname, ptr);
b9525b92 GH	318	#endif
b9525b92 GH	319	#endif
19468eff	320	}
b9525b92 GH	321	restorezone (zone, oldtz);
b9525b92 GH	322	/* delayed until zone has been restored. */
19468eff	323	errno = err;
b9525b92	324	if (utc == NULL \|\| lt == NULL)
19468eff GH	325	scm_syserror (s_localtime);
	326
	327	/* calculate timezone offset in seconds west of UTC. */
	328	zoff = (utc->tm_hour - lt->tm_hour) * 3600 + (utc->tm_min - lt->tm_min) * 60
	329	+ utc->tm_sec - lt->tm_sec;
	330	if (utc->tm_year < lt->tm_year)
	331	zoff -= 24 * 60 * 60;
	332	else if (utc->tm_year > lt->tm_year)
	333	zoff += 24 * 60 * 60;
	334	else if (utc->tm_yday < lt->tm_yday)
	335	zoff -= 24 * 60 * 60;
	336	else if (utc->tm_yday > lt->tm_yday)
	337	zoff += 24 * 60 * 60;
	338
	339	result = filltime (lt, zoff, zname);
	340	SCM_ALLOW_INTS;
	341	return result;
	342	}
19468eff GH	343
	344	SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
	345	SCM
	346	scm_gmtime (SCM time)
	347	{
	348	timet itime;
	349	struct tm *bd_time;
	350	SCM result;
	351
	352	itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
	353	SCM_DEFER_INTS;
	354	bd_time = gmtime (&itime);
	355	if (bd_time == NULL)
	356	scm_syserror (s_gmtime);
	357	result = filltime (bd_time, 0, "GMT");
	358	SCM_ALLOW_INTS;
	359	return result;
	360	}
	361
b9525b92 GH	362	/* copy time components from a Scheme object to a struct tm. */
	363	static void
	364	bdtime2c (SCM sbd_time, struct tm lt, int pos, char subr)
19468eff	365	{
b9525b92 GH	366	SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
	367	&& scm_obj_length (sbd_time) == 11
	368	&& SCM_INUMP (SCM_VELTS (sbd_time)[0])
19468eff GH	369	&& SCM_INUMP (SCM_VELTS (sbd_time)[1])
	370	&& SCM_INUMP (SCM_VELTS (sbd_time)[2])
	371	&& SCM_INUMP (SCM_VELTS (sbd_time)[3])
	372	&& SCM_INUMP (SCM_VELTS (sbd_time)[4])
	373	&& SCM_INUMP (SCM_VELTS (sbd_time)[5])
b9525b92 GH	374	&& SCM_INUMP (SCM_VELTS (sbd_time)[6])
b9525b92 GH	375	&& SCM_INUMP (SCM_VELTS (sbd_time)[7])
19468eff	376	&& SCM_INUMP (SCM_VELTS (sbd_time)[8]),
b9525b92 GH	377	sbd_time, pos, subr);
	378	lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]);
	379	lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]);
	380	lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]);
	381	lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]);
	382	lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]);
	383	lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]);
	384	lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]);
	385	lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]);
	386	lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
	387	}
	388
	389	SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
	390	SCM
	391	scm_mktime (SCM sbd_time, SCM zone)
	392	{
	393	timet itime;
	394	struct tm lt, *utc;
	395	SCM result;
	396	int zoff;
	397	char *zname = 0;
	398	char *oldtz = 0;
	399	int err;
	400
	401	SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time,
	402	SCM_ARG1, s_mktime);
	403	bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);
19468eff GH	404
19468eff GH	405	SCM_DEFER_INTS;
b9525b92	406	oldtz = setzone (zone, SCM_ARG2, s_mktime);
19468eff	407	itime = mktime (&lt);
b9525b92	408	err = errno;
19468eff GH	409
	410	/* timezone offset in seconds west of UTC. */
	411	utc = gmtime (&itime);
b9525b92 GH	412	if (utc == NULL)
	413	err = errno;
	414
	415	if (itime != -1)
	416	{
	417	#ifdef HAVE_TM_ZONE
73f19016	418	zname = lt.tm_zone;
b9525b92 GH	419	#else
	420	# ifdef HAVE_TZNAME
	421	/* must be copied before calling tzset again. */
	422	char *ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
	423
	424	zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
	425	strcpy (zname, ptr);
	426	#endif
	427	#endif
	428	}
	429	restorezone (zone, oldtz);
	430	/* delayed until zone has been restored. */
	431	errno = err;
	432	if (utc == NULL \|\| itime == -1)
	433	scm_syserror (s_mktime);
	434
19468eff GH	435	zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
	436	+ utc->tm_sec - lt.tm_sec;
	437	if (utc->tm_year < lt.tm_year)
	438	zoff -= 24 * 60 * 60;
	439	else if (utc->tm_year > lt.tm_year)
	440	zoff += 24 * 60 * 60;
	441	else if (utc->tm_yday < lt.tm_yday)
	442	zoff -= 24 * 60 * 60;
	443	else if (utc->tm_yday > lt.tm_yday)
	444	zoff += 24 * 60 * 60;
	445
19468eff GH	446	result = scm_cons (scm_long2num ((long) itime),
	447	filltime (&lt, zoff, zname));
	448	SCM_ALLOW_INTS;
	449	return result;
0f2d19dd JB	450	}
0f2d19dd JB	451
19468eff GH	452	SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
	453	SCM
	454	scm_tzset (void)
0f2d19dd	455	{
19468eff GH	456	tzset();
19468eff GH	457	return SCM_UNSPECIFIED;
0f2d19dd JB	458	}
0f2d19dd JB	459
b9525b92 GH	460	SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
	461
	462	SCM
	463	scm_strftime (format, stime)
	464	SCM format;
	465	SCM stime;
	466	{
	467	struct tm t;
	468
	469	char *tbuf;
	470	int size = 50;
	471	char *fmt;
	472	int len;
	473
	474	SCM_ASSERT (SCM_NIMP (format) && SCM_STRINGP (format), format, SCM_ARG1,
	475	s_strftime);
	476	bdtime2c (stime, &t, SCM_ARG2, s_strftime);
	477
	478	fmt = SCM_ROCHARS (format);
	479	len = SCM_ROLENGTH (format);
	480
	481	tbuf = scm_must_malloc (size, s_strftime);
	482	while ((len = strftime (tbuf, size, fmt, &t)) == size)
	483	{
	484	scm_must_free (tbuf);
	485	size *= 2;
	486	tbuf = scm_must_malloc (size, s_strftime);
	487	}
	488	return scm_makfromstr (tbuf, len, 0);
	489	}
	490
	491	SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
	492
	493	SCM
	494	scm_strptime (format, string)
	495	SCM format;
	496	SCM string;
	497	{
	498	#ifdef HAVE_STRPTIME
	499	struct tm t;
	500	char fmt, str, *rest;
	501
	502	SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
	503	s_strptime);
	504	SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
	505	s_strptime);
	506
	507	fmt = SCM_ROCHARS (format);
	508	str = SCM_ROCHARS (string);
	509
	510	/* initialize the struct tm */
	511	#define tm_init(field) t.field = 0
	512	tm_init (tm_sec);
	513	tm_init (tm_min);
	514	tm_init (tm_hour);
	515	tm_init (tm_mday);
	516	tm_init (tm_mon);
	517	tm_init (tm_year);
	518	tm_init (tm_wday);
	519	tm_init (tm_yday);
	520	#undef tm_init
	521
	522	t.tm_isdst = -1;
	523	SCM_DEFER_INTS;
524	if ((rest = strptime (str, fmt, &t)) == NULL)
525	scm_syserror (s_strptime);
526
527	SCM_ALLOW_INTS;
528	return scm_cons (filltime (&t, 0, NULL), SCM_MAKINUM (rest - str));
529
530	#else
531	scm_sysmissing (s_strptime);
532	#endif
533	}
534
0f2d19dd JB	535	void
0f2d19dd JB	536	scm_init_stime()
0f2d19dd JB	537	{
0f2d19dd JB	538	scm_sysintern("internal-time-units-per-second",
19468eff	539	scm_long2num((long)CLKTCK));
0f2d19dd JB	540
	541	#ifdef HAVE_FTIME
	542	if (!scm_your_base.time) ftime(&scm_your_base);
	543	#else
	544	if (!scm_your_base) time(&scm_your_base);
	545	#endif
	546
	547	if (!scm_my_base) scm_my_base = mytime();
	548
876c87ce	549	scm_add_feature ("current-time");
0f2d19dd JB	550	#include "stime.x"
	551	}
	552