libguile/stime.c

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