stime.c 23 KB

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