guile18/libguile/stime.c

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