libguile/stime.c

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