libguile/stime.c

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