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