libguile/stime.c

   1 /* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "libguile/_scm.h"
  49 #include "libguile/feature.h"
  50 #include "libguile/strings.h"
  51 #include "libguile/vectors.h"
  52
  53 #include "libguile/validate.h"
  54 #include "libguile/stime.h"
  55
  56 #ifdef HAVE_UNISTD_H
  57 #include <unistd.h>
  58 #endif
  59
  60 \f
  61 # ifdef HAVE_SYS_TYPES_H
  62 #  include <sys/types.h>
  63 # endif
  64
  65 #ifdef HAVE_STRING_H
  66 #include <string.h>
  67 #endif
  68
  69 # ifdef TIME_WITH_SYS_TIME
  70 #  include <sys/time.h>
  71 #  include <time.h>
  72 # else
  73 #  ifdef HAVE_SYS_TIME_H
  74 #   include <sys/time.h>
  75 #  else
  76 #   ifdef HAVE_TIME_H
  77 #    include <time.h>
  78 #   endif
  79 #  endif
  80 # endif
  81
  82 #ifdef HAVE_SYS_TIMES_H
  83 # include <sys/times.h>
  84 #endif
  85
  86 #ifdef HAVE_SYS_TIMEB_H
  87 # include <sys/timeb.h>
  88 #endif
  89
  90 #ifndef tzname /* For SGI.  */
  91 extern char *tzname[]; /* RS6000 and others reject char **tzname.  */
  92 #endif
  93
  94 #ifdef MISSING_STRPTIME_DECL
  95 extern char *strptime ();
  96 #endif
  97
  98 /* This should be figured out by autoconf.  */
  99 #if ! defined(CLKTCK) && defined(CLK_TCK)
 100 #  define CLKTCK CLK_TCK
 101 #endif
 102 #if ! defined(CLKTCK) && defined(CLOCKS_PER_SEC)
 103 #  define CLKTCK CLOCKS_PER_SEC
 104 #endif
 105 #if ! defined(CLKTCK)
 106 #  define CLKTCK 60
 107 #endif
 108
 109 #ifdef __STDC__
 110 # define timet time_t
 111 #else
 112 # define timet long
 113 #endif
 114
 115 #ifdef HAVE_TIMES
 116 static
 117 timet mytime()
 118 {
 119   struct tms time_buffer;
 120   times(&time_buffer);
 121   return time_buffer.tms_utime + time_buffer.tms_stime;
 122 }
 123 #else
 124 # ifdef LACK_CLOCK
 125 #    define mytime() ((time((timet*)0) - scm_your_base) * CLKTCK)
 126 # else
 127 #  define mytime clock
 128 # endif
 129 #endif
 130
 131 extern int errno;
 132
 133 #ifdef HAVE_FTIME
 134 struct timeb scm_your_base = {0};
 135 #else
 136 timet scm_your_base = 0;
 137 #endif
 138
 139 SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
 140            (),
 141             "Returns the number of time units since the interpreter was started.")
 142 #define FUNC_NAME s_scm_get_internal_real_time
 143 {
 144 #ifdef HAVE_FTIME
 145   struct timeb time_buffer;
 146
 147   SCM tmp;
 148   ftime (&time_buffer);
 149   time_buffer.time -= scm_your_base.time;
 150   tmp = scm_long2num (time_buffer.millitm - scm_your_base.millitm);
 151   tmp = scm_sum (tmp,
 152                  scm_product (SCM_MAKINUM (1000),
 153                               SCM_MAKINUM (time_buffer.time)));
 154   return scm_quotient (scm_product (tmp, SCM_MAKINUM (CLKTCK)),
 155                        SCM_MAKINUM (1000));
 156 #else
 157   return scm_long2num((time((timet*)0) - scm_your_base) * (int)CLKTCK);
 158 #endif /* HAVE_FTIME */
 159 }
 160 #undef FUNC_NAME
 161
 162
 163 #ifdef HAVE_TIMES
 164 SCM_DEFINE (scm_times, "times", 0, 0, 0,
 165             (void),
 166             "Returns an object with information about real and processor time.\n"
 167             "The following procedures accept such an object as an argument and\n"
 168             "return a selected component:\n\n"
 169             "@table @code\n"
 170             "@item tms:clock\n"
 171             "The current real time, expressed as time units relative to an\n"
 172             "arbitrary base.\n"
 173             "@item tms:utime\n"
 174             "The CPU time units used by the calling process.\n"
 175             "@item tms:stime\n"
 176             "The CPU time units used by the system on behalf of the calling process.\n"
 177             "@item tms:cutime\n"
 178             "The CPU time units used by terminated child processes of the calling\n"
 179             "process, whose status has been collected (e.g., using @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_make_vector (SCM_MAKINUM(5), SCM_UNDEFINED);
 190   rv = times (&t);
 191   if (rv == -1)
 192     SCM_SYSERROR;
 193   SCM_VELTS (result)[0] = scm_long2num (rv);
 194   SCM_VELTS (result)[1] = scm_long2num (t.tms_utime);
 195   SCM_VELTS (result)[2] = scm_long2num (t.tms_stime);
 196   SCM_VELTS (result)[3] = scm_long2num (t.tms_cutime);
 197   SCM_VELTS (result)[4] = scm_long2num (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             "Returns the number of time units of processor time used by the interpreter.\n"
 214             "Both \"system\" and \"user\" time are included but subprocesses are not.")
 215 #define FUNC_NAME s_scm_get_internal_run_time
 216 {
 217   return scm_long2num (scm_c_get_internal_run_time ());
 218 }
 219 #undef FUNC_NAME
 220
 221 SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
 222            (void),
 223             "Returns the number of seconds since 1970-01-01 00:00:00 UTC, excluding\n"
 224             "leap seconds.")
 225 #define FUNC_NAME s_scm_current_time
 226 {
 227   timet timv;
 228
 229   SCM_DEFER_INTS;
 230   if ((timv = time (0)) == -1)
 231     SCM_SYSERROR;
 232   SCM_ALLOW_INTS;
 233   return scm_long2num((long) timv);
 234 }
 235 #undef FUNC_NAME
 236
 237 SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
 238             (void),
 239             "Returns a pair containing the number of seconds and microseconds since\n"
 240             "1970-01-01 00:00:00 UTC, excluding leap seconds.  Note: whether true\n"
 241             "microsecond resolution is available depends on the operating system.")
 242 #define FUNC_NAME s_scm_gettimeofday
 243 {
 244 #ifdef HAVE_GETTIMEOFDAY
 245   struct timeval time;
 246
 247   SCM_DEFER_INTS;
 248   if (gettimeofday (&time, NULL) == -1)
 249     SCM_SYSERROR;
 250   SCM_ALLOW_INTS;
 251   return scm_cons (scm_long2num ((long) time.tv_sec),
 252                    scm_long2num ((long) time.tv_usec));
 253 #else
 254 # ifdef HAVE_FTIME
 255   struct timeb time;
 256
 257   ftime(&time);
 258   return scm_cons (scm_long2num ((long) time.time),
 259                    SCM_MAKINUM (time.millitm * 1000));
 260 # else
 261   timet timv;
 262
 263   SCM_DEFER_INTS;
 264   if ((timv = time (0)) == -1)
 265     SCM_SYSERROR;
 266   SCM_ALLOW_INTS;
 267   return scm_cons (scm_long2num (timv), SCM_MAKINUM (0));
 268 # endif
 269 #endif
 270 }
 271 #undef FUNC_NAME
 272
 273 static SCM
 274 filltime (struct tm *bd_time, int zoff, char *zname)
 275 {
 276   SCM result = scm_make_vector (SCM_MAKINUM(11), SCM_UNDEFINED);
 277
 278   SCM_VELTS (result)[0] = SCM_MAKINUM (bd_time->tm_sec);
 279   SCM_VELTS (result)[1] = SCM_MAKINUM (bd_time->tm_min);
 280   SCM_VELTS (result)[2] = SCM_MAKINUM (bd_time->tm_hour);
 281   SCM_VELTS (result)[3] = SCM_MAKINUM (bd_time->tm_mday);
 282   SCM_VELTS (result)[4] = SCM_MAKINUM (bd_time->tm_mon);
 283   SCM_VELTS (result)[5] = SCM_MAKINUM (bd_time->tm_year);
 284   SCM_VELTS (result)[6] = SCM_MAKINUM (bd_time->tm_wday);
 285   SCM_VELTS (result)[7] = SCM_MAKINUM (bd_time->tm_yday);
 286   SCM_VELTS (result)[8] = SCM_MAKINUM (bd_time->tm_isdst);
 287   SCM_VELTS (result)[9] = SCM_MAKINUM (zoff);
 288   SCM_VELTS (result)[10] = zname ? scm_makfrom0str (zname) : SCM_BOOL_F;
 289   return result;
 290 }
 291
 292 static char tzvar[3] = "TZ";
 293 extern char ** environ;
 294
 295 /* if zone is set, create a temporary environment with only a TZ
 296    string.  other threads or interrupt handlers shouldn't be allowed
 297    to run until the corresponding restorezone is called.  hence the use
 298    of a static variable for tmpenv is no big deal.  */
 299 static char **
 300 setzone (SCM zone, int pos, const char *subr)
 301 {
 302   char **oldenv = 0;
 303
 304   if (!SCM_UNBNDP (zone))
 305     {
 306       static char *tmpenv[2];
 307       char *buf;
 308
 309       SCM_ASSERT (SCM_STRINGP (zone), zone, pos, subr);
 310       SCM_STRING_COERCE_0TERMINATION_X (zone);
 311       buf = scm_must_malloc (SCM_STRING_LENGTH (zone) + sizeof (tzvar) + 1, subr);
 312       sprintf (buf, "%s=%s", tzvar, SCM_STRING_CHARS (zone));
 313       oldenv = environ;
 314       tmpenv[0] = buf;
 315       tmpenv[1] = 0;
 316       environ = tmpenv;
 317     }
 318   return oldenv;
 319 }
 320
 321 static void
 322 restorezone (SCM zone, char **oldenv, const char *subr)
 323 {
 324   if (!SCM_UNBNDP (zone))
 325     {
 326       scm_must_free (environ[0]);
 327       environ = oldenv;
 328 #ifdef HAVE_TZSET
 329       /* for the possible benefit of user code linked with libguile.  */
 330       tzset();
 331 #endif
 332     }
 333 }
 334
 335 SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
 336             (SCM time, SCM zone),
 337             "Returns an object representing the broken down components of @var{time},\n"
 338             "an integer like the one returned by @code{current-time}.  The time zone\n"
 339             "for the calculation is optionally specified by @var{zone} (a string),\n"
 340             "otherwise the @code{TZ} environment variable or the system default is\n"
 341             "used.")
 342 #define FUNC_NAME s_scm_localtime
 343 {
 344   timet itime;
 345   struct tm *ltptr, lt, *utc;
 346   SCM result;
 347   int zoff;
 348   char *zname = 0;
 349   char **oldenv;
 350   int err;
 351
 352   itime = SCM_NUM2LONG (1,time);
 353
 354   /* deferring interupts is essential since a) setzone may install a temporary
 355      environment b) localtime uses a static buffer.  */
 356   SCM_DEFER_INTS;
 357   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 358 #ifdef LOCALTIME_CACHE
 359   tzset ();
 360 #endif
 361   ltptr = localtime (&itime);
 362   err = errno;
 363   if (ltptr)
 364     {
 365       const char *ptr;
 366
 367       /* copy zone name before calling gmtime or restoring zone.  */
 368 #if defined (HAVE_TM_ZONE)
 369       ptr = ltptr->tm_zone;
 370 #elif defined (HAVE_TZNAME)
 371       ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
 372 #else
 373       ptr = "";
 374 #endif
 375       zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
 376       strcpy (zname, ptr);
 377     }
 378   /* the struct is copied in case localtime and gmtime share a buffer.  */
 379   if (ltptr)
 380     lt = *ltptr;
 381   utc = gmtime (&itime);
 382   if (utc == NULL)
 383     err = errno;
 384   restorezone (zone, oldenv, FUNC_NAME);
 385   /* delayed until zone has been restored.  */
 386   errno = err;
 387   if (utc == NULL || ltptr == NULL)
 388     SCM_SYSERROR;
 389
 390   /* calculate timezone offset in seconds west of UTC.  */
 391   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 392     + utc->tm_sec - lt.tm_sec;
 393   if (utc->tm_year < lt.tm_year)
 394     zoff -= 24 * 60 * 60;
 395   else if (utc->tm_year > lt.tm_year)
 396     zoff += 24 * 60 * 60;
 397   else if (utc->tm_yday < lt.tm_yday)
 398     zoff -= 24 * 60 * 60;
 399   else if (utc->tm_yday > lt.tm_yday)
 400     zoff += 24 * 60 * 60;
 401
 402   result = filltime (&lt, zoff, zname);
 403   SCM_ALLOW_INTS;
 404   scm_must_free (zname);
 405   return result;
 406 }
 407 #undef FUNC_NAME
 408
 409 SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
 410             (SCM time),
 411             "Returns an object representing the broken down components of @var{time},\n"
 412             "an integer like the one returned by @code{current-time}.  The values\n"
 413             "are calculated for UTC.")
 414 #define FUNC_NAME s_scm_gmtime
 415 {
 416   timet itime;
 417   struct tm *bd_time;
 418   SCM result;
 419
 420   itime = SCM_NUM2LONG (1,time);
 421   SCM_DEFER_INTS;
 422   bd_time = gmtime (&itime);
 423   if (bd_time == NULL)
 424     SCM_SYSERROR;
 425   result = filltime (bd_time, 0, "GMT");
 426   SCM_ALLOW_INTS;
 427   return result;
 428 }
 429 #undef FUNC_NAME
 430
 431 /* copy time components from a Scheme object to a struct tm.  */
 432 static void
 433 bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
 434 {
 435   SCM *velts;
 436   int i;
 437
 438   SCM_ASSERT (SCM_VECTORP (sbd_time)
 439               && SCM_VECTOR_LENGTH (sbd_time) == 11,
 440               sbd_time, pos, subr);
 441   velts = SCM_VELTS (sbd_time);
 442   for (i = 0; i < 10; i++)
 443     {
 444       SCM_ASSERT (SCM_INUMP (velts[i]), sbd_time, pos, subr);
 445     }
 446   SCM_ASSERT (SCM_FALSEP (velts[10]) || SCM_STRINGP (velts[10]),
 447               sbd_time, pos, subr);
 448
 449   lt->tm_sec = SCM_INUM (velts[0]);
 450   lt->tm_min = SCM_INUM (velts[1]);
 451   lt->tm_hour = SCM_INUM (velts[2]);
 452   lt->tm_mday = SCM_INUM (velts[3]);
 453   lt->tm_mon = SCM_INUM (velts[4]);
 454   lt->tm_year = SCM_INUM (velts[5]);
 455   lt->tm_wday = SCM_INUM (velts[6]);
 456   lt->tm_yday = SCM_INUM (velts[7]);
 457   lt->tm_isdst = SCM_INUM (velts[8]);
 458 #ifdef HAVE_TM_ZONE
 459   lt->tm_gmtoff = SCM_INUM (velts[9]);
 460   if (SCM_FALSEP (velts[10]))
 461     lt->tm_zone = NULL;
 462   else
 463     lt->tm_zone  = SCM_STRING_CHARS (velts[10]);
 464 #endif
 465 }
 466
 467 SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
 468             (SCM sbd_time, SCM zone),
 469             "@var{bd-time} is an object representing broken down time and @code{zone}\n"
 470             "is an optional time zone specifier (otherwise the TZ environment variable\n"
 471             "or the system default is used).\n\n"
 472             "Returns a pair: the CAR is a corresponding\n"
 473             "integer time value like that returned\n"
 474             "by @code{current-time}; the CDR is a broken down time object, similar to\n"
 475             "as @var{bd-time} but with normalized values.")
 476 #define FUNC_NAME s_scm_mktime
 477 {
 478   timet itime;
 479   struct tm lt, *utc;
 480   SCM result;
 481   int zoff;
 482   char *zname = 0;
 483   char **oldenv;
 484   int err;
 485
 486   bdtime2c (sbd_time, &lt, SCM_ARG1, FUNC_NAME);
 487
 488   SCM_DEFER_INTS;
 489   oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 490 #ifdef LOCALTIME_CACHE
 491   tzset ();
 492 #endif
 493   itime = mktime (&lt);
 494   err = errno;
 495
 496   if (itime != -1)
 497     {
 498       const char *ptr;
 499
 500       /* copy zone name before calling gmtime or restoring the zone.  */
 501 #if defined (HAVE_TM_ZONE)
 502       ptr = lt.tm_zone;
 503 #elif defined (HAVE_TZNAME)
 504       ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
 505 #else
 506       ptr = "";
 507 #endif
 508       zname = SCM_MUST_MALLOC (strlen (ptr) + 1);
 509       strcpy (zname, ptr);
 510     }
 511
 512   /* get timezone offset in seconds west of UTC.  */
 513   utc = gmtime (&itime);
 514   if (utc == NULL)
 515     err = errno;
 516
 517   restorezone (zone, oldenv, FUNC_NAME);
 518   /* delayed until zone has been restored.  */
 519   errno = err;
 520   if (utc == NULL || itime == -1)
 521     SCM_SYSERROR;
 522
 523   zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
 524     + utc->tm_sec - lt.tm_sec;
 525   if (utc->tm_year < lt.tm_year)
 526     zoff -= 24 * 60 * 60;
 527   else if (utc->tm_year > lt.tm_year)
 528     zoff += 24 * 60 * 60;
 529   else if (utc->tm_yday < lt.tm_yday)
 530     zoff -= 24 * 60 * 60;
 531   else if (utc->tm_yday > lt.tm_yday)
 532     zoff += 24 * 60 * 60;
 533
 534   result = scm_cons (scm_long2num ((long) itime),
 535                      filltime (&lt, zoff, zname));
 536   SCM_ALLOW_INTS;
 537   scm_must_free (zname);
 538   return result;
 539 }
 540 #undef FUNC_NAME
 541
 542 #ifdef HAVE_TZSET
 543 SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
 544             (void),
 545             "Initialize the timezone from the TZ environment variable\n"
 546             "or the system default.  It's not usually necessary to call this procedure\n"
 547             "since it's done automatically by other procedures that depend on the\n"
 548             "timezone.")
 549 #define FUNC_NAME s_scm_tzset
 550 {
 551   tzset();
 552   return SCM_UNSPECIFIED;
 553 }
 554 #undef FUNC_NAME
 555 #endif /* HAVE_TZSET */
 556
 557 SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
 558             (SCM format, SCM stime),
 559             "Formats a time specification @var{time} using @var{template}.  @var{time}\n"
 560             "is an object with time components in the form returned by @code{localtime}\n"
 561             "or @code{gmtime}.  @var{template} is a string which can include formatting\n"
 562             "specifications introduced by a @code{%} character.  The formatting of\n"
 563             "month and day names is dependent on the current locale.  The value returned\n"
 564             "is the formatted string.\n"
 565             "@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.)")
 566 #define FUNC_NAME s_scm_strftime
 567 {
 568   struct tm t;
 569
 570   char *tbuf;
 571   int size = 50;
 572   char *fmt, *myfmt;
 573   int len;
 574   SCM result;
 575
 576   SCM_VALIDATE_STRING (1, format);
 577   bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
 578
 579   SCM_STRING_COERCE_0TERMINATION_X (format);
 580   fmt = SCM_STRING_CHARS (format);
 581   len = SCM_STRING_LENGTH (format);
 582
 583   /* Ugly hack: strftime can return 0 if its buffer is too small,
 584      but some valid time strings (e.g. "%p") can sometimes produce
 585      a zero-byte output string!  Workaround is to prepend a junk
 586      character to the format string, so that valid returns are always
 587      nonzero. */
 588   myfmt = SCM_MUST_MALLOC (len+2);
 589   *myfmt = 'x';
 590   strncpy(myfmt+1, fmt, len);
 591   myfmt[len+1] = 0;
 592
 593   tbuf = SCM_MUST_MALLOC (size);
 594   {
 595 #if !defined (HAVE_TM_ZONE)
 596     /* it seems the only way to tell non-GNU versions of strftime what
 597        zone to use (for the %Z format) is to set TZ in the
 598        environment.  interrupts and thread switching must be deferred
 599        until TZ is restored.  */
 600     char **oldenv = NULL;
 601     SCM *velts = SCM_VELTS (stime);
 602     int have_zone = 0;
 603
 604     if (SCM_NFALSEP (velts[10]) && *SCM_STRING_CHARS (velts[10]) != 0)
 605       {
 606         /* it's not required that the TZ setting be correct, just that
 607            it has the right name.  so try something like TZ=EST0.
 608            using only TZ=EST would be simpler but it doesn't work on
 609            some OSs, e.g., Solaris.  */
 610         SCM zone =
 611           scm_string_append (scm_cons (velts[10],
 612                                        scm_cons (scm_makfrom0str ("0"),
 613                                                  SCM_EOL)));
 614
 615         have_zone = 1;
 616         SCM_DEFER_INTS;
 617         oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
 618       }
 619 #endif
 620
 621 #ifdef LOCALTIME_CACHE
 622     tzset ();
 623 #endif
 624
 625     /* POSIX says strftime returns 0 on buffer overrun, but old
 626        systems (i.e. libc 4 on GNU/Linux) might return `size' in that
 627        case. */
 628     while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
 629       {
 630         scm_must_free (tbuf);
 631         size *= 2;
 632         tbuf = SCM_MUST_MALLOC (size);
 633       }
 634
 635 #if !defined (HAVE_TM_ZONE)
 636     if (have_zone)
 637       {
 638         restorezone (velts[10], oldenv, FUNC_NAME);
 639         SCM_ALLOW_INTS;
 640       }
 641 #endif
 642     }
 643
 644   result = scm_makfromstr (tbuf+1, len-1, 0);
 645   scm_must_free (tbuf);
 646   scm_must_free(myfmt);
 647   return result;
 648 }
 649 #undef FUNC_NAME
 650
 651 #ifdef HAVE_STRPTIME
 652 SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
 653             (SCM format, SCM string),
 654             "Performs the reverse action to @code{strftime}, parsing @var{string}\n"
 655             "according to the specification supplied in @var{template}.  The\n"
 656             "interpretation of month and day names is dependent on the current\n"
 657             "locale.  The\n"
 658             "value returned is a pair.  The CAR has an object with time components \n"
 659             "in the form returned by @code{localtime} or @code{gmtime},\n"
 660             "but the time zone components\n"
 661             "are not usefully set.\n"
 662             "The CDR reports the number of characters from @var{string} which\n"
 663             "were used for the conversion.")
 664 #define FUNC_NAME s_scm_strptime
 665 {
 666   struct tm t;
 667   char *fmt, *str, *rest;
 668
 669   SCM_VALIDATE_STRING (1, format);
 670   SCM_VALIDATE_STRING (2, string);
 671
 672   SCM_STRING_COERCE_0TERMINATION_X (format);
 673   SCM_STRING_COERCE_0TERMINATION_X (string);
 674   fmt = SCM_STRING_CHARS (format);
 675   str = SCM_STRING_CHARS (string);
 676
 677   /* initialize the struct tm */
 678 #define tm_init(field) t.field = 0
 679   tm_init (tm_sec);
 680   tm_init (tm_min);
 681   tm_init (tm_hour);
 682   tm_init (tm_mday);
 683   tm_init (tm_mon);
 684   tm_init (tm_year);
 685   tm_init (tm_wday);
 686   tm_init (tm_yday);
 687 #undef tm_init
 688
 689   t.tm_isdst = -1;
 690   SCM_DEFER_INTS;
 691   if ((rest = strptime (str, fmt, &t)) == NULL)
 692     SCM_SYSERROR;
 693
 694   SCM_ALLOW_INTS;
 695   return scm_cons (filltime (&t, 0, NULL),  SCM_MAKINUM (rest - str));
 696 }
 697 #undef FUNC_NAME
 698 #endif /* HAVE_STRPTIME */
 699
 700 void
 701 scm_init_stime()
 702 {
 703   scm_sysintern("internal-time-units-per-second",
 704                 scm_long2num((long)CLKTCK));
 705
 706 #ifdef HAVE_FTIME
 707   if (!scm_your_base.time) ftime(&scm_your_base);
 708 #else
 709   if (!scm_your_base) time(&scm_your_base);
 710 #endif
 711
 712   if (!scm_my_base) scm_my_base = mytime();
 713
 714   scm_add_feature ("current-time");
 715 #ifndef SCM_MAGIC_SNARFER
 716 #include "libguile/stime.x"
 717 #endif
 718 }
 719
 720
 721 /*
 722   Local Variables:
 723   c-file-style: "gnu"
 724   End:
 725 */