guile/libguile/stime.c

/* Copyright (C) 1995,1996,1997,1998, 1999 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.  */

/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
   gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */



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

#include "scm_validate.h"
#include "stime.h"

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


# 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>
#endif

#ifdef HAVE_SYS_TIMEB_H
# include <sys/timeb.h>
#endif

#ifndef tzname /* For SGI.  */
extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
#endif

#ifdef MISSING_STRPTIME_DECL
extern char *strptime ();
#endif

/* This should be figured out by autoconf.  */
#if ! defined(CLKTCK) && defined(CLK_TCK)
#  define CLKTCK CLK_TCK
#endif
#if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
#  define CLKTCK CLOCKS_PER_SEC
#endif
#if ! defined(CLKTCK)
#  define CLKTCK 60
#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

struct timeb scm_your_base = {0};

GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, 
           (),
"")
#define FUNC_NAME s_scm_get_internal_real_time
{
  struct timeb time_buffer;

  SCM tmp;
  ftime (&time_buffer);
  time_buffer.time -= scm_your_base.time;
  tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
  tmp = scm_sum (tmp,
		 scm_product (SCM_MAKINUM (1000),
			      SCM_MAKINUM (time_buffer.time)));
  return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
		       SCM_MAKINUM (1000));
}
#undef FUNC_NAME


#else

timet scm_your_base = 0;

GUILE_PROC(scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0, 
           (),
           "")
#define FUNC_NAME s_scm_get_internal_real_time
{
  return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
}
#undef FUNC_NAME

#endif

GUILE_PROC (scm_times, "times", 0, 0, 0, 
            (void),
"")
#define FUNC_NAME s_scm_times
{
#ifdef HAVE_TIMES
  struct tms t;
  clock_t rv;

  SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
  rv = times (&t);
  if (rv == -1)
    SCM_SYSERROR;
  SCM_VELTS (result)[0] = scm_long2num (rv);
  SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
  SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
  SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
  SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
  return result;
#else
  SCM_SYSMISSING;
#endif
}
#undef FUNC_NAME

#ifndef HAVE_TZSET
/* GNU-WIN32's cygwin.dll doesn't have this. */
#define tzset()
#endif


static long scm_my_base = 0;

GUILE_PROC(scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0, 
           (void),
"")
#define FUNC_NAME s_scm_get_internal_run_time
{
  return scm_long2num(mytime()-scm_my_base);
}
#undef FUNC_NAME

GUILE_PROC(scm_current_time, "current-time", 0, 0, 0, 
           (void),
"")
#define FUNC_NAME s_scm_current_time
{
  timet timv;

  SCM_DEFER_INTS;
  if ((timv = time (0)) == -1)
    SCM_SYSERROR;
  SCM_ALLOW_INTS;
  return scm_long2num((long) timv);
}
#undef FUNC_NAME

GUILE_PROC (scm_gettimeofday, "gettimeofday", 0, 0, 0, 
            (void),
            "")
#define FUNC_NAME s_scm_gettimeofday
{
#ifdef HAVE_GETTIMEOFDAY
  struct timeval time;

  SCM_DEFER_INTS;
  if (gettimeofday (&time, NULL) == -1)
    SCM_SYSERROR;
  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;
  SCM_ALLOW_INTS;
  return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
# endif
#endif
}
#undef FUNC_NAME

static SCM
filltime (struct tm *bd_time, int zoff, char *zname)
{
  SCM result = scm_make_vector (SCM_MAKINUM(11), 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 tzvar[3] = "TZ";
extern char ** environ;

static char **
setzone (SCM zone, int pos, const char *subr)
{
  char **oldenv = 0;

  if (!SCM_UNBNDP (zone))
    {
      static char *tmpenv[2];
      char *buf;

      /* if zone was supplied, set the environment temporarily.  */
      SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr);
      SCM_COERCE_SUBSTR (zone);
      buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1,
			     subr);
      sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone));
      oldenv = environ;
      tmpenv[0] = buf;
      tmpenv[1] = 0;
      environ = tmpenv;
      tzset();
    }
  return oldenv;
}

static void
restorezone (SCM zone, char **oldenv, const char *subr)
{
  if (!SCM_UNBNDP (zone))
    {
      scm_must_free (environ[0]);
      environ = oldenv;
      tzset();
    }
}


GUILE_PROC (scm_localtime, "localtime", 1, 1, 0, 
            (SCM time, SCM zone),
"")
#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);
  SCM_DEFER_INTS;
  oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
  ltptr = localtime (&itime);
  err = errno;
  if (ltptr)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or tzset.  */
#ifdef HAVE_TM_ZONE
      ptr = ltptr->tm_zone;
#else
# ifdef HAVE_TZNAME
      ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
# else
      SCM_MISC_ERROR ("Not fully implemented on this platform",_EOL);
# endif
#endif
      zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
      strcpy (zname, ptr);
    }
  /* the struct is copied in case localtime and gmtime share a buffer.  */
  if (ltptr)
    lt = *ltptr;
  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 (&lt, zoff, zname);
  SCM_ALLOW_INTS;
  scm_must_free (zname);
  return result;
}
#undef FUNC_NAME

GUILE_PROC (scm_gmtime, "gmtime", 1, 0, 0, 
            (SCM time),
"")
#define FUNC_NAME s_scm_gmtime
{
  timet itime;
  struct tm *bd_time;
  SCM result;

  itime = SCM_NUM2LONG (1,time);
  SCM_DEFER_INTS;
  bd_time = gmtime (&itime);
  if (bd_time == NULL)
    SCM_SYSERROR;
  result = filltime (bd_time, 0, "GMT");
  SCM_ALLOW_INTS;
  return result;
}
#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 *velts;
  int i;

  SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
	      && SCM_LENGTH (sbd_time) == 11,
	      sbd_time, pos, subr);
  velts = SCM_VELTS (sbd_time);
  for (i = 0; i < 10; i++)
    {
      SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr);
    }
  SCM_ASSERT (SCM_FALSEP (velts[10])
	      || (SCM_NIMP (velts[10]) && SCM_STRINGP (velts[10])),
	      sbd_time, pos, subr);

  lt->tm_sec = SCM_INUM (velts[0]);
  lt->tm_min = SCM_INUM (velts[1]);
  lt->tm_hour = SCM_INUM (velts[2]);
  lt->tm_mday = SCM_INUM (velts[3]);
  lt->tm_mon = SCM_INUM (velts[4]);
  lt->tm_year = SCM_INUM (velts[5]);
  lt->tm_wday = SCM_INUM (velts[6]);
  lt->tm_yday = SCM_INUM (velts[7]);
  lt->tm_isdst = SCM_INUM (velts[8]);
#ifdef HAVE_TM_ZONE
  lt->tm_gmtoff = SCM_INUM (velts[9]);
  if (SCM_FALSEP (velts[10]))
    lt->tm_zone = NULL;
  else
    lt->tm_zone  = SCM_CHARS (velts[10]);
#endif
}

GUILE_PROC (scm_mktime, "mktime", 1, 1, 0, 
            (SCM sbd_time, SCM zone),
"")
#define FUNC_NAME s_scm_mktime
{
  timet itime;
  struct tm lt, *utc;
  SCM result;
  int zoff;
  char *zname = 0;
  char **oldenv;
  int err;

  bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);

  SCM_DEFER_INTS;
  oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
  itime = mktime (&lt);
  err = errno;

  if (itime != -1)
    {
      const char *ptr;

      /* copy zone name before calling gmtime or tzset.  */
#ifdef HAVE_TM_ZONE
      ptr = lt.tm_zone;
#else
# ifdef HAVE_TZNAME
      ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
# else
      scm_misc_error (s_mktime, "Not fully implemented on this platform",
		      SCM_EOL);
# endif
#endif
      zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
      strcpy (zname, ptr);
    }

  /* get timezone offset in seconds west of UTC.  */
  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_long2num ((long) itime),
		     filltime (&lt, zoff, zname));
  SCM_ALLOW_INTS;
  scm_must_free (zname);
  return result;
}
#undef FUNC_NAME

GUILE_PROC (scm_tzset, "tzset", 0, 0, 0, 
            (void),
"")
#define FUNC_NAME s_scm_tzset
{
  tzset();
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

GUILE_PROC (scm_strftime, "strftime", 2, 0, 0,
            (SCM format, SCM stime),
"")
#define FUNC_NAME s_scm_strftime
{
  struct tm t;

  char *tbuf;
  int size = 50;
  char *fmt;
  int len;
  SCM result;

  SCM_VALIDATE_ROSTRING(1,format);
  bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);

  SCM_COERCE_SUBSTR (format);
  fmt = SCM_ROCHARS (format);
  len = SCM_ROLENGTH (format);

  tbuf = SCM_MUST_MALLOC (size);
  while ((len = strftime (tbuf, size, fmt, &t)) == size)
    {
      scm_must_free (tbuf);
      size *= 2;
      tbuf = SCM_MUST_MALLOC (size);
    }
  result = scm_makfromstr (tbuf, len, 0);
  scm_must_free (tbuf);
  return result;
}
#undef FUNC_NAME

GUILE_PROC (scm_strptime, "strptime", 2, 0, 0,
            (SCM format, SCM string),
"")
#define FUNC_NAME s_scm_strptime
{
#ifdef HAVE_STRPTIME
  struct tm t;
  char *fmt, *str, *rest;

  SCM_VALIDATE_ROSTRING(1,format);
  SCM_VALIDATE_ROSTRING(2,string);

  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;

  SCM_ALLOW_INTS;
  return scm_cons (filltime (&t, 0, NULL),  SCM_MAKINUM (rest - str));

#else
  SCM_SYSMISSING;
#endif
}
#undef FUNC_NAME

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"
}