libguile/stime.c

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