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