libguile/stime.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 /* _POSIX_C_SOURCE is not defined always, because it causes problems on some
  23    systems, notably
  24
  25        - FreeBSD loses all BSD and XOPEN defines.
  26        - glibc loses some things like CLK_TCK.
  27        - On MINGW it conflicts with the pthread headers.
  28
  29    But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r.
  30
  31    Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and
  32    what it takes away, and decide from that whether to use it, instead of
  33    hard coding __hpux.  */
  34
  35 #ifndef _REENTRANT
  36 # define _REENTRANT   /* ask solaris for gmtime_r prototype */
  37 #endif
  38 #ifdef __hpux
  39 #define _POSIX_C_SOURCE 199506L  /* for gmtime_r prototype */
  40 #endif
  41
  42 #ifdef HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <stdio.h>
  47 #include <errno.h>
  48 #include <strftime.h>
  49 #include <unistr.h>
  50
  51 #include "libguile/_scm.h"
  52 #include "libguile/async.h"
  53 #include "libguile/feature.h"
  54 #include "libguile/strings.h"
  55 #include "libguile/vectors.h"
  56 #include "libguile/dynwind.h"
  57 #include "libguile/strings.h"
  58
  59 #include "libguile/validate.h"
  60 #include "libguile/stime.h"
  61
  62 #ifdef HAVE_UNISTD_H
  63 #include <unistd.h>
  64 #endif
  65
  66 \f
  67 #ifdef HAVE_CLOCK_GETTIME
  68 # include <time.h>
  69 #endif
  70
  71 #include <sys/types.h>
  72 #include <string.h>
  73 #include <sys/times.h>
  74
  75 #ifdef HAVE_SYS_TIMEB_H
  76 # include <sys/timeb.h>
  77 #endif
  78
  79 #if ! HAVE_DECL_STRPTIME
  80 extern char *strptime ();
  81 #endif
  82
  83 #ifdef __STDC__
  84 # define timet time_t
  85 #else
  86 # define timet long
  87 #endif
  88
  89
  90 #if SCM_SIZEOF_LONG >= 8 && defined HAVE_CLOCK_GETTIME
  91 /* Nanoseconds on 64-bit systems with POSIX timers.  */
  92 #define TIME_UNITS_PER_SECOND 1000000000
  93 #else
  94 /* Milliseconds for everyone else.  */
  95 #define TIME_UNITS_PER_SECOND 1000
  96 #endif
  97
  98 long scm_c_time_units_per_second = TIME_UNITS_PER_SECOND;
  99
 100 static long
 101 time_from_seconds_and_nanoseconds (long s, long ns)
 102 {
 103   return s * TIME_UNITS_PER_SECOND
 104     + ns / (1000000000 / TIME_UNITS_PER_SECOND);
 105 }
 106
 107
 108 /* A runtime-selectable mechanism to choose a timing mechanism.  Really
 109    we want to use POSIX timers, but that's not always possible.  Notably,
 110    the user may have everything she needs at compile-time, but if she's
 111    running on an SMP machine without a common clock source, she can't
 112    use POSIX CPUTIME clocks.  */
 113 static long (*get_internal_real_time) (void);
 114 static long (*get_internal_run_time) (void);
 115
 116
 117 #ifdef HAVE_CLOCK_GETTIME
 118 struct timespec posix_real_time_base;
 119
 120 static long
 121 get_internal_real_time_posix_timer (void)
 122 {
 123   struct timespec ts;
 124   clock_gettime (CLOCK_REALTIME, &ts);
 125   return time_from_seconds_and_nanoseconds
 126     (ts.tv_sec - posix_real_time_base.tv_sec,
 127      ts.tv_nsec - posix_real_time_base.tv_nsec);
 128 }
 129
 130 #if defined _POSIX_CPUTIME && defined CLOCK_PROCESS_CPUTIME_ID
 131 /* You see, FreeBSD defines _POSIX_CPUTIME but not
 132    CLOCK_PROCESS_CPUTIME_ID.  */
 133 #define HAVE_POSIX_CPUTIME 1
 134
 135 struct timespec posix_run_time_base;
 136
 137 static long
 138 get_internal_run_time_posix_timer (void)
 139 {
 140   struct timespec ts;
 141   clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &ts);
 142   return time_from_seconds_and_nanoseconds
 143     (ts.tv_sec - posix_run_time_base.tv_sec,
 144      ts.tv_nsec - posix_run_time_base.tv_nsec);
 145 }
 146 #endif /* _POSIX_CPUTIME */
 147 #endif /* HAVE_CLOCKTIME */
 148
 149
 150 #ifdef HAVE_GETTIMEOFDAY
 151 struct timeval gettimeofday_real_time_base;
 152
 153 static long
 154 get_internal_real_time_gettimeofday (void)
 155 {
 156   struct timeval tv;
 157   gettimeofday (&tv, NULL);
 158   return time_from_seconds_and_nanoseconds
 159     (tv.tv_sec - gettimeofday_real_time_base.tv_sec,
 160      (tv.tv_usec - gettimeofday_real_time_base.tv_usec) * 1000);
 161 }
 162 #endif
 163
 164
 165 static long ticks_per_second;
 166
 167 static long
 168 get_internal_run_time_times (void)
 169 {
 170   struct tms time_buffer;
 171   times(&time_buffer);
 172   return (time_buffer.tms_utime + time_buffer.tms_stime)
 173     * TIME_UNITS_PER_SECOND / ticks_per_second;
 174 }
 175
 176 static timet fallback_real_time_base;
 177 static long
 178 get_internal_real_time_fallback (void)
 179 {
 180   return time_from_seconds_and_nanoseconds
 181     ((long) time (NULL) - fallback_real_time_base, 0);
 182 }
 183
 184
 185 SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
 186            (),
 187             "Return the number of time units since the interpreter was\n"
 188             "started.")
 189 #define FUNC_NAME s_scm_get_internal_real_time
 190 {
 191   return scm_from_long (get_internal_real_time ());
 192 }
 193 #undef FUNC_NAME
 194
 195
 196 SCM_DEFINE (scm_times, "times", 0, 0, 0,
 197             (void),
 198             "Return an object with information about real and processor\n"
 199             "time.  The following procedures accept such an object as an\n"
 200             "argument and return a selected component:\n"
 201             "\n"
 202             "@table @code\n"
 203             "@item tms:clock\n"
 204             "The current real time, expressed as time units relative to an\n"
 205             "arbitrary base.\n"
 206             "@item tms:utime\n"
 207             "The CPU time units used by the calling process.\n"
 208             "@item tms:stime\n"
 209             "The CPU time units used by the system on behalf of the calling\n"
 210             "process.\n"
 211             "@item tms:cutime\n"
 212             "The CPU time units used by terminated child processes of the\n"
 213             "calling process, whose status has been collected (e.g., using\n"
 214             "@code{waitpid}).\n"
 215             "@item tms:cstime\n"
 216             "Similarly, the CPU times units used by the system on behalf of\n"
 217             "terminated child processes.\n"
 218             "@end table")
 219 #define FUNC_NAME s_scm_times
 220 {
 221   struct tms t;
 222   clock_t rv;
 223   SCM factor;
 224
 225   SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
 226   rv = times (&t);
 227   if (rv == -1)
 228     SCM_SYSERROR;
 229
 230   factor = scm_quotient (scm_from_long (TIME_UNITS_PER_SECOND),
 231                          scm_from_long (ticks_per_second));
 232
 233   SCM_SIMPLE_VECTOR_SET (result, 0,
 234                          scm_product (scm_from_long (rv), factor));
 235   SCM_SIMPLE_VECTOR_SET (result, 1,
 236                          scm_product (scm_from_long (t.tms_utime), factor));
 237   SCM_SIMPLE_VECTOR_SET (result, 2,
 238                          scm_product (scm_from_long (t.tms_stime), factor));
 239   SCM_SIMPLE_VECTOR_SET (result ,3,
 240                          scm_product (scm_from_long (t.tms_cutime), factor));
 241   SCM_SIMPLE_VECTOR_SET (result, 4,
 242                          scm_product (scm_from_long (t.tms_cstime), factor));
 243   return result;
 244 }
 245 #undef FUNC_NAME
 246
 247 long
 248 scm_c_get_internal_run_time (void)
 249 {
 250   return get_internal_run_time ();
 251 }
 252
 253 SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
 254            (void),
 255             "Return the number of time units of processor time used by the\n"
 256             "interpreter.  Both @emph{system} and @emph{user} time are\n"
 257             "included but subprocesses are not.")
 258 #define FUNC_NAME s_scm_get_internal_run_time
 259 {
 260   return scm_from_long (scm_c_get_internal_run_time ());
 261 }
 262 #undef FUNC_NAME
 263
 264 /* For reference, note that current-time and gettimeofday both should be
 265    protected against setzone/restorezone changes in another thread, since on
 266    DOS the system time is normally kept as local time, which means TZ
 267    affects the return from current-time and gettimeofday.  Not sure if DJGPP
 268    etc actually has concurrent multi-threading, but it seems prudent not to
 269    make assumptions about this.  */
 270
 271 SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
 272            (void),
 273             "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
 274             "excluding leap seconds.")
 275 #define FUNC_NAME s_scm_current_time
 276 {
 277   timet timv;
 278
 279   SCM_CRITICAL_SECTION_START;
 280   timv = time (NULL);
 281   SCM_CRITICAL_SECTION_END;
 282   if (timv == -1)
 283     SCM_MISC_ERROR ("current time not available", SCM_EOL);
 284   return scm_from_long (timv);
 285 }
 286 #undef FUNC_NAME
 287
 288 SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
 289             (void),
 290             "Return a pair containing the number of seconds and microseconds\n"
 291             "since 1970-01-01 00:00:00 UTC, excluding leap seconds.  Note:\n"
 292             "whether true microsecond resolution is available depends on the\n"
 293             "operating system.")
 294 #define FUNC_NAME s_scm_gettimeofday
 295 {
 296 #ifdef HAVE_GETTIMEOFDAY
 297   struct timeval time;
 298
 299   if (gettimeofday (&time, NULL))
 300     SCM_SYSERROR;
 301
 302   return scm_cons (scm_from_long (time.tv_sec),
 303                    scm_from_long (time.tv_usec));
 304 #else
 305   timet t = time (NULL);
 306   if (errno)
 307     SCM_SYSERROR;
 308   else
 309     return scm_cons (scm_from_long ((long)t), SCM_INUM0);
 310 #endif
 311 }
 312 #undef FUNC_NAME
 313
 314 static SCM
 315 filltime (struct tm *bd_time, int zoff, const char *zname)
 316 {
 317   SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
 318
 319   SCM_SIMPLE_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec));
 320   SCM_SIMPLE_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min));
 321   SCM_SIMPLE_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour));
 322   SCM_SIMPLE_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday));
 323   SCM_SIMPLE_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon));
 324   SCM_SIMPLE_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year));
 325   SCM_SIMPLE_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday));
 326   SCM_SIMPLE_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday));
 327   SCM_SIMPLE_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst));
 328   SCM_SIMPLE_VECTOR_SET (result,9, scm_from_int (zoff));
 329   SCM_SIMPLE_VECTOR_SET (result,10, (zname
 330                                      ? scm_from_locale_string (zname)
 331                                      : SCM_BOOL_F));
 332   return result;
 333 }
 334
 335 static char tzvar[3] = "TZ";
 336
 337 /* if zone is set, create a temporary environment with only a TZ
 338    string.  other threads or interrupt handlers shouldn't be allowed
 339    to run until the corresponding restorezone is called.  hence the use
 340    of a static variable for tmpenv is no big deal.  */
 341 static char **
 342 setzone (SCM zone, int pos, const char *subr)
 343 {
 344   char **oldenv = 0;
 345
 346   if (!SCM_UNBNDP (zone))
 347     {
 348       static char *tmpenv[2];
 349       char *buf;
 350       size_t zone_len;
 351
 352       zone_len = scm_to_locale_stringbuf (zone, NULL, 0);
 353       buf = scm_malloc (zone_len + sizeof (tzvar) + 1);
 354       strcpy (buf, tzvar);
 355       buf[sizeof(tzvar)-1] = '=';
 356       scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len);
 357       buf[sizeof(tzvar)+zone_len] = '\0';
 358       oldenv = environ;
 359       tmpenv[0] = buf;
 360       tmpenv[1] = 0;
 361       environ = tmpenv;
 362     }
 363   return oldenv;
 364 }
 365
 366 static void
 367 restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
 368 {
 369   if (!SCM_UNBNDP (zone))
 370     {
 371       free (environ[0]);
 372       environ = oldenv;
 373 #ifdef HAVE_TZSET
 374       /* for the possible benefit of user code linked with libguile.  */
 375       tzset();
 376 #endif
 377     }
 378 }
 379
 380 SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
 381             (SCM time, SCM zone),
 382             "Return an object representing the broken down components of\n"
 383             "@var{time}, an integer like the one returned by\n"
 384             "@code{current-time}.  The time zone for the calculation is\n"
 385             "optionally specified by @var{zone} (a string), otherwise the\n"
 386             "@code{TZ} environment variable or the system default is used.")
 387 #define FUNC_NAME s_scm_localtime
 388 {
 389   timet itime;
 390   struct tm *ltptr, lt, *utc;
 391   SCM result;
 392   int zoff;
 393   char *zname = 0;
 394   char **oldenv;
 395   int err;
 396
 397   itime = SCM_NUM2LONG (1, time);
 398
 399   /* deferring interupts is essential since a) setzone may install a temporary
 400      environment b) localtime uses a static buffer.  */
 401   SCM_CRITICAL_SECTION_START;
 402   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 403 #ifdef LOCALTIME_CACHE
 404   tzset ();
 405 #endif
 406   /* POSIX says localtime sets errno, but C99 doesn't say that.
 407      Give a sensible default value in case localtime doesn't set it.  */
 408   errno = EINVAL;
 409   ltptr = localtime (&itime);
 410   err = errno;
 411   if (ltptr)
 412     {
 413       const char *ptr;
 414
 415       /* copy zone name before calling gmtime or restoring zone.  */
 416 #if defined (HAVE_TM_ZONE)
 417       ptr = ltptr->tm_zone;
 418 #elif defined (HAVE_TZNAME)
 419       ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
 420 #else
 421       ptr = "";
 422 #endif
 423       zname = scm_malloc (strlen (ptr) + 1);
 424       strcpy (zname, ptr);
 425     }
 426   /* the struct is copied in case localtime and gmtime share a buffer.  */
 427   if (ltptr)
 428     lt = *ltptr;
 429   /* POSIX says gmtime sets errno, but C99 doesn't say that.
 430      Give a sensible default value in case gmtime doesn't set it.  */
 431   errno = EINVAL;
 432   utc = gmtime (&itime);
 433   if (utc == NULL)
 434     err = errno;
 435   restorezone (zone, oldenv, FUNC_NAME);
 436   /* delayed until zone has been restored.  */
 437   errno = err;
 438   if (utc == NULL || ltptr == NULL)
 439     SCM_SYSERROR;
 440
 441   /* calculate timezone offset in seconds west of UTC.  */
 442   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 443     + utc->tm_sec - lt.tm_sec;
 444   if (utc->tm_year < lt.tm_year)
 445     zoff -= 24 * 60 * 60;
 446   else if (utc->tm_year > lt.tm_year)
 447     zoff += 24 * 60 * 60;
 448   else if (utc->tm_yday < lt.tm_yday)
 449     zoff -= 24 * 60 * 60;
 450   else if (utc->tm_yday > lt.tm_yday)
 451     zoff += 24 * 60 * 60;
 452
 453   result = filltime (&lt, zoff, zname);
 454   SCM_CRITICAL_SECTION_END;
 455
 456   free (zname);
 457   return result;
 458 }
 459 #undef FUNC_NAME
 460
 461 /* tm_zone is normally a pointer, not an array within struct tm, so we might
 462    have to worry about the lifespan of what it points to.  The posix specs
 463    don't seem to say anything about this, let's assume here that tm_zone
 464    will be a constant and therefore no protection or anything is needed
 465    until we copy it in filltime().  */
 466
 467 SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
 468             (SCM time),
 469             "Return an object representing the broken down components of\n"
 470             "@var{time}, an integer like the one returned by\n"
 471             "@code{current-time}.  The values are calculated for UTC.")
 472 #define FUNC_NAME s_scm_gmtime
 473 {
 474   timet itime;
 475   struct tm bd_buf, *bd_time;
 476   const char *zname;
 477
 478   itime = SCM_NUM2LONG (1, time);
 479
 480   /* POSIX says gmtime sets errno, but C99 doesn't say that.
 481      Give a sensible default value in case gmtime doesn't set it.  */
 482   errno = EINVAL;
 483
 484 #if HAVE_GMTIME_R
 485   bd_time = gmtime_r (&itime, &bd_buf);
 486 #else
 487   SCM_CRITICAL_SECTION_START;
 488   bd_time = gmtime (&itime);
 489   if (bd_time != NULL)
 490     bd_buf = *bd_time;
 491   SCM_CRITICAL_SECTION_END;
 492 #endif
 493   if (bd_time == NULL)
 494     SCM_SYSERROR;
 495
 496 #if HAVE_STRUCT_TM_TM_ZONE
 497   zname = bd_buf.tm_zone;
 498 #else
 499   zname = "GMT";
 500 #endif
 501   return filltime (&bd_buf, 0, zname);
 502 }
 503 #undef FUNC_NAME
 504
 505 /* copy time components from a Scheme object to a struct tm.  */
 506 static void
 507 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
 508 {
 509   SCM_ASSERT (scm_is_simple_vector (sbd_time)
 510               && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
 511               sbd_time, pos, subr);
 512
 513   lt->tm_sec = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 0));
 514   lt->tm_min = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 1));
 515   lt->tm_hour = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 2));
 516   lt->tm_mday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 3));
 517   lt->tm_mon = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 4));
 518   lt->tm_year = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 5));
 519   lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6));
 520   lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
 521   lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8));
 522 #if HAVE_STRUCT_TM_TM_GMTOFF
 523   lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
 524 #endif
 525 #ifdef HAVE_TM_ZONE
 526   if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
 527     lt->tm_zone = NULL;
 528   else
 529     lt->tm_zone  = scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time, 10));
 530 #endif
 531 }
 532
 533 SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
 534             (SCM sbd_time, SCM zone),
 535             "@var{sbd_time} is an object representing broken down time and\n"
 536             "@code{zone} is an optional time zone specifier (otherwise the\n"
 537             "TZ environment variable or the system default is used).\n"
 538             "\n"
 539             "Returns a pair: the car is a corresponding integer time value\n"
 540             "like that returned by @code{current-time}; the cdr is a broken\n"
 541             "down time object, similar to as @var{sbd_time} but with\n"
 542             "normalized values.")
 543 #define FUNC_NAME s_scm_mktime
 544 {
 545   timet itime;
 546   struct tm lt, *utc;
 547   SCM result;
 548   int zoff;
 549   char *zname = 0;
 550   char **oldenv;
 551   int err;
 552
 553   scm_dynwind_begin (0);
 554
 555   bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
 556 #if HAVE_STRUCT_TM_TM_ZONE
 557   scm_dynwind_free ((char *)lt.tm_zone);
 558 #endif
 559
 560   scm_dynwind_critical_section (SCM_BOOL_F);
 561
 562   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 563 #ifdef LOCALTIME_CACHE
 564   tzset ();
 565 #endif
 566   itime = mktime (&lt);
 567   /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
 568      doesn't.  Force a sensible value for our error message.  */
 569   err = EINVAL;
 570
 571   if (itime != -1)
 572     {
 573       const char *ptr;
 574
 575       /* copy zone name before calling gmtime or restoring the zone.  */
 576 #if defined (HAVE_TM_ZONE)
 577       ptr = lt.tm_zone;
 578 #elif defined (HAVE_TZNAME)
 579       ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
 580 #else
 581       ptr = "";
 582 #endif
 583       zname = scm_malloc (strlen (ptr) + 1);
 584       strcpy (zname, ptr);
 585     }
 586
 587   /* get timezone offset in seconds west of UTC.  */
 588   /* POSIX says gmtime sets errno, but C99 doesn't say that.
 589      Give a sensible default value in case gmtime doesn't set it.  */
 590   errno = EINVAL;
 591   utc = gmtime (&itime);
 592   if (utc == NULL)
 593     err = errno;
 594
 595   restorezone (zone, oldenv, FUNC_NAME);
 596   /* delayed until zone has been restored.  */
 597   errno = err;
 598   if (utc == NULL || itime == -1)
 599     SCM_SYSERROR;
 600
 601   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 602     + utc->tm_sec - lt.tm_sec;
 603   if (utc->tm_year < lt.tm_year)
 604     zoff -= 24 * 60 * 60;
 605   else if (utc->tm_year > lt.tm_year)
 606     zoff += 24 * 60 * 60;
 607   else if (utc->tm_yday < lt.tm_yday)
 608     zoff -= 24 * 60 * 60;
 609   else if (utc->tm_yday > lt.tm_yday)
 610     zoff += 24 * 60 * 60;
 611
 612   result = scm_cons (scm_from_long (itime),
 613                      filltime (&lt, zoff, zname));
 614   free (zname);
 615
 616   scm_dynwind_end ();
 617   return result;
 618 }
 619 #undef FUNC_NAME
 620
 621 #ifdef HAVE_TZSET
 622 SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
 623             (void),
 624             "Initialize the timezone from the TZ environment variable\n"
 625             "or the system default.  It's not usually necessary to call this procedure\n"
 626             "since it's done automatically by other procedures that depend on the\n"
 627             "timezone.")
 628 #define FUNC_NAME s_scm_tzset
 629 {
 630   tzset();
 631   return SCM_UNSPECIFIED;
 632 }
 633 #undef FUNC_NAME
 634 #endif /* HAVE_TZSET */
 635
 636 SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
 637             (SCM format, SCM stime),
 638             "Return a string which is broken-down time structure @var{stime}\n"
 639             "formatted according to the given @var{format} string.\n"
 640             "\n"
 641             "@var{format} contains field specifications introduced by a\n"
 642             "@samp{%} character.  See @ref{Formatting Calendar Time,,, libc,\n"
 643             "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
 644             "for the available formatting.\n"
 645             "\n"
 646             "@lisp\n"
 647             "(strftime \"%c\" (localtime (current-time)))\n"
 648             "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
 649             "@end lisp\n"
 650             "\n"
 651             "If @code{setlocale} has been called (@pxref{Locales}), month\n"
 652             "and day names are from the current locale and in the locale\n"
 653             "character set.")
 654 #define FUNC_NAME s_scm_strftime
 655 {
 656   struct tm t;
 657
 658   char *tbuf;
 659   int size = 50;
 660   char *fmt;
 661   char *myfmt;
 662   size_t len;
 663   SCM result;
 664
 665   SCM_VALIDATE_STRING (1, format);
 666   bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
 667
 668   /* Convert string to UTF-8 so that non-ASCII characters in the
 669      format are passed through unchanged.  */
 670   fmt = scm_to_utf8_stringn (format, &len);
 671
 672   /* Ugly hack: strftime can return 0 if its buffer is too small,
 673      but some valid time strings (e.g. "%p") can sometimes produce
 674      a zero-byte output string!  Workaround is to prepend a junk
 675      character to the format string, so that valid returns are always
 676      nonzero. */
 677   myfmt = scm_malloc (len+2);
 678   *myfmt = (scm_t_uint8) 'x';
 679   strncpy (myfmt + 1, fmt, len);
 680   myfmt[len + 1] = 0;
 681   scm_remember_upto_here_1 (format);
 682   free (fmt);
 683
 684   tbuf = scm_malloc (size);
 685   {
 686 #if !defined (HAVE_TM_ZONE)
 687     /* it seems the only way to tell non-GNU versions of strftime what
 688        zone to use (for the %Z format) is to set TZ in the
 689        environment.  interrupts and thread switching must be deferred
 690        until TZ is restored.  */
 691     char **oldenv = NULL;
 692     SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10);
 693     int have_zone = 0;
 694
 695     if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0)
 696       {
 697         /* it's not required that the TZ setting be correct, just that
 698            it has the right name.  so try something like TZ=EST0.
 699            using only TZ=EST would be simpler but it doesn't work on
 700            some OSs, e.g., Solaris.  */
 701         SCM zone =
 702           scm_string_append (scm_list_2 (zone_spec,
 703                                          scm_from_locale_string ("0")));
 704
 705         have_zone = 1;
 706         SCM_CRITICAL_SECTION_START;
 707         oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 708       }
 709 #endif
 710
 711 #ifdef LOCALTIME_CACHE
 712     tzset ();
 713 #endif
 714
 715     /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions
 716        supported by glibc.  */
 717     while ((len = nstrftime (tbuf, size, myfmt, &t, 0, 0)) == 0)
 718       {
 719         free (tbuf);
 720         size *= 2;
 721         tbuf = scm_malloc (size);
 722       }
 723
 724 #if !defined (HAVE_TM_ZONE)
 725     if (have_zone)
 726       {
 727         restorezone (zone_spec, oldenv, FUNC_NAME);
 728         SCM_CRITICAL_SECTION_END;
 729       }
 730 #endif
 731     }
 732
 733   result = scm_from_utf8_string (tbuf + 1);
 734   free (tbuf);
 735   free (myfmt);
 736 #if HAVE_STRUCT_TM_TM_ZONE
 737   free ((char *) t.tm_zone);
 738 #endif
 739   return result;
 740 }
 741 #undef FUNC_NAME
 742
 743 #ifdef HAVE_STRPTIME
 744 SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
 745             (SCM format, SCM string),
 746             "Performs the reverse action to @code{strftime}, parsing\n"
 747             "@var{string} according to the specification supplied in\n"
 748             "@var{format}.  The interpretation of month and day names is\n"
 749             "dependent on the current locale.  The value returned is a pair.\n"
 750             "The car has an object with time components\n"
 751             "in the form returned by @code{localtime} or @code{gmtime},\n"
 752             "but the time zone components\n"
 753             "are not usefully set.\n"
 754             "The cdr reports the number of characters from @var{string}\n"
 755             "which were used for the conversion.")
 756 #define FUNC_NAME s_scm_strptime
 757 {
 758   struct tm t;
 759   char *fmt, *str, *rest;
 760   size_t used_len;
 761   long zoff;
 762
 763   SCM_VALIDATE_STRING (1, format);
 764   SCM_VALIDATE_STRING (2, string);
 765
 766   /* Convert strings to UTF-8 so that non-ASCII characters are passed
 767      through unchanged.  */
 768   fmt = scm_to_utf8_string (format);
 769   str = scm_to_utf8_string (string);
 770
 771   /* initialize the struct tm */
 772 #define tm_init(field) t.field = 0
 773   tm_init (tm_sec);
 774   tm_init (tm_min);
 775   tm_init (tm_hour);
 776   tm_init (tm_mday);
 777   tm_init (tm_mon);
 778   tm_init (tm_year);
 779   tm_init (tm_wday);
 780   tm_init (tm_yday);
 781 #if HAVE_STRUCT_TM_TM_GMTOFF
 782   tm_init (tm_gmtoff);
 783 #endif
 784 #undef tm_init
 785
 786   /* GNU glibc strptime() "%s" is affected by the current timezone, since it
 787      reads a UTC time_t value and converts with localtime_r() to set the tm
 788      fields, hence the use of SCM_CRITICAL_SECTION_START.  */
 789   t.tm_isdst = -1;
 790   SCM_CRITICAL_SECTION_START;
 791   rest = strptime (str, fmt, &t);
 792   SCM_CRITICAL_SECTION_END;
 793   if (rest == NULL)
 794     {
 795       /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
 796          instance it doesn't.  Force a sensible value for our error
 797          message.  */
 798       errno = EINVAL;
 799       scm_remember_upto_here_2 (format, string);
 800       free (str);
 801       free (fmt);
 802       SCM_SYSERROR;
 803     }
 804
 805   /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
 806      available */
 807 #if HAVE_STRUCT_TM_TM_GMTOFF
 808   zoff = - t.tm_gmtoff;  /* seconds west, not east */
 809 #else
 810   zoff = 0;
 811 #endif
 812
 813   /* Compute the number of UTF-8 characters.  */
 814   used_len = u8_strnlen ((scm_t_uint8*) str, rest-str);
 815   scm_remember_upto_here_2 (format, string);
 816   free (str);
 817   free (fmt);
 818
 819   return scm_cons (filltime (&t, zoff, NULL),
 820                    scm_from_signed_integer (used_len));
 821 }
 822 #undef FUNC_NAME
 823 #endif /* HAVE_STRPTIME */
 824
 825 void
 826 scm_init_stime()
 827 {
 828   scm_c_define ("internal-time-units-per-second",
 829                 scm_from_long (SCM_TIME_UNITS_PER_SECOND));
 830
 831   /* Init POSIX timers, and see if we can use them. */
 832 #ifdef HAVE_CLOCK_GETTIME
 833   if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
 834     get_internal_real_time = get_internal_real_time_posix_timer;
 835
 836 #ifdef HAVE_POSIX_CPUTIME
 837   {
 838     clockid_t dummy;
 839
 840     /* Only use the _POSIX_CPUTIME clock if it's going to work across
 841        CPUs. */
 842     if (clock_getcpuclockid (0, &dummy) == 0 &&
 843         clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0)
 844       get_internal_run_time = get_internal_run_time_posix_timer;
 845     else
 846       errno = 0;
 847   }
 848 #endif /* HAVE_POSIX_CPUTIME */
 849 #endif /* HAVE_CLOCKTIME */
 850
 851   /* If needed, init and use gettimeofday timer. */
 852 #ifdef HAVE_GETTIMEOFDAY
 853   if (!get_internal_real_time
 854       && gettimeofday (&gettimeofday_real_time_base, NULL) == 0)
 855     get_internal_real_time = get_internal_real_time_gettimeofday;
 856 #endif
 857
 858   /* Init ticks_per_second for scm_times, and use times(2)-based
 859      run-time timer if needed. */
 860 #ifdef _SC_CLK_TCK
 861   ticks_per_second = sysconf (_SC_CLK_TCK);
 862 #else
 863   ticks_per_second = CLK_TCK;
 864 #endif
 865   if (!get_internal_run_time)
 866     get_internal_run_time = get_internal_run_time_times;
 867
 868   if (!get_internal_real_time)
 869     /* No POSIX timers, gettimeofday doesn't work... badness!  */
 870     {
 871       fallback_real_time_base = time (NULL);
 872       get_internal_real_time = get_internal_real_time_fallback;
 873     }
 874
 875   scm_add_feature ("current-time");
 876 #include "libguile/stime.x"
 877 }
 878
 879
 880 /*
 881   Local Variables:
 882   c-file-style: "gnu"
 883   End:
 884 */