libguile/stime.c

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