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{bd-time} is an object representing broken down time and @code{zone}\n"
 555             "is an optional time zone specifier (otherwise the TZ environment variable\n"
 556             "or the system default is used).\n\n"
 557             "Returns a pair: the car is a corresponding\n"
 558             "integer time value like that returned\n"
 559             "by @code{current-time}; the cdr is a broken down time object, similar to\n"
 560             "as @var{bd-time} but with normalized values.")
 561 #define FUNC_NAME s_scm_mktime
 562 {
 563   timet itime;
 564   struct tm lt, *utc;
 565   SCM result;
 566   int zoff;
 567   char *zname = 0;
 568   char **oldenv;
 569   int err;
 570
 571   scm_dynwind_begin (0);
 572
 573   bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
 574 #if HAVE_STRUCT_TM_TM_ZONE
 575   scm_dynwind_free ((char *)lt.tm_zone);
 576 #endif
 577
 578   scm_dynwind_critical_section (SCM_BOOL_F);
 579
 580   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 581 #ifdef LOCALTIME_CACHE
 582   tzset ();
 583 #endif
 584   itime = mktime (&lt);
 585   /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
 586      doesn't.  Force a sensible value for our error message.  */
 587   err = EINVAL;
 588
 589   if (itime != -1)
 590     {
 591       const char *ptr;
 592
 593       /* copy zone name before calling gmtime or restoring the zone.  */
 594 #if defined (HAVE_TM_ZONE)
 595       ptr = lt.tm_zone;
 596 #elif defined (HAVE_TZNAME)
 597       ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
 598 #else
 599       ptr = "";
 600 #endif
 601       zname = scm_malloc (strlen (ptr) + 1);
 602       strcpy (zname, ptr);
 603     }
 604
 605   /* get timezone offset in seconds west of UTC.  */
 606   /* POSIX says gmtime sets errno, but C99 doesn't say that.
 607      Give a sensible default value in case gmtime doesn't set it.  */
 608   errno = EINVAL;
 609   utc = gmtime (&itime);
 610   if (utc == NULL)
 611     err = errno;
 612
 613   restorezone (zone, oldenv, FUNC_NAME);
 614   /* delayed until zone has been restored.  */
 615   errno = err;
 616   if (utc == NULL || itime == -1)
 617     SCM_SYSERROR;
 618
 619   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 620     + utc->tm_sec - lt.tm_sec;
 621   if (utc->tm_year < lt.tm_year)
 622     zoff -= 24 * 60 * 60;
 623   else if (utc->tm_year > lt.tm_year)
 624     zoff += 24 * 60 * 60;
 625   else if (utc->tm_yday < lt.tm_yday)
 626     zoff -= 24 * 60 * 60;
 627   else if (utc->tm_yday > lt.tm_yday)
 628     zoff += 24 * 60 * 60;
 629
 630   result = scm_cons (scm_from_long (itime),
 631                      filltime (&lt, zoff, zname));
 632   free (zname);
 633
 634   scm_dynwind_end ();
 635   return result;
 636 }
 637 #undef FUNC_NAME
 638
 639 #ifdef HAVE_TZSET
 640 SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
 641             (void),
 642             "Initialize the timezone from the TZ environment variable\n"
 643             "or the system default.  It's not usually necessary to call this procedure\n"
 644             "since it's done automatically by other procedures that depend on the\n"
 645             "timezone.")
 646 #define FUNC_NAME s_scm_tzset
 647 {
 648   tzset();
 649   return SCM_UNSPECIFIED;
 650 }
 651 #undef FUNC_NAME
 652 #endif /* HAVE_TZSET */
 653
 654 SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
 655             (SCM format, SCM stime),
 656             "Return a string which is broken-down time structure @var{stime}\n"
 657             "formatted according to the given @var{format} string.\n"
 658             "\n"
 659             "@var{format} contains field specifications introduced by a\n"
 660             "@samp{%} character.  See @ref{Formatting Calendar Time,,, libc,\n"
 661             "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
 662             "for the available formatting.\n"
 663             "\n"
 664             "@lisp\n"
 665             "(strftime \"%c\" (localtime (current-time)))\n"
 666             "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
 667             "@end lisp\n"
 668             "\n"
 669             "If @code{setlocale} has been called (@pxref{Locales}), month\n"
 670             "and day names are from the current locale and in the locale\n"
 671             "character set.")
 672 #define FUNC_NAME s_scm_strftime
 673 {
 674   struct tm t;
 675
 676   char *tbuf;
 677   int size = 50;
 678   char *fmt;
 679   char *myfmt;
 680   size_t len;
 681   SCM result;
 682
 683   SCM_VALIDATE_STRING (1, format);
 684   bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
 685
 686   /* Convert string to UTF-8 so that non-ASCII characters in the
 687      format are passed through unchanged.  */
 688   fmt = scm_to_utf8_stringn (format, &len);
 689
 690   /* Ugly hack: strftime can return 0 if its buffer is too small,
 691      but some valid time strings (e.g. "%p") can sometimes produce
 692      a zero-byte output string!  Workaround is to prepend a junk
 693      character to the format string, so that valid returns are always
 694      nonzero. */
 695   myfmt = scm_malloc (len+2);
 696   *myfmt = (scm_t_uint8) 'x';
 697   strncpy (myfmt + 1, fmt, len);
 698   myfmt[len + 1] = 0;
 699   scm_remember_upto_here_1 (format);
 700   free (fmt);
 701
 702   tbuf = scm_malloc (size);
 703   {
 704 #if !defined (HAVE_TM_ZONE)
 705     /* it seems the only way to tell non-GNU versions of strftime what
 706        zone to use (for the %Z format) is to set TZ in the
 707        environment.  interrupts and thread switching must be deferred
 708        until TZ is restored.  */
 709     char **oldenv = NULL;
 710     SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10);
 711     int have_zone = 0;
 712
 713     if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0)
 714       {
 715         /* it's not required that the TZ setting be correct, just that
 716            it has the right name.  so try something like TZ=EST0.
 717            using only TZ=EST would be simpler but it doesn't work on
 718            some OSs, e.g., Solaris.  */
 719         SCM zone =
 720           scm_string_append (scm_list_2 (zone_spec,
 721                                          scm_from_locale_string ("0")));
 722
 723         have_zone = 1;
 724         SCM_CRITICAL_SECTION_START;
 725         oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 726       }
 727 #endif
 728
 729 #ifdef LOCALTIME_CACHE
 730     tzset ();
 731 #endif
 732
 733     /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions
 734        supported by glibc.  */
 735     while ((len = nstrftime (tbuf, size, myfmt, &t, 0, 0)) == 0)
 736       {
 737         free (tbuf);
 738         size *= 2;
 739         tbuf = scm_malloc (size);
 740       }
 741
 742 #if !defined (HAVE_TM_ZONE)
 743     if (have_zone)
 744       {
 745         restorezone (zone_spec, oldenv, FUNC_NAME);
 746         SCM_CRITICAL_SECTION_END;
 747       }
 748 #endif
 749     }
 750
 751   result = scm_from_utf8_string (tbuf + 1);
 752   free (tbuf);
 753   free (myfmt);
 754 #if HAVE_STRUCT_TM_TM_ZONE
 755   free ((char *) t.tm_zone);
 756 #endif
 757   return result;
 758 }
 759 #undef FUNC_NAME
 760
 761 #ifdef HAVE_STRPTIME
 762 SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
 763             (SCM format, SCM string),
 764             "Performs the reverse action to @code{strftime}, parsing\n"
 765             "@var{string} according to the specification supplied in\n"
 766             "@var{template}.  The interpretation of month and day names is\n"
 767             "dependent on the current locale.  The value returned is a pair.\n"
 768             "The car has an object with time components\n"
 769             "in the form returned by @code{localtime} or @code{gmtime},\n"
 770             "but the time zone components\n"
 771             "are not usefully set.\n"
 772             "The cdr reports the number of characters from @var{string}\n"
 773             "which were used for the conversion.")
 774 #define FUNC_NAME s_scm_strptime
 775 {
 776   struct tm t;
 777   char *fmt, *str, *rest;
 778   size_t used_len;
 779   long zoff;
 780
 781   SCM_VALIDATE_STRING (1, format);
 782   SCM_VALIDATE_STRING (2, string);
 783
 784   /* Convert strings to UTF-8 so that non-ASCII characters are passed
 785      through unchanged.  */
 786   fmt = scm_to_utf8_string (format);
 787   str = scm_to_utf8_string (string);
 788
 789   /* initialize the struct tm */
 790 #define tm_init(field) t.field = 0
 791   tm_init (tm_sec);
 792   tm_init (tm_min);
 793   tm_init (tm_hour);
 794   tm_init (tm_mday);
 795   tm_init (tm_mon);
 796   tm_init (tm_year);
 797   tm_init (tm_wday);
 798   tm_init (tm_yday);
 799 #if HAVE_STRUCT_TM_TM_GMTOFF
 800   tm_init (tm_gmtoff);
 801 #endif
 802 #undef tm_init
 803
 804   /* GNU glibc strptime() "%s" is affected by the current timezone, since it
 805      reads a UTC time_t value and converts with localtime_r() to set the tm
 806      fields, hence the use of SCM_CRITICAL_SECTION_START.  */
 807   t.tm_isdst = -1;
 808   SCM_CRITICAL_SECTION_START;
 809   rest = strptime (str, fmt, &t);
 810   SCM_CRITICAL_SECTION_END;
 811   if (rest == NULL)
 812     {
 813       /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
 814          instance it doesn't.  Force a sensible value for our error
 815          message.  */
 816       errno = EINVAL;
 817       scm_remember_upto_here_2 (format, string);
 818       free (str);
 819       free (fmt);
 820       SCM_SYSERROR;
 821     }
 822
 823   /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
 824      available */
 825 #if HAVE_STRUCT_TM_TM_GMTOFF
 826   zoff = - t.tm_gmtoff;  /* seconds west, not east */
 827 #else
 828   zoff = 0;
 829 #endif
 830
 831   /* Compute the number of UTF-8 characters.  */
 832   used_len = u8_strnlen ((scm_t_uint8*) str, rest-str);
 833   scm_remember_upto_here_2 (format, string);
 834   free (str);
 835   free (fmt);
 836
 837   return scm_cons (filltime (&t, zoff, NULL),
 838                    scm_from_signed_integer (used_len));
 839 }
 840 #undef FUNC_NAME
 841 #endif /* HAVE_STRPTIME */
 842
 843 void
 844 scm_init_stime()
 845 {
 846   scm_c_define ("internal-time-units-per-second",
 847                 scm_from_long (SCM_TIME_UNITS_PER_SECOND));
 848
 849   /* Init POSIX timers, and see if we can use them. */
 850 #ifdef HAVE_CLOCK_GETTIME
 851   if (clock_gettime (CLOCK_REALTIME, &posix_real_time_base) == 0)
 852     get_internal_real_time = get_internal_real_time_posix_timer;
 853
 854 #ifdef HAVE_POSIX_CPUTIME
 855   {
 856     clockid_t dummy;
 857
 858     /* Only use the _POSIX_CPUTIME clock if it's going to work across
 859        CPUs. */
 860     if (clock_getcpuclockid (0, &dummy) == 0 &&
 861         clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0)
 862       get_internal_run_time = get_internal_run_time_posix_timer;
 863     else
 864       errno = 0;
 865   }
 866 #endif /* HAVE_POSIX_CPUTIME */
 867 #endif /* HAVE_CLOCKTIME */
 868
 869   /* If needed, init and use gettimeofday timer. */
 870 #ifdef HAVE_GETTIMEOFDAY
 871   if (!get_internal_real_time
 872       && gettimeofday (&gettimeofday_real_time_base, NULL) == 0)
 873     get_internal_real_time = get_internal_real_time_gettimeofday;
 874 #endif
 875
 876   /* Init ticks_per_second for scm_times, and use times(2)-based
 877      run-time timer if needed. */
 878 #ifdef HAVE_TIMES
 879 #ifdef _SC_CLK_TCK
 880   ticks_per_second = sysconf (_SC_CLK_TCK);
 881 #else
 882   ticks_per_second = CLK_TCK;
 883 #endif
 884   if (!get_internal_run_time)
 885     get_internal_run_time = get_internal_run_time_times;
 886 #endif
 887
 888   if (!get_internal_real_time)
 889     /* No POSIX timers, gettimeofday doesn't work... badness!  */
 890     {
 891       fallback_real_time_base = time (NULL);
 892       get_internal_real_time = get_internal_real_time_fallback;
 893     }
 894
 895   /* If we don't have a run-time timer, use real-time.  */
 896   if (!get_internal_run_time)
 897     get_internal_run_time = get_internal_real_time;
 898
 899   scm_add_feature ("current-time");
 900 #include "libguile/stime.x"
 901 }
 902
 903
 904 /*
 905   Local Variables:
 906   c-file-style: "gnu"
 907   End:
 908 */