libguile/stime.c

   1 /*      Copyright (C) 1995,1996,1997,1998 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
  47 #include "stime.h"
  48
  49 #ifdef HAVE_UNISTD_H
  50 #include <unistd.h>
  51 #endif
  52
  53 \f
  54 # ifdef HAVE_SYS_TYPES_H
  55 #  include <sys/types.h>
  56 # endif
  57
  58 # ifdef TIME_WITH_SYS_TIME
  59 #  include <sys/time.h>
  60 #  include <time.h>
  61 # else
  62 #  ifdef HAVE_SYS_TIME_H
  63 #   include <sys/time.h>
  64 #  else
  65 #   ifdef HAVE_TIME_H
  66 #    include <time.h>
  67 #   endif
  68 #  endif
  69 # endif
  70
  71 #ifdef HAVE_SYS_TIMES_H
  72 # include <sys/times.h>
  73 #endif
  74
  75 #ifdef HAVE_SYS_TIMEB_H
  76 # include <sys/timeb.h>
  77 #endif
  78
  79 #ifndef tzname /* For SGI.  */
  80 extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
  81 #endif
  82
  83 #ifdef MISSING_STRPTIME_DECL
  84 extern char *strptime ();
  85 #endif
  86
  87 /* This should be figured out by autoconf.  */
  88 #if ! defined(CLKTCK) && defined(CLK_TCK)
  89 #  define CLKTCK CLK_TCK
  90 #endif
  91 #if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
  92 #  define CLKTCK CLOCKS_PER_SEC
  93 #endif
  94 #if ! defined(CLKTCK)
  95 #  define CLKTCK 60
  96 #endif
  97
  98
  99 #ifdef __STDC__
 100 # define timet time_t
 101 #else
 102 # define timet long
 103 #endif
 104
 105 #ifdef HAVE_TIMES
 106 static
 107 long mytime()
 108 {
 109   struct tms time_buffer;
 110   times(&time_buffer);
 111   return time_buffer.tms_utime + time_buffer.tms_stime;
 112 }
 113 #else
 114 # ifdef LACK_CLOCK
 115 #    define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
 116 # else
 117 #  define mytime clock
 118 # endif
 119 #endif
 120
 121 extern int errno;
 122
 123 #ifdef HAVE_FTIME
 124
 125 extern int ftime (struct timeb *);
 126
 127 struct timeb scm_your_base = {0};
 128 SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
 129 SCM
 130 scm_get_internal_real_time()
 131 {
 132   struct timeb time_buffer;
 133
 134   SCM tmp;
 135   ftime (&time_buffer);
 136   time_buffer.time -= scm_your_base.time;
 137   tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
 138   tmp = scm_sum (tmp,
 139                  scm_product (SCM_MAKINUM (1000),
 140                               SCM_MAKINUM (time_buffer.time)));
 141   return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
 142                        SCM_MAKINUM (1000));
 143 };
 144
 145 #else
 146
 147 timet scm_your_base = 0;
 148 SCM_PROC(s_get_internal_real_time, "get-internal-real-time", 0, 0, 0, scm_get_internal_real_time);
 149 SCM
 150 scm_get_internal_real_time()
 151 {
 152   return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
 153 }
 154 #endif
 155
 156 SCM_PROC (s_times, "times", 0, 0, 0, scm_times);
 157 SCM
 158 scm_times (void)
 159 {
 160 #ifdef HAVE_TIMES
 161   struct tms t;
 162   clock_t rv;
 163
 164   SCM result = scm_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
 165   rv = times (&t);
 166   if (rv == -1)
 167     scm_syserror (s_times);
 168   SCM_VELTS (result)[0] = scm_long2num (rv);
 169   SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
 170   SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
 171   SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
 172   SCM_VELTS (result)[4] = scm_long2num (t.tms_cstime);
 173   return result;
 174 #else
 175   scm_sysmissing (s_times);
 176 #endif
 177 }
 178
 179 #ifndef HAVE_TZSET
 180 /* GNU-WIN32's cygwin.dll doesn't have this. */
 181 #define tzset()
 182 #endif
 183
 184
 185 static long scm_my_base = 0;
 186
 187 SCM_PROC(s_get_internal_run_time, "get-internal-run-time", 0, 0, 0, scm_get_internal_run_time);
 188 SCM
 189 scm_get_internal_run_time()
 190 {
 191   return scm_long2num(mytime()-scm_my_base);
 192 }
 193
 194 SCM_PROC(s_current_time, "current-time", 0, 0, 0, scm_current_time);
 195 SCM
 196 scm_current_time()
 197 {
 198   timet timv;
 199
 200   SCM_DEFER_INTS;
 201   if ((timv = time (0)) == -1)
 202     scm_syserror (s_current_time);
 203   SCM_ALLOW_INTS;
 204   return scm_long2num((long) timv);
 205 }
 206
 207 SCM_PROC (s_gettimeofday, "gettimeofday", 0, 0, 0, scm_gettimeofday);
 208 SCM
 209 scm_gettimeofday (void)
 210 {
 211 #ifdef HAVE_GETTIMEOFDAY
 212   struct timeval time;
 213
 214   SCM_DEFER_INTS;
 215   if (gettimeofday (&time, NULL) == -1)
 216     scm_syserror (s_gettimeofday);
 217   SCM_ALLOW_INTS;
 218   return scm_cons (scm_long2num ((long) time.tv_sec),
 219                    scm_long2num ((long) time.tv_usec));
 220 #else
 221 # ifdef HAVE_FTIME
 222   struct timeb time;
 223
 224   ftime(&time);
 225   return scm_cons (scm_long2num ((long) time.time),
 226                    SCM_MAKINUM (time.millitm * 1000));
 227 # else
 228   timet timv;
 229
 230   SCM_DEFER_INTS;
 231   if ((timv = time (0)) == -1)
 232     scm_syserror (s_gettimeofday);
 233   SCM_ALLOW_INTS;
 234   return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
 235 # endif
 236 #endif
 237 }
 238
 239 static SCM
 240 filltime (struct tm *bd_time, int zoff, char *zname)
 241 {
 242   SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED);
 243
 244   SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
 245   SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
 246   SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
 247   SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
 248   SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
 249   SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
 250   SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
 251   SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
 252   SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
 253   SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
 254   SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
 255   return result;
 256 }
 257
 258 static char tzvar[3] = "TZ";
 259 extern char ** environ;
 260
 261 static char **
 262 setzone (SCM zone, int pos, const char *subr)
 263 {
 264   char **oldenv = 0;
 265
 266   if (!SCM_UNBNDP (zone))
 267     {
 268       static char *tmpenv[2];
 269       char *buf;
 270
 271       /* if zone was supplied, set the environment temporarily.  */
 272       SCM_ASSERT (SCM_NIMP (zone) && SCM_ROSTRINGP (zone), zone, pos, subr);
 273       SCM_COERCE_SUBSTR (zone);
 274       buf = scm_must_malloc (SCM_LENGTH (zone) + sizeof (tzvar) + 1,
 275                              subr);
 276       sprintf (buf, "%s=%s", tzvar, SCM_ROCHARS (zone));
 277       oldenv = environ;
 278       tmpenv[0] = buf;
 279       tmpenv[1] = 0;
 280       environ = tmpenv;
 281       tzset();
 282     }
 283   return oldenv;
 284 }
 285
 286 static void
 287 restorezone (SCM zone, char **oldenv, const char *subr)
 288 {
 289   if (!SCM_UNBNDP (zone))
 290     {
 291       scm_must_free (environ[0]);
 292       environ = oldenv;
 293       tzset();
 294     }
 295 }
 296
 297
 298 SCM_PROC (s_localtime, "localtime", 1, 1, 0, scm_localtime);
 299 SCM
 300 scm_localtime (SCM time, SCM zone)
 301 {
 302   timet itime;
 303   struct tm *ltptr, lt, *utc;
 304   SCM result;
 305   int zoff;
 306   char *zname = 0;
 307   char **oldenv;
 308   int err;
 309
 310   itime = scm_num2long (time, (char *) SCM_ARG1, s_localtime);
 311   SCM_DEFER_INTS;
 312   oldenv = setzone (zone, SCM_ARG2, s_localtime);
 313   ltptr = localtime (&itime);
 314   err = errno;
 315   if (ltptr)
 316     {
 317       const char *ptr;
 318
 319       /* copy zone name before calling gmtime or tzset.  */
 320 #ifdef HAVE_TM_ZONE
 321       ptr = ltptr->tm_zone;
 322 #else
 323 # ifdef HAVE_TZNAME
 324       ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
 325 # else
 326       scm_misc_error (s_localtime, "Not fully implemented on this platform",
 327                       SCM_EOL);
 328 # endif
 329 #endif
 330       zname = scm_must_malloc (strlen (ptr) + 1, s_localtime);
 331       strcpy (zname, ptr);
 332     }
 333   /* the struct is copied in case localtime and gmtime share a buffer.  */
 334   if (ltptr)
 335     lt = *ltptr;
 336   utc = gmtime (&itime);
 337   if (utc == NULL)
 338     err = errno;
 339   restorezone (zone, oldenv, s_localtime);
 340   /* delayed until zone has been restored.  */
 341   errno = err;
 342   if (utc == NULL || ltptr == NULL)
 343     scm_syserror (s_localtime);
 344
 345   /* calculate timezone offset in seconds west of UTC.  */
 346   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 347     + utc->tm_sec - lt.tm_sec;
 348   if (utc->tm_year < lt.tm_year)
 349     zoff -= 24 * 60 * 60;
 350   else if (utc->tm_year > lt.tm_year)
 351     zoff += 24 * 60 * 60;
 352   else if (utc->tm_yday < lt.tm_yday)
 353     zoff -= 24 * 60 * 60;
 354   else if (utc->tm_yday > lt.tm_yday)
 355     zoff += 24 * 60 * 60;
 356
 357   result = filltime (&lt, zoff, zname);
 358   SCM_ALLOW_INTS;
 359   scm_must_free (zname);
 360   return result;
 361 }
 362
 363 SCM_PROC (s_gmtime, "gmtime", 1, 0, 0, scm_gmtime);
 364 SCM
 365 scm_gmtime (SCM time)
 366 {
 367   timet itime;
 368   struct tm *bd_time;
 369   SCM result;
 370
 371   itime = scm_num2long (time, (char *) SCM_ARG1, s_gmtime);
 372   SCM_DEFER_INTS;
 373   bd_time = gmtime (&itime);
 374   if (bd_time == NULL)
 375     scm_syserror (s_gmtime);
 376   result = filltime (bd_time, 0, "GMT");
 377   SCM_ALLOW_INTS;
 378   return result;
 379 }
 380
 381 /* copy time components from a Scheme object to a struct tm.  */
 382 static void
 383 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
 384 {
 385   SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time)
 386               && SCM_LENGTH (sbd_time) == 11
 387               && SCM_INUMP (SCM_VELTS (sbd_time)[0])
 388               && SCM_INUMP (SCM_VELTS (sbd_time)[1])
 389               && SCM_INUMP (SCM_VELTS (sbd_time)[2])
 390               && SCM_INUMP (SCM_VELTS (sbd_time)[3])
 391               && SCM_INUMP (SCM_VELTS (sbd_time)[4])
 392               && SCM_INUMP (SCM_VELTS (sbd_time)[5])
 393               && SCM_INUMP (SCM_VELTS (sbd_time)[6])
 394               && SCM_INUMP (SCM_VELTS (sbd_time)[7])
 395               && SCM_INUMP (SCM_VELTS (sbd_time)[8]),
 396               sbd_time, pos, subr);
 397   lt->tm_sec = SCM_INUM (SCM_VELTS (sbd_time)[0]);
 398   lt->tm_min = SCM_INUM (SCM_VELTS (sbd_time)[1]);
 399   lt->tm_hour = SCM_INUM (SCM_VELTS (sbd_time)[2]);
 400   lt->tm_mday = SCM_INUM (SCM_VELTS (sbd_time)[3]);
 401   lt->tm_mon = SCM_INUM (SCM_VELTS (sbd_time)[4]);
 402   lt->tm_year = SCM_INUM (SCM_VELTS (sbd_time)[5]);
 403   lt->tm_wday = SCM_INUM (SCM_VELTS (sbd_time)[6]);
 404   lt->tm_yday = SCM_INUM (SCM_VELTS (sbd_time)[7]);
 405   lt->tm_isdst = SCM_INUM (SCM_VELTS (sbd_time)[8]);
 406 }
 407
 408 SCM_PROC (s_mktime, "mktime", 1, 1, 0, scm_mktime);
 409 SCM
 410 scm_mktime (SCM sbd_time, SCM zone)
 411 {
 412   timet itime;
 413   struct tm lt, *utc;
 414   SCM result;
 415   int zoff;
 416   char *zname = 0;
 417   char **oldenv;
 418   int err;
 419
 420   SCM_ASSERT (SCM_NIMP (sbd_time) && SCM_VECTORP (sbd_time), sbd_time,
 421               SCM_ARG1, s_mktime);
 422   bdtime2c (sbd_time, &lt, SCM_ARG1, s_mktime);
 423
 424   SCM_DEFER_INTS;
 425   oldenv = setzone (zone, SCM_ARG2, s_mktime);
 426   itime = mktime (&lt);
 427   err = errno;
 428
 429   if (itime != -1)
 430     {
 431       const char *ptr;
 432
 433       /* copy zone name before calling gmtime or tzset.  */
 434 #ifdef HAVE_TM_ZONE
 435       ptr = lt.tm_zone;
 436 #else
 437 # ifdef HAVE_TZNAME
 438       ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
 439 # else
 440       scm_misc_error (s_mktime, "Not fully implemented on this platform",
 441                       SCM_EOL);
 442 # endif
 443 #endif
 444       zname = scm_must_malloc (strlen (ptr) + 1, s_mktime);
 445       strcpy (zname, ptr);
 446     }
 447
 448   /* get timezone offset in seconds west of UTC.  */
 449   utc = gmtime (&itime);
 450   if (utc == NULL)
 451     err = errno;
 452
 453   restorezone (zone, oldenv, s_mktime);
 454   /* delayed until zone has been restored.  */
 455   errno = err;
 456   if (utc == NULL || itime == -1)
 457     scm_syserror (s_mktime);
 458
 459   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 460     + utc->tm_sec - lt.tm_sec;
 461   if (utc->tm_year < lt.tm_year)
 462     zoff -= 24 * 60 * 60;
 463   else if (utc->tm_year > lt.tm_year)
 464     zoff += 24 * 60 * 60;
 465   else if (utc->tm_yday < lt.tm_yday)
 466     zoff -= 24 * 60 * 60;
 467   else if (utc->tm_yday > lt.tm_yday)
 468     zoff += 24 * 60 * 60;
 469
 470   result = scm_cons (scm_long2num ((long) itime),
 471                      filltime (&lt, zoff, zname));
 472   SCM_ALLOW_INTS;
 473   scm_must_free (zname);
 474   return result;
 475 }
 476
 477 SCM_PROC (s_tzset, "tzset", 0, 0, 0, scm_tzset);
 478 SCM
 479 scm_tzset (void)
 480 {
 481   tzset();
 482   return SCM_UNSPECIFIED;
 483 }
 484
 485 SCM_PROC (s_strftime, "strftime", 2, 0, 0, scm_strftime);
 486
 487 SCM
 488 scm_strftime (format, stime)
 489      SCM format;
 490      SCM stime;
 491 {
 492   struct tm t;
 493
 494   char *tbuf;
 495   int size = 50;
 496   char *fmt;
 497   int len;
 498   SCM result;
 499
 500   SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
 501               s_strftime);
 502   bdtime2c (stime, &t, SCM_ARG2, s_strftime);
 503
 504   SCM_COERCE_SUBSTR (format);
 505   fmt = SCM_ROCHARS (format);
 506   len = SCM_ROLENGTH (format);
 507
 508   tbuf = scm_must_malloc (size, s_strftime);
 509   while ((len = strftime (tbuf, size, fmt, &t)) == size)
 510     {
 511       scm_must_free (tbuf);
 512       size *= 2;
 513       tbuf = scm_must_malloc (size, s_strftime);
 514     }
 515   result = scm_makfromstr (tbuf, len, 0);
 516   scm_must_free (tbuf);
 517   return result;
 518 }
 519
 520 SCM_PROC (s_strptime, "strptime", 2, 0, 0, scm_strptime);
 521
 522 SCM
 523 scm_strptime (format, string)
 524      SCM format;
 525      SCM string;
 526 {
 527 #ifdef HAVE_STRPTIME
 528   struct tm t;
 529   char *fmt, *str, *rest;
 530
 531   SCM_ASSERT (SCM_NIMP (format) && SCM_ROSTRINGP (format), format, SCM_ARG1,
 532               s_strptime);
 533   SCM_ASSERT (SCM_NIMP (string) && SCM_ROSTRINGP (string), string, SCM_ARG2,
 534               s_strptime);
 535
 536   SCM_COERCE_SUBSTR (format);
 537   SCM_COERCE_SUBSTR (string);
 538   fmt = SCM_ROCHARS (format);
 539   str = SCM_ROCHARS (string);
 540
 541   /* initialize the struct tm */
 542 #define tm_init(field) t.field = 0
 543   tm_init (tm_sec);
 544   tm_init (tm_min);
 545   tm_init (tm_hour);
 546   tm_init (tm_mday);
 547   tm_init (tm_mon);
 548   tm_init (tm_year);
 549   tm_init (tm_wday);
 550   tm_init (tm_yday);
 551 #undef tm_init
 552
 553   t.tm_isdst = -1;
 554   SCM_DEFER_INTS;
 555   if ((rest = strptime (str, fmt, &t)) == NULL)
 556     scm_syserror (s_strptime);
 557
 558   SCM_ALLOW_INTS;
 559   return scm_cons (filltime (&t, 0, NULL),  SCM_MAKINUM (rest - str));
 560
 561 #else
 562   scm_sysmissing (s_strptime);
 563 #endif
 564 }
 565
 566 void
 567 scm_init_stime()
 568 {
 569   scm_sysintern("internal-time-units-per-second",
 570                 scm_long2num((long)CLKTCK));
 571
 572 #ifdef HAVE_FTIME
 573   if (!scm_your_base.time) ftime(&scm_your_base);
 574 #else
 575   if (!scm_your_base) time(&scm_your_base);
 576 #endif
 577
 578   if (!scm_my_base) scm_my_base = mytime();
 579
 580   scm_add_feature ("current-time");
 581 #include "stime.x"
 582 }
 583