/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- Scm_IntegerToOffset
- Scm_OffsetToInteger
- Scm_SysCall
- Scm_PtrSysCall
- Scm_GetPortFd
- Scm_ReadDirectory
- Scm_GlobDirectory
- Scm_PathDelimiter
- get_first_separator
- get_last_separator
- skip_separators
- truncate_trailing_separators
- put_user_home
- expand_tilde
- put_current_dir
- copy_win32_path
- Scm_NormalizePathname
- Scm_BaseName
- Scm_DirName
- Scm_Mkstemp
- Scm_SysMkstemp
- stat_allocate
- Scm_MakeSysStat
- stat_type_get
- stat_perm_get
- time_allocate
- time_print
- time_compare
- Scm_MakeTime
- Scm_CurrentTime
- Scm_IntSecondsToTime
- Scm_RealSecondsToTime
- time_type_get
- time_type_set
- time_sec_get
- time_sec_set
- time_nsec_get
- time_nsec_set
- Scm_MakeSysTime
- Scm_GetSysTime
- Scm_TimeToSeconds
- Scm_GetTimeSpec
- tm_allocate
- tm_print
- Scm_MakeSysTm
- grp_print
- make_group
- Scm_GetGroupById
- Scm_GetGroupByName
- pwd_print
- make_passwd
- Scm_GetPasswdById
- Scm_GetPasswdByName
- Scm_IsSugid
- Scm_SysExec
- fdset_allocate
- fdset_copy
- select_checkfd
- select_timeval
- select_int
- Scm_SysSelect
- Scm_SysSelectX
- w2mdup
- m2wdup
- convert_user
- getpwnam
- getpwuid
- getgrgid
- getgrnam
- getuid
- geteuid
- getgid
- getegid
- getppid
- fork
- kill
- pipe
- ttyname
- truncate
- ftruncate
- alarm
- link
- Scm__InitSystem
1 /*
2 * system.c - system interface
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: system.c,v 1.71 2005/10/28 02:53:10 shirok Exp $
34 */
35
36 #include <stdio.h>
37 #include <stdlib.h>
38 #include <math.h>
39 #include <unistd.h>
40 #include <dirent.h>
41 #include <locale.h>
42 #include <errno.h>
43 #include <string.h>
44 #include <sys/types.h>
45 #include <sys/stat.h>
46 #include <fcntl.h>
47 #ifndef __MINGW32__
48 #include <grp.h>
49 #include <pwd.h>
50 #else /*__MINGW32__*/
51 #include <windows.h>
52 #include <lm.h>
53 #include <tlhelp32.h>
54 #endif /*__MINGW32__*/
55
56 #define LIBGAUCHE_BODY
57 #include "gauche.h"
58 #include "gauche/class.h"
59 #include "gauche/builtin-syms.h"
60
61 #ifdef HAVE_GLOB_H
62 #include <glob.h>
63 #endif
64
65 /*
66 * Auxiliary system interface functions. See syslib.stub for
67 * Scheme binding.
68 */
69
70 /*
71 * Conversion between off_t and Scheme integer.
72 * off_t might be either 32bit or 64bit. However, as far as I know,
73 * on ILP32 machines off_t is kept 32bits for compabitility and
74 * a separate off64_t is defined for 64bit offset access.
75 * To aim completeness I have to support the case that
76 * sizeof(off_t) > sizeof(long). For the time being, I just signal
77 * an error outside the long value.
78 */
79 off_t Scm_IntegerToOffset(ScmObj i)
80 {
81 if (SCM_INTP(i)) {
82 return (off_t)SCM_INT_VALUE(i);
83 } else if (SCM_BIGNUMP(i)) {
84 if (SCM_BIGNUM_SIZE(i) > 1
85 || SCM_BIGNUM(i)->values[0] > LONG_MAX) {
86 Scm_Error("offset value too large: %S", i);
87 }
88 return (off_t)Scm_GetInteger(i);
89 }
90 Scm_Error("bad value as offset: %S", i);
91 return (off_t)-1; /* dummy */
92 }
93
94 ScmObj Scm_OffsetToInteger(off_t off)
95 {
96 #if SIZEOF_OFF_T == SIZEOF_LONG
97 return Scm_MakeInteger(off);
98 #else
99 if (off <= LONG_MAX && off >= LONG_MIN) {
100 return Scm_MakeInteger(off);
101 } else {
102 Scm_Error("offset value too large to support");
103 return Scm_MakeInteger(-1); /* dummy */
104 }
105 #endif
106 }
107
108 /*===============================================================
109 * OBSOLETED: Wrapper to the system call to handle signals.
110 * Use SCM_SYSCALL_{I|P} macro instead.
111 */
112 int Scm_SysCall(int r)
113 {
114 Scm_Warn("Obsoleted API Scm_SysCall is called.");
115 if (r < 0 && errno == EINTR) {
116 ScmVM *vm = Scm_VM();
117 errno = 0;
118 SCM_SIGCHECK(vm);
119 }
120 return r;
121 }
122
123 void *Scm_PtrSysCall(void *r)
124 {
125 Scm_Warn("Obsoleted API Scm_PtrSysCall is called.");
126 if (r == NULL && errno == EINTR) {
127 ScmVM *vm = Scm_VM();
128 errno = 0;
129 SCM_SIGCHECK(vm);
130 }
131 return r;
132 }
133
134 /*
135 * A utility function for the procedures that accepts either port or
136 * integer file descriptor. Returns the file descriptor. If port_or_fd
137 * is a port that is not associated with the system file, and needfd is
138 * true, signals error. Otherwise it returns -1.
139 */
140 int Scm_GetPortFd(ScmObj port_or_fd, int needfd)
141 {
142 int fd = -1;
143 if (SCM_INTP(port_or_fd)) {
144 fd = SCM_INT_VALUE(port_or_fd);
145 } else if (SCM_PORTP(port_or_fd)) {
146 fd = Scm_PortFileNo(SCM_PORT(port_or_fd));
147 if (fd < 0 && needfd) {
148 Scm_Error("the port is not associated with a system file descriptor: %S",
149 port_or_fd);
150 }
151 } else {
152 Scm_Error("port or small integer required, but got %S", port_or_fd);
153 }
154 return fd;
155 }
156
157 /*===============================================================
158 * Directory primitives (dirent.h)
159 * We don't provide the iterator primitives, but a function which
160 * reads entire directory.
161 */
162
163 /* Returns a list of directory entries. If pathname is not a directory,
164 or can't be opened by some reason, an error is signalled. */
165 ScmObj Scm_ReadDirectory(ScmString *pathname)
166 {
167 ScmObj head = SCM_NIL, tail = SCM_NIL;
168 ScmVM *vm = Scm_VM();
169 struct dirent *dire;
170 DIR *dirp = opendir(Scm_GetStringConst(pathname));
171
172 if (dirp == NULL) {
173 SCM_SIGCHECK(vm);
174 Scm_SysError("couldn't open directory %S", pathname);
175 }
176 while ((dire = readdir(dirp)) != NULL) {
177 ScmObj ent = SCM_MAKE_STR_COPYING(dire->d_name);
178 SCM_APPEND1(head, tail, ent);
179 }
180 SCM_SIGCHECK(vm);
181 closedir(dirp);
182 return head;
183 }
184
185 /* Glob()function. */
186 /* TODO: allow to take optional flags */
187 ScmObj Scm_GlobDirectory(ScmString *pattern)
188 {
189 #if defined(HAVE_GLOB_H)
190 glob_t globbed;
191 ScmObj head = SCM_NIL, tail = SCM_NIL;
192 int i, r;
193 SCM_SYSCALL(r, glob(Scm_GetStringConst(pattern), 0, NULL, &globbed));
194 if (r) {
195 globfree(&globbed);
196 #if defined(GLOB_NOMATCH)
197 if (r == GLOB_NOMATCH) return SCM_NIL;
198 #endif /*!GLOB_NOMATCH*/
199 Scm_Error("Couldn't glob %S", pattern);
200 }
201 for (i = 0; i < globbed.gl_pathc; i++) {
202 ScmObj path = SCM_MAKE_STR_COPYING(globbed.gl_pathv[i]);
203 SCM_APPEND1(head, tail, path);
204 }
205 globfree(&globbed);
206 return head;
207 #elif defined(__MINGW32__)
208 /* We provide alternative using Windows API */
209 HANDLE dirp;
210 WIN32_FIND_DATA fdata;
211 DWORD winerrno;
212 const char *path = Scm_GetStringConst(pattern);
213 ScmObj head = SCM_NIL, tail = SCM_NIL;
214
215 dirp = FindFirstFile(path, &fdata);
216 if (dirp == INVALID_HANDLE_VALUE) {
217 if ((winerrno = GetLastError()) != ERROR_FILE_NOT_FOUND) goto err;
218 return head;
219 }
220 SCM_APPEND1(head, tail, SCM_MAKE_STR_COPYING(fdata.cFileName));
221 while (FindNextFile(dirp, &fdata) != 0) {
222 SCM_APPEND1(head, tail, SCM_MAKE_STR_COPYING(fdata.cFileName));
223 }
224 winerrno = GetLastError();
225 FindClose(dirp);
226 if (winerrno != ERROR_NO_MORE_FILES) goto err;
227 return head;
228 err:
229 Scm_Error("Searching directory failed by windows error %d",
230 winerrno);
231 return SCM_UNDEFINED; /* dummy */
232 #else /*!HAVE_GLOB_H && !__MINGW32__*/
233 Scm_Error("glob-directory is not supported on this architecture.");
234 return SCM_UNDEFINED;
235 #endif /*!HAVE_GLOB_H && !__MINGW32__*/
236 }
237
238 /*===============================================================
239 * Pathname manipulation
240 *
241 * It gets complicated since the byte '/' and '\\' can appear in
242 * the trailing octets of a multibyte character.
243 * Assuming these operations won't be a bottleneck, we use simple and
244 * straightforward code rather than tricky and fast one.
245 */
246
247 /* Returns the system's native pathname delimiter. */
248 const char *Scm_PathDelimiter(void)
249 {
250 #ifndef __MINGW32__
251 return "/";
252 #else /*__MINGW32__*/
253 return "\\";
254 #endif /*__MINGW32__*/
255 }
256
257 #ifdef __MINGW32__
258 #define SEPARATOR '\\'
259 #define ROOTDIR "\\"
260 #else
261 #define SEPARATOR '/'
262 #define ROOTDIR "/"
263 #endif
264
265 /* Returns the pointer to the first path separator character,
266 or NULL if no separator is found. */
267 static const char *get_first_separator(const char *path, const char *end)
268 {
269 const char *p = path;
270 while (p < end) {
271 if (*p == '/' || *p == '\\') return p;
272 p += SCM_CHAR_NFOLLOWS(*p)+1;
273 }
274 return NULL;
275 }
276
277 /* Returns the pointer to the last path separator character,
278 or NULL if no separator is found. */
279 static const char *get_last_separator(const char *path, const char *end)
280 {
281 const char *p = path, *last = NULL;
282 while (p < end) {
283 if (*p == '/' || *p == '\\') last = p;
284 p += SCM_CHAR_NFOLLOWS(*p)+1;
285 }
286 return last;
287 }
288
289 static const char *skip_separators(const char *p, const char *end)
290 {
291 while (p < end) {
292 if (*p != '/' && *p != '\\') break;
293 p += SCM_CHAR_NFOLLOWS(*p)+1;
294 }
295 return p;
296 }
297
298 /* Returns the end pointer sans trailing separators. */
299 static const char *truncate_trailing_separators(const char *path,
300 const char *end)
301 {
302 const char *p = get_first_separator(path, end), *q;
303 if (p == NULL) return end;
304 for (;;) {
305 q = skip_separators(p, end);
306 if (q == end) return p;
307 p = get_first_separator(q, end);
308 if (p == NULL) return end;
309 }
310 }
311
312 /* A utility for tilde expansion. They are called only on
313 Unix variants, so we only need to check '/'. */
314 static void put_user_home(ScmDString *dst,
315 const char *name,
316 const char *end)
317 {
318 struct passwd *pwd;
319 int dirlen;
320
321 if (name == end) {
322 pwd = getpwuid(geteuid());
323 if (pwd == NULL) {
324 Scm_SigCheck(Scm_VM());
325 Scm_SysError("couldn't get home directory.\n");
326 }
327 } else {
328 int namesiz = end - name;
329 char *uname = (char*)SCM_MALLOC_ATOMIC(namesiz+1);
330 memcpy(uname, name, namesiz);
331 uname[namesiz] = '\0';
332 pwd = getpwnam(uname);
333 if (pwd == NULL) {
334 Scm_SigCheck(Scm_VM());
335 Scm_Error("couldn't get home directory of user \"%s\".\n", uname);
336 }
337 }
338 dirlen = strlen(pwd->pw_dir);
339 Scm_DStringPutz(dst, pwd->pw_dir, dirlen);
340 if (pwd->pw_dir[dirlen-1] != '/') Scm_DStringPutc(dst, '/');
341 }
342
343 /* SRC points to the pathname string beginning with '~'. Expand it
344 to the user's home directory, leaving the partial result in DST.
345 Returns the pointer into SRC sans tilde prefix (e.g. removed "~user/").
346 The returned pointer may points just past the last char of SRC. */
347 static const char *expand_tilde(ScmDString *dst,
348 const char *src,
349 const char *end)
350 {
351 struct passwd *pwd;
352 int dirlen;
353 const char *sep = get_first_separator(src, end);
354
355 if (sep == NULL) {
356 put_user_home(dst, src+1, end);
357 return end;
358 } else {
359 put_user_home(dst, src+1, sep);
360 return skip_separators(sep, end);
361 }
362 }
363
364 /* Put current dir to DST */
365 static void put_current_dir(ScmDString *dst)
366 {
367 int dirlen;
368 #define GETCWD_PATH_MAX 1024 /* TODO: must be configured */
369 char p[GETCWD_PATH_MAX];
370 if (getcwd(p, GETCWD_PATH_MAX-1) == NULL) {
371 Scm_SigCheck(Scm_VM());
372 Scm_SysError("couldn't get current directory.");
373 }
374 dirlen = strlen(p);
375 Scm_DStringPutz(dst, p, dirlen);
376 if (p[dirlen-1] != '/' && p[dirlen-1] != '\\') {
377 Scm_DStringPutc(dst, SEPARATOR);
378 }
379 #undef GETCWD_PATH_MAX
380 }
381
382 /* win32 specific; copy pathname with replacing '/' by '\\'. */
383 static void copy_win32_path(ScmDString *dst,
384 const char *srcp,
385 const char *end)
386 {
387 while (srcp < end) {
388 ScmChar ch;
389 if (*srcp == '/' || *srcp == '\\') {
390 Scm_DStringPutc(dst, SEPARATOR);
391 } else {
392 SCM_CHAR_GET(srcp, ch);
393 Scm_DStringPutc(dst, ch);
394 }
395 srcp += SCM_CHAR_NBYTES(ch);
396 }
397 }
398
399 ScmObj Scm_NormalizePathname(ScmString *pathname, int flags)
400 {
401 u_int size;
402 const char *str = Scm_GetStringContent(pathname, &size, NULL, NULL);
403 const char *srcp = str;
404 const char *endp = str + size;
405 ScmDString buf;
406
407 Scm_DStringInit(&buf);
408
409 /* Preprocess. We expand tilde (on unix platform), and prepend the
410 current directory to the relative pathname if absolutize is required.
411 For canonicalization, we also put any absolute prefix into buf, so
412 that srcp points to the relative path part after this. */
413 #if !defined(__MINGW32__)
414 if ((flags & SCM_PATH_EXPAND) && size >= 1 && *str == '~') {
415 srcp = expand_tilde(&buf, srcp, endp);
416 } else if (endp > srcp && *srcp == '/') {
417 /* Path is absolute */
418 if (flags & SCM_PATH_CANONICALIZE) {
419 Scm_DStringPutc(&buf, SEPARATOR);
420 srcp = skip_separators(srcp, endp);
421 }
422 } else {
423 /* Path is relative */
424 if (flags & SCM_PATH_ABSOLUTE) {
425 put_current_dir(&buf);
426 }
427 }
428 if (!(flags & SCM_PATH_CANONICALIZE)) {
429 Scm_DStringPutz(&buf, srcp, endp - srcp);
430 return Scm_DStringGet(&buf, 0);
431 }
432 #else /* __MINGW32__ */
433 if (endp > srcp+1 && isalpha(*srcp) && *(srcp+1) == ':') {
434 /* We first process the Evil Drive Letter */
435 Scm_DStringPutc(&buf, *srcp++);
436 Scm_DStringPutc(&buf, *srcp++);
437 }
438 if (endp > srcp && (*srcp == '/' || *srcp == '\\')) {
439 if (flags & SCM_PATH_CANONICALIZE) {
440 Scm_DStringPutc(&buf, SEPARATOR);
441 srcp = skip_separators(srcp, endp);
442 }
443 } else if (srcp == str) {
444 /* Path is relative (the srcp==str condition rules out the
445 drive letter case */
446 if (flags & SCM_PATH_ABSOLUTE) {
447 put_current_dir(&buf);
448 }
449 }
450 if (!(flags & SCM_PATH_CANONICALIZE)) {
451 copy_win32_path(&buf, srcp, endp);
452 return Scm_DStringGet(&buf, 0);
453 }
454 #endif /* __MINGW32__ */
455
456 /* Canonicalization. We used to have a tricky piece of code here
457 that avoids extra allocations, but have replaced it for
458 simple-minded code, since speed gain here won't contribute to
459 the overall performance anyway. */
460 {
461 ScmObj comps = SCM_NIL; /* reverse list of components */
462 int cnt = 0; /* # of components except ".."'s */
463 int final = FALSE;
464 int wentup = FALSE; /* true if the last loop went up a dir */
465 const char *p;
466
467 for (;;) {
468 p = get_first_separator(srcp, endp);
469 if (p == NULL) {
470 final = TRUE;
471 p = endp;
472 }
473
474 if (p == srcp+1 && *srcp == '.') {
475 /* do nothing */
476 } else if (p == srcp+2 && srcp[0] == '.' && srcp[1] == '.') {
477 if (cnt > 0) {
478 SCM_ASSERT(SCM_PAIRP(comps));
479 comps = SCM_CDR(comps);
480 cnt--;
481 wentup = TRUE;
482 } else {
483 comps = Scm_Cons(SCM_MAKE_STR(".."), comps);
484 wentup = FALSE;
485 }
486 } else {
487 comps = Scm_Cons(Scm_MakeString(srcp, p-srcp, -1, 0), comps);
488 cnt++;
489 wentup = FALSE;
490 }
491 if (final) {
492 /* If we just went up a directory, we want to preserve the
493 trailing separator in the result. So we add an empty
494 component. */
495 if (wentup) comps = Scm_Cons(SCM_MAKE_STR(""), comps);
496 break;
497 }
498 srcp = skip_separators(p, endp);
499 }
500 if (SCM_PAIRP(comps)) {
501 comps = Scm_ReverseX(comps);
502 Scm_DStringAdd(&buf, SCM_STRING(SCM_CAR(comps)));
503 SCM_FOR_EACH(comps, SCM_CDR(comps)) {
504 Scm_DStringPutc(&buf, SEPARATOR);
505 Scm_DStringAdd(&buf, SCM_STRING(SCM_CAR(comps)));
506 }
507 }
508 }
509 return Scm_DStringGet(&buf, 0);
510 }
511
512 ScmObj Scm_BaseName(ScmString *filename)
513 {
514 u_int size;
515 const char *path = Scm_GetStringContent(filename, &size, NULL, NULL);
516 const char *endp, *last;
517
518 if (size == 0) return SCM_MAKE_STR("");
519 endp = truncate_trailing_separators(path, path+size);
520 last = get_last_separator(path, endp);
521 if (last == NULL) {
522 return Scm_MakeString(path, endp-path, -1, 0);
523 } else {
524 return Scm_MakeString(last+1, endp-last-1, -1, 0);
525 }
526 }
527
528 ScmObj Scm_DirName(ScmString *filename)
529 {
530 u_int size;
531 const char *path = Scm_GetStringContent(filename, &size, NULL, NULL);
532 const char *endp, *last;
533
534 if (size == 0) return SCM_MAKE_STR(".");
535 endp = truncate_trailing_separators(path, path+size);
536 if (endp == path) return SCM_MAKE_STR(ROOTDIR);
537 last = get_last_separator(path, endp);
538 if (last == NULL) {
539 return SCM_MAKE_STR(".");
540 }
541
542 /* we have "something/", and 'last' points to the last separator. */
543 last = truncate_trailing_separators(path, last);
544 return Scm_MakeString(path, last-path, -1, 0);
545 }
546
547 #undef ROOTDIR
548 #undef SEPARATOR
549
550 /* Make mkstemp() work even if the system doesn't have one. */
551 int Scm_Mkstemp(char *templat)
552 {
553 int fd = -1;
554 #if defined(HAVE_MKSTEMP)
555 SCM_SYSCALL(fd, mkstemp(templat));
556 if (fd < 0) Scm_SysError("mkstemp failed");
557 return fd;
558 #else /*!defined(HAVE_MKSTEMP)*/
559 /* Emulate mkstemp. */
560 int siz = strlen(templat);
561 if (siz < 6) {
562 Scm_Error("mkstemp - invalid template: %s", templat);
563 }
564 #define MKSTEMP_MAX_TRIALS 65535 /* avoid infinite loop */
565 {
566 u_long seed = (u_long)time(NULL);
567 int numtry, flags;
568 char suffix[7];
569 #if defined(__MINGW32__)
570 flags = O_CREAT|O_EXCL|O_WRONLY|O_BINARY;
571 #else /* !__MINGW32__ */
572 flags = O_CREAT|O_EXCL|O_WRONLY;
573 #endif /* !__MINGW32__ */
574 for (numtry=0; numtry<MKSTEMP_MAX_TRIALS; numtry++) {
575 snprintf(suffix, 7, "%06x", seed&0xffffff);
576 memcpy(templat+siz-6, suffix, 7);
577 SCM_SYSCALL(fd, open(templat, flags, 0600));
578 if (fd >= 0) break;
579 seed *= 2654435761UL;
580 }
581 if (numtry == MKSTEMP_MAX_TRIALS) {
582 Scm_Error("mkstemp failed");
583 }
584 }
585 return fd;
586 #endif /*!defined(HAVE_MKSTEMP)*/
587 }
588
589
590 ScmObj Scm_SysMkstemp(ScmString *templat)
591 {
592 #define MKSTEMP_PATH_MAX 1025 /* Geez, remove me */
593 char name[MKSTEMP_PATH_MAX];
594 ScmObj sname;
595 u_int siz;
596 int fd;
597 const char *t = Scm_GetStringContent(templat, &siz, NULL, NULL);
598 if (siz >= MKSTEMP_PATH_MAX-6) {
599 Scm_Error("pathname too long: %S", templat);
600 }
601 memcpy(name, t, siz);
602 memcpy(name + siz, "XXXXXX", 6);
603 name[siz+6] = '\0';
604 fd = Scm_Mkstemp(name);
605 sname = SCM_MAKE_STR_COPYING(name);
606 SCM_RETURN(Scm_Values2(Scm_MakePortWithFd(sname, SCM_PORT_OUTPUT, fd,
607 SCM_PORT_BUFFER_FULL, TRUE),
608 sname));
609 }
610
611 /*===============================================================
612 * Stat (sys/stat.h)
613 */
614
615 static ScmObj stat_allocate(ScmClass *klass, ScmObj initargs)
616 {
617 ScmSysStat *s = SCM_ALLOCATE(ScmSysStat, klass);
618 SCM_SET_CLASS(s, SCM_CLASS_SYS_STAT);
619 return SCM_OBJ(s);
620 }
621
622 SCM_DEFINE_BUILTIN_CLASS(Scm_SysStatClass,
623 NULL, NULL, NULL,
624 stat_allocate,
625 SCM_CLASS_DEFAULT_CPL);
626
627 ScmObj Scm_MakeSysStat(void)
628 {
629 return stat_allocate(&Scm_SysStatClass, SCM_NIL);
630 }
631
632 static ScmObj stat_type_get(ScmSysStat *stat)
633 {
634 if (S_ISDIR(stat->statrec.st_mode)) return (SCM_SYM_DIRECTORY);
635 if (S_ISREG(stat->statrec.st_mode)) return (SCM_SYM_REGULAR);
636 if (S_ISCHR(stat->statrec.st_mode)) return (SCM_SYM_CHARACTER);
637 if (S_ISBLK(stat->statrec.st_mode)) return (SCM_SYM_BLOCK);
638 if (S_ISFIFO(stat->statrec.st_mode)) return (SCM_SYM_FIFO);
639 #ifdef S_ISLNK
640 if (S_ISLNK(stat->statrec.st_mode)) return (SCM_SYM_SYMLINK);
641 #endif
642 #ifdef S_ISSOCK
643 if (S_ISSOCK(stat->statrec.st_mode)) return (SCM_SYM_SOCKET);
644 #endif
645 return (SCM_FALSE);
646 }
647
648 static ScmObj stat_perm_get(ScmSysStat *stat)
649 {
650 return Scm_MakeIntegerFromUI(stat->statrec.st_mode & 0777);
651 }
652
653 #define STAT_GETTER_UI(name) \
654 static ScmObj SCM_CPP_CAT3(stat_, name, _get)(ScmSysStat *s) \
655 { return Scm_MakeIntegerFromUI((u_long)s->statrec.SCM_CPP_CAT(st_, name)); }
656 #define STAT_GETTER_TIME(name) \
657 static ScmObj SCM_CPP_CAT3(stat_, name, _get)(ScmSysStat *s) \
658 { return Scm_MakeSysTime(s->statrec.SCM_CPP_CAT(st_, name)); }
659
660 STAT_GETTER_UI(mode)
661 STAT_GETTER_UI(ino)
662 STAT_GETTER_UI(dev)
663 STAT_GETTER_UI(rdev)
664 STAT_GETTER_UI(nlink)
665 STAT_GETTER_UI(uid)
666 STAT_GETTER_UI(gid)
667 STAT_GETTER_UI(size) /*TODO: check portability of off_t (maybe 64bits)*/
668 STAT_GETTER_TIME(atime)
669 STAT_GETTER_TIME(mtime)
670 STAT_GETTER_TIME(ctime)
671
672 static ScmClassStaticSlotSpec stat_slots[] = {
673 SCM_CLASS_SLOT_SPEC("type", stat_type_get, NULL),
674 SCM_CLASS_SLOT_SPEC("perm", stat_perm_get, NULL),
675 SCM_CLASS_SLOT_SPEC("mode", stat_mode_get, NULL),
676 SCM_CLASS_SLOT_SPEC("ino", stat_ino_get, NULL),
677 SCM_CLASS_SLOT_SPEC("dev", stat_dev_get, NULL),
678 SCM_CLASS_SLOT_SPEC("rdev", stat_rdev_get, NULL),
679 SCM_CLASS_SLOT_SPEC("nlink", stat_nlink_get, NULL),
680 SCM_CLASS_SLOT_SPEC("uid", stat_uid_get, NULL),
681 SCM_CLASS_SLOT_SPEC("gid", stat_gid_get, NULL),
682 SCM_CLASS_SLOT_SPEC("size", stat_size_get, NULL),
683 SCM_CLASS_SLOT_SPEC("atime", stat_atime_get, NULL),
684 SCM_CLASS_SLOT_SPEC("mtime", stat_mtime_get, NULL),
685 SCM_CLASS_SLOT_SPEC("ctime", stat_ctime_get, NULL),
686 { NULL }
687 };
688
689 /*===============================================================
690 * Time (sys/time.h)
691 */
692
693 /* Gauche has two notion of time. A simple number is used by the low-level
694 * system interface (sys-time, sys-gettimeofday). An object of <time> class
695 * is used for higher-level interface, including threads.
696 */
697
698 /* <time> object */
699
700 static ScmObj time_allocate(ScmClass *klass, ScmObj initargs)
701 {
702 ScmTime *t = SCM_ALLOCATE(ScmTime, klass);
703 SCM_SET_CLASS(t, SCM_CLASS_TIME);
704 t->type = SCM_SYM_TIME_UTC;
705 t->sec = t->nsec = 0;
706 return SCM_OBJ(t);
707 }
708
709 static void time_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
710 {
711 ScmTime *t = SCM_TIME(obj);
712 Scm_Printf(port, "#<%S %lu.%09lu>", t->type, t->sec, t->nsec);
713 }
714
715 static int time_compare(ScmObj x, ScmObj y, int equalp)
716 {
717 ScmTime *tx = SCM_TIME(x);
718 ScmTime *ty = SCM_TIME(y);
719
720 if (equalp) {
721 if (SCM_EQ(tx->type, ty->type)
722 && tx->sec == ty->sec
723 && tx->nsec == ty->nsec) {
724 return 0;
725 } else {
726 return 1;
727 }
728 } else {
729 if (!SCM_EQ(tx->type, ty->type)) {
730 Scm_Error("cannot compare different types of time objects: %S vs %S", x, y);
731 }
732 if (tx->sec < ty->sec) return -1;
733 if (tx->sec == ty->sec) {
734 if (tx->nsec < ty->nsec) return -1;
735 if (tx->nsec == ty->nsec) return 0;
736 else return 1;
737 }
738 else return 1;
739 }
740 }
741
742 SCM_DEFINE_BUILTIN_CLASS(Scm_TimeClass,
743 time_print, time_compare, NULL,
744 time_allocate, SCM_CLASS_DEFAULT_CPL);
745
746 ScmObj Scm_MakeTime(ScmObj type, long sec, long nsec)
747 {
748 ScmTime *t = SCM_TIME(time_allocate(SCM_CLASS_TIME, SCM_NIL));
749 t->type = SCM_FALSEP(type)? SCM_SYM_TIME_UTC : type;
750 t->sec = sec;
751 t->nsec = nsec;
752 return SCM_OBJ(t);
753 }
754
755 ScmObj Scm_CurrentTime(void)
756 {
757 #ifdef HAVE_GETTIMEOFDAY
758 struct timeval tv;
759 int r;
760 SCM_SYSCALL(r, gettimeofday(&tv, NULL));
761 if (r < 0) Scm_SysError("gettimeofday failed");
762 return Scm_MakeTime(SCM_SYM_TIME_UTC, (long)tv.tv_sec, (long)tv.tv_usec*1000);
763 #else /* !HAVE_GETTIMEOFDAY */
764 return Scm_MakeTime(SCM_SYM_TIME_UTC, (long)time(NULL), 0);
765 #endif /* !HAVE_GETTIMEOFDAY */
766 }
767
768 ScmObj Scm_IntSecondsToTime(long sec)
769 {
770 return Scm_MakeTime(SCM_SYM_TIME_UTC, sec, 0);
771 }
772
773 ScmObj Scm_RealSecondsToTime(double sec)
774 {
775 double s, frac;
776 if (sec > (double)ULONG_MAX || sec < 0) {
777 Scm_Error("seconds out of range: %f", sec);
778 }
779 frac = modf(sec, &s);
780 return Scm_MakeTime(SCM_SYM_TIME_UTC, (long)s, (long)(frac * 1.0e9));
781 }
782
783 static ScmObj time_type_get(ScmTime *t)
784 {
785 return t->type;
786 }
787
788 static void time_type_set(ScmTime *t, ScmObj val)
789 {
790 if (!SCM_SYMBOLP(val)) {
791 Scm_Error("time type must be a symbol, but got %S", val);
792 }
793 t->type = val;
794 }
795
796 static ScmObj time_sec_get(ScmTime *t)
797 {
798 return Scm_MakeInteger(t->sec);
799 }
800
801 static void time_sec_set(ScmTime *t, ScmObj val)
802 {
803 if (!SCM_REALP(val)) {
804 Scm_Error("real number required, but got %S", val);
805 }
806 t->sec = Scm_GetInteger(val);
807 }
808
809 static ScmObj time_nsec_get(ScmTime *t)
810 {
811 return Scm_MakeInteger(t->nsec);
812 }
813
814 static void time_nsec_set(ScmTime *t, ScmObj val)
815 {
816 long l;
817 if (!SCM_REALP(val)) {
818 Scm_Error("real number required, but got %S", val);
819 }
820 if ((l = Scm_GetInteger(val)) >= 1000000000) {
821 Scm_Error("nanoseconds out of range: %ld", l);
822 }
823 t->nsec = l;
824 }
825
826 static ScmClassStaticSlotSpec time_slots[] = {
827 SCM_CLASS_SLOT_SPEC("type", time_type_get, time_type_set),
828 SCM_CLASS_SLOT_SPEC("second", time_sec_get, time_sec_set),
829 SCM_CLASS_SLOT_SPEC("nanosecond", time_nsec_get, time_nsec_set),
830 {NULL}
831 };
832
833 /* time_t and conversion routines */
834 /* NB: I assume time_t is typedefed to either an integral type or
835 * a floating point type. As far as I know it is true on most
836 * current architectures. POSIX doesn't specify so, however; it
837 * may be some weird structure. If you find such an architecture,
838 * tweak configure.in and modify the following two functions.
839 */
840 ScmObj Scm_MakeSysTime(time_t t)
841 {
842 #ifdef INTEGRAL_TIME_T
843 return Scm_MakeIntegerFromUI((unsigned long)t);
844 #else
845 double val = (double)t;
846 return Scm_MakeFlonum(val);
847 #endif
848 }
849
850 time_t Scm_GetSysTime(ScmObj val)
851 {
852 if (SCM_TIMEP(val)) {
853 #ifdef INTEGRAL_TIME_T
854 return (time_t)SCM_TIME(val)->sec;
855 #else
856 return (time_t)((double)SCM_TIME(val)->sec +
857 (double)SCM_TIME(val)->nsec/1.0e9);
858 #endif
859 } else if (SCM_NUMBERP(val)) {
860 #ifdef INTEGRAL_TIME_T
861 return (time_t)Scm_GetUInteger(val);
862 #else
863 return (time_t)Scm_GetDouble(val);
864 #endif
865 } else {
866 Scm_Error("bad time value: either a <time> object or a real number is required, but got %S", val);
867 return (time_t)0; /* dummy */
868 }
869 }
870
871 ScmObj Scm_TimeToSeconds(ScmTime *t)
872 {
873 if (t->nsec) {
874 return Scm_MakeFlonum((double)t->sec + (double)t->nsec/1.0e9);
875 } else {
876 return Scm_MakeIntegerFromUI(t->sec);
877 }
878 }
879
880 #if defined(HAVE_STRUCT_TIMESPEC) || defined (GAUCHE_USE_PTHREADS)
881 /* Scheme time -> timespec conversion, used by pthread routines.*/
882 struct timespec *Scm_GetTimeSpec(ScmObj t, struct timespec *spec)
883 {
884 if (SCM_FALSEP(t)) return NULL;
885 if (SCM_TIMEP(t)) {
886 spec->tv_sec = SCM_TIME(t)->sec;
887 spec->tv_nsec = SCM_TIME(t)->nsec;
888 } else if (!SCM_REALP(t)) {
889 Scm_Error("bad timeout spec: <time> object or real number is required, but got %S", t);
890 } else {
891 ScmTime *ct = SCM_TIME(Scm_CurrentTime());
892 spec->tv_sec = ct->sec;
893 spec->tv_nsec = ct->nsec;
894 if (SCM_EXACTP(t)) {
895 spec->tv_sec += Scm_GetUInteger(t);
896 } else if (SCM_FLONUMP(t)) {
897 double s;
898 spec->tv_nsec += (unsigned long)(modf(Scm_GetDouble(t), &s)*1.0e9);
899 spec->tv_sec += (unsigned long)s;
900 while (spec->tv_nsec >= 1000000000) {
901 spec->tv_nsec -= 1000000000;
902 spec->tv_sec += 1;
903 }
904 } else {
905 Scm_Panic("implementation error: Scm_GetTimeSpec: something wrong");
906 }
907 }
908 return spec;
909 }
910 #endif /* defined(HAVE_STRUCT_TIMESPEC) || defined (GAUCHE_USE_PTHREADS) */
911
912 /* <sys-tm> object */
913
914 static ScmObj tm_allocate(ScmClass *klass, ScmObj initargs)
915 {
916 ScmSysTm *st = SCM_ALLOCATE(ScmSysTm, klass);
917 SCM_SET_CLASS(st, SCM_CLASS_SYS_TM);
918 return SCM_OBJ(st);
919 }
920
921 static void tm_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
922 {
923 #define TM_BUFSIZ 50
924 char buf[TM_BUFSIZ];
925 ScmSysTm *st = SCM_SYS_TM(obj);
926 strftime(buf, TM_BUFSIZ, "%a %b %e %T %Y", &st->tm);
927 Scm_Printf(port, "#<sys-tm \"%s\">", buf);
928 #undef TM_BUFSIZ
929 }
930
931 SCM_DEFINE_BUILTIN_CLASS(Scm_SysTmClass,
932 tm_print, NULL, NULL,
933 tm_allocate, SCM_CLASS_DEFAULT_CPL);
934
935 ScmObj Scm_MakeSysTm(struct tm *tm)
936 {
937 ScmSysTm *st = SCM_NEW(ScmSysTm);
938 SCM_SET_CLASS(st, SCM_CLASS_SYS_TM);
939 st->tm = *tm; /* copy */
940 return SCM_OBJ(st);
941 }
942
943 #define TM_ACCESSOR(name) \
944 static ScmObj SCM_CPP_CAT(name, _get)(ScmSysTm *tm) { \
945 return Scm_MakeInteger(tm->tm.name); \
946 } \
947 static void SCM_CPP_CAT(name, _set)(ScmSysTm *tm, ScmObj val) { \
948 if (!SCM_EXACTP(val)) \
949 Scm_Error("exact integer required, but got %S", val); \
950 tm->tm.name = Scm_GetInteger(val); \
951 }
952
953 TM_ACCESSOR(tm_sec)
954 TM_ACCESSOR(tm_min)
955 TM_ACCESSOR(tm_hour)
956 TM_ACCESSOR(tm_mday)
957 TM_ACCESSOR(tm_mon)
958 TM_ACCESSOR(tm_year)
959 TM_ACCESSOR(tm_wday)
960 TM_ACCESSOR(tm_yday)
961 TM_ACCESSOR(tm_isdst)
962
963 static ScmClassStaticSlotSpec tm_slots[] = {
964 SCM_CLASS_SLOT_SPEC("sec", tm_sec_get, tm_sec_set),
965 SCM_CLASS_SLOT_SPEC("min", tm_min_get, tm_min_set),
966 SCM_CLASS_SLOT_SPEC("hour", tm_hour_get, tm_hour_set),
967 SCM_CLASS_SLOT_SPEC("mday", tm_mday_get, tm_mday_set),
968 SCM_CLASS_SLOT_SPEC("mon", tm_mon_get, tm_mon_set),
969 SCM_CLASS_SLOT_SPEC("year", tm_year_get, tm_year_set),
970 SCM_CLASS_SLOT_SPEC("wday", tm_wday_get, tm_wday_set),
971 SCM_CLASS_SLOT_SPEC("yday", tm_yday_get, tm_yday_set),
972 SCM_CLASS_SLOT_SPEC("isdst", tm_isdst_get, tm_isdst_set),
973 { NULL }
974 };
975
976 /*===============================================================
977 * Groups (grp.h)
978 */
979
980 static void grp_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
981 {
982 Scm_Printf(port, "#<sys-group %S>",
983 SCM_SYS_GROUP(obj)->name);
984 }
985
986 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SysGroupClass, grp_print);
987
988 static ScmObj make_group(struct group *g)
989 {
990 ScmObj head = SCM_NIL, tail = SCM_NIL, p;
991 char **memp;
992 ScmSysGroup *sg = SCM_NEW(ScmSysGroup);
993 SCM_SET_CLASS(sg, SCM_CLASS_SYS_GROUP);
994
995 sg->name = SCM_MAKE_STR_COPYING(g->gr_name);
996 #ifdef HAVE_GR_PASSWD
997 sg->passwd = SCM_MAKE_STR_COPYING(g->gr_passwd);
998 #else
999 sg->passwd = SCM_FALSE;
1000 #endif
1001 sg->gid = Scm_MakeInteger(g->gr_gid);
1002 for (memp = g->gr_mem; *memp; memp++) {
1003 p = SCM_MAKE_STR_COPYING(*memp);
1004 SCM_APPEND1(head, tail, p);
1005 }
1006 sg->mem = head;
1007 return SCM_OBJ(sg);
1008 }
1009
1010 ScmObj Scm_GetGroupById(gid_t gid)
1011 {
1012 struct group *gdata;
1013 gdata = getgrgid(gid);
1014 if (gdata == NULL) {
1015 Scm_SigCheck(Scm_VM());
1016 return SCM_FALSE;
1017 } else {
1018 return make_group(gdata);
1019 }
1020 }
1021
1022 ScmObj Scm_GetGroupByName(ScmString *name)
1023 {
1024 struct group *gdata;
1025 gdata = getgrnam(Scm_GetStringConst(name));
1026 if (gdata == NULL) {
1027 Scm_SigCheck(Scm_VM());
1028 return SCM_FALSE;
1029 } else {
1030 return make_group(gdata);
1031 }
1032 }
1033
1034 #define GRP_GETTER(name) \
1035 static ScmObj SCM_CPP_CAT3(grp_, name, _get)(ScmSysGroup *s) \
1036 { return s->name; }
1037
1038 GRP_GETTER(name)
1039 GRP_GETTER(gid)
1040 GRP_GETTER(passwd)
1041 GRP_GETTER(mem)
1042
1043 static ScmClassStaticSlotSpec grp_slots[] = {
1044 SCM_CLASS_SLOT_SPEC("name", grp_name_get, NULL),
1045 SCM_CLASS_SLOT_SPEC("gid", grp_gid_get, NULL),
1046 SCM_CLASS_SLOT_SPEC("passwd", grp_passwd_get, NULL),
1047 SCM_CLASS_SLOT_SPEC("mem", grp_mem_get, NULL),
1048 { NULL }
1049 };
1050
1051 /*===============================================================
1052 * Passwords (pwd.h)
1053 * Patch provided by Yuuki Takahashi (t.yuuki@mbc.nifty.com)
1054 */
1055
1056 static void pwd_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
1057 {
1058 Scm_Printf(port, "#<sys-passwd %S>",
1059 SCM_SYS_PASSWD(obj)->name);
1060 }
1061
1062 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_SysPasswdClass, pwd_print);
1063
1064 static ScmObj make_passwd(struct passwd *pw)
1065 {
1066 ScmSysPasswd *sp = SCM_NEW(ScmSysPasswd);
1067 SCM_SET_CLASS(sp, SCM_CLASS_SYS_PASSWD);
1068
1069 sp->name = SCM_MAKE_STR_COPYING(pw->pw_name);
1070 sp->uid = Scm_MakeInteger(pw->pw_uid);
1071 sp->gid = Scm_MakeInteger(pw->pw_gid);
1072 #ifdef HAVE_PW_PASSWD
1073 sp->passwd = SCM_MAKE_STR_COPYING(pw->pw_passwd);
1074 #else
1075 sp->passwd = SCM_FALSE;
1076 #endif
1077 #ifdef HAVE_PW_GECOS
1078 sp->gecos = SCM_MAKE_STR_COPYING(pw->pw_gecos);
1079 #else
1080 sp->gecos = SCM_FALSE;
1081 #endif
1082 #ifdef HAVE_PW_CLASS
1083 sp->pwclass = SCM_MAKE_STR_COPYING(pw->pw_class);
1084 #else
1085 sp->pwclass = SCM_FALSE;
1086 #endif
1087 sp->dir = SCM_MAKE_STR_COPYING(pw->pw_dir);
1088 sp->shell = SCM_MAKE_STR_COPYING(pw->pw_shell);
1089 return SCM_OBJ(sp);
1090 }
1091
1092 ScmObj Scm_GetPasswdById(uid_t uid)
1093 {
1094 struct passwd *pdata;
1095 pdata = getpwuid(uid);
1096 if (pdata == NULL) {
1097 Scm_SigCheck(Scm_VM());
1098 return SCM_FALSE;
1099 } else {
1100 return make_passwd(pdata);
1101 }
1102 }
1103
1104 ScmObj Scm_GetPasswdByName(ScmString *name)
1105 {
1106 struct passwd *pdata;
1107 pdata = getpwnam(Scm_GetStringConst(name));
1108 if (pdata == NULL) {
1109 Scm_SigCheck(Scm_VM());
1110 return SCM_FALSE;
1111 } else {
1112 return make_passwd(pdata);
1113 }
1114 }
1115
1116 #define PWD_GETTER(name) \
1117 static ScmObj SCM_CPP_CAT3(pwd_, name, _get)(ScmSysPasswd *p) \
1118 { return p->name; }
1119
1120 PWD_GETTER(name)
1121 PWD_GETTER(uid)
1122 PWD_GETTER(gid)
1123 PWD_GETTER(passwd)
1124 PWD_GETTER(gecos)
1125 PWD_GETTER(dir)
1126 PWD_GETTER(shell)
1127 PWD_GETTER(pwclass)
1128
1129 static ScmClassStaticSlotSpec pwd_slots[] = {
1130 SCM_CLASS_SLOT_SPEC("name", pwd_name_get, NULL),
1131 SCM_CLASS_SLOT_SPEC("uid", pwd_uid_get, NULL),
1132 SCM_CLASS_SLOT_SPEC("gid", pwd_gid_get, NULL),
1133 SCM_CLASS_SLOT_SPEC("passwd", pwd_passwd_get, NULL),
1134 SCM_CLASS_SLOT_SPEC("gecos", pwd_gecos_get, NULL),
1135 SCM_CLASS_SLOT_SPEC("dir", pwd_dir_get, NULL),
1136 SCM_CLASS_SLOT_SPEC("shell", pwd_shell_get, NULL),
1137 SCM_CLASS_SLOT_SPEC("class", pwd_pwclass_get, NULL),
1138 { NULL }
1139 };
1140
1141 /*
1142 * check if we're suid/sgid-ed.
1143 * TODO: some system has a special syscall for it; use it if so.
1144 */
1145 int Scm_IsSugid(void)
1146 {
1147 #ifndef __MINGW32__
1148 return (geteuid() != getuid() || getegid() != getgid());
1149 #else /*__MINGW32__*/
1150 return FALSE;
1151 #endif /*__MINGW32__*/
1152 }
1153
1154 /*===============================================================
1155 * Exec
1156 * execvp(), with optionally setting stdios correctly.
1157 *
1158 * iomap argument, when provided, specifies how the open file descriptors
1159 * are treated. If it is not a pair, nothing will be changed for open
1160 * file descriptors. If it is a pair, it must be a list of
1161 * (<to> . <from>), where <tofd> is an integer file descriptor that
1162 * executed process will get, and <from> is either an integer file descriptor
1163 * or a port. If a list is passed to iomap, any file descriptors other
1164 * than specified in the list will be closed before exec().
1165 *
1166 * If forkp arg is TRUE, this function forks before swapping file
1167 * descriptors. It is more reliable way to fork&exec in multi-threaded
1168 * program. In such a case, this function returns Scheme integer to
1169 * show the children's pid. If for arg is FALSE, this procedure
1170 * of course never returns.
1171 *
1172 * On Windows/MinGW port, I'm not sure we can do I/O swapping in
1173 * reasonable way. For now, iomap is ignored.
1174 */
1175
1176 ScmObj Scm_SysExec(ScmString *file, ScmObj args, ScmObj iomap, int forkp)
1177 {
1178 int argc = Scm_Length(args), i, j, maxfd, iollen;
1179 int *tofd = NULL, *fromfd = NULL, *tmpfd = NULL;
1180 char **argv;
1181 const char *program;
1182 ScmObj ap, iop;
1183 pid_t pid = 0;
1184
1185 if (argc < 1) {
1186 Scm_Error("argument list must have at least one element: %S", args);
1187 }
1188
1189 /* make a C array of C strings */
1190 argv = SCM_NEW_ARRAY(char *, argc+1);
1191 for (i=0, ap = args; i<argc; i++, ap = SCM_CDR(ap)) {
1192 if (!SCM_STRINGP(SCM_CAR(ap)))
1193 Scm_Error("bad argument (string required): %S", SCM_CAR(ap));
1194 argv[i] = Scm_GetString(SCM_STRING(SCM_CAR(ap)));
1195 }
1196 argv[i] = NULL;
1197 program = Scm_GetStringConst(file);
1198
1199 #ifndef __MINGW32__
1200 /* setting up iomap table */
1201 iollen = Scm_Length(iomap);
1202 if (SCM_PAIRP(iomap)) {
1203 /* check argument vailidity before duping file descriptors, so that
1204 we can still use Scm_Error */
1205 if (iollen < 0) {
1206 Scm_Error("proper list required for iolist, but got %S", iomap);
1207 }
1208 tofd = SCM_NEW_ATOMIC2(int *, iollen * sizeof(int));
1209 fromfd = SCM_NEW_ATOMIC2(int *, iollen * sizeof(int));
1210 tmpfd = SCM_NEW_ATOMIC2(int *, iollen * sizeof(int));
1211 i = 0;
1212 SCM_FOR_EACH(iop, iomap) {
1213 ScmObj port, elt = SCM_CAR(iop);
1214 if (!SCM_PAIRP(elt) || !SCM_INTP(SCM_CAR(elt))
1215 || (!SCM_PORTP(SCM_CDR(elt)) && !SCM_INTP(SCM_CDR(elt)))) {
1216 Scm_Error("bad iomap specification: needs (int . int-or-port): %S", elt);
1217 }
1218 tofd[i] = SCM_INT_VALUE(SCM_CAR(elt));
1219 if (SCM_INTP(SCM_CDR(elt))) {
1220 fromfd[i] = SCM_INT_VALUE(SCM_CDR(elt));
1221 } else {
1222 port = SCM_CDAR(iop);
1223 fromfd[i] = Scm_PortFileNo(SCM_PORT(port));
1224 if (fromfd[i] < 0) {
1225 Scm_Error("iolist requires a port that has associated file descriptor, but got %S",
1226 SCM_CDAR(iop));
1227 }
1228 if (tofd[i] == 0 && !SCM_IPORTP(port))
1229 Scm_Error("input port required to make it stdin: %S",
1230 port);
1231 if (tofd[i] == 1 && !SCM_OPORTP(port))
1232 Scm_Error("output port required to make it stdout: %S",
1233 port);
1234 if (tofd[i] == 2 && !SCM_OPORTP(port))
1235 Scm_Error("output port required to make it stderr: %S",
1236 port);
1237 }
1238 i++;
1239 }
1240 }
1241
1242 /* When requested, call fork() here. */
1243 if (forkp) {
1244 SCM_SYSCALL(pid, fork());
1245 if (pid < 0) Scm_SysError("fork failed");
1246 }
1247
1248 /* Now we swap file descriptors and exec().
1249 We can't throw an error anymore! */
1250 if (!forkp || pid == 0) {
1251 /* TODO: use getdtablehi if available */
1252 if ((maxfd = sysconf(_SC_OPEN_MAX)) < 0) {
1253 Scm_Panic("failed to get OPEN_MAX value from sysconf");
1254 }
1255
1256 for (i=0; i<iollen; i++) {
1257 if (tofd[i] == fromfd[i]) continue;
1258 for (j=i+1; j<iollen; j++) {
1259 if (tofd[i] == fromfd[j]) {
1260 int tmp = dup(tofd[i]);
1261 if (tmp < 0) Scm_Panic("dup failed: %s", strerror(errno));
1262 fromfd[j] = tmp;
1263 }
1264 }
1265 if (dup2(fromfd[i], tofd[i]) < 0)
1266 Scm_Panic("dup2 failed: %s", strerror(errno));
1267 }
1268 for (i=0; i<maxfd; i++) {
1269 for (j=0; j<iollen; j++) {
1270 if (i == tofd[j]) break;
1271 }
1272 if (j == iollen) close(i);
1273 }
1274 execvp(program, (char *const*)argv);
1275 /* here, we failed */
1276 Scm_Panic("exec failed: %s: %s", program, strerror(errno));
1277 }
1278
1279 /* We come here only when fork is requested. */
1280 return Scm_MakeInteger(pid);
1281 #else /* __MINGW32__ */
1282 if (forkp) {
1283 Scm_Error("fork() not supported on MinGW port");
1284 } else {
1285 execvp(program, (const char *const*)argv);
1286 Scm_Panic("exec failed: %s: %s", program, strerror(errno));
1287 }
1288 return SCM_FALSE; /* dummy */
1289 #endif /* __MINGW32__ */
1290 }
1291
1292 /*===============================================================
1293 * select
1294 */
1295
1296 #ifdef HAVE_SELECT
1297 static ScmObj fdset_allocate(ScmClass *klass, ScmObj initargs)
1298 {
1299 ScmSysFdset *set = SCM_ALLOCATE(ScmSysFdset, klass);
1300 SCM_SET_CLASS(set, SCM_CLASS_SYS_FDSET);
1301 set->maxfd = -1;
1302 FD_ZERO(&set->fdset);
1303 return SCM_OBJ(set);
1304 }
1305
1306 static ScmSysFdset *fdset_copy(ScmSysFdset *fdset)
1307 {
1308 ScmSysFdset *set = SCM_NEW(ScmSysFdset);
1309 SCM_SET_CLASS(set, SCM_CLASS_SYS_FDSET);
1310 set->maxfd = fdset->maxfd;
1311 set->fdset = fdset->fdset;
1312 return set;
1313 }
1314
1315 SCM_DEFINE_BUILTIN_CLASS(Scm_SysFdsetClass, NULL, NULL, NULL,
1316 fdset_allocate, SCM_CLASS_DEFAULT_CPL);
1317
1318 static ScmSysFdset *select_checkfd(ScmObj fds)
1319 {
1320 if (SCM_FALSEP(fds)) return NULL;
1321 if (!SCM_SYS_FDSET_P(fds))
1322 Scm_Error("sys-fdset object or #f is required, but got %S", fds);
1323 return SCM_SYS_FDSET(fds);
1324 }
1325
1326 static struct timeval *select_timeval(ScmObj timeout, struct timeval *tm)
1327 {
1328 if (SCM_FALSEP(timeout)) return NULL;
1329 if (SCM_INTP(timeout)) {
1330 int val = SCM_INT_VALUE(timeout);
1331 if (val < 0) goto badtv;
1332 tm->tv_sec = val / 1000000;
1333 tm->tv_usec = val % 1000000;
1334 return tm;
1335 } else if (SCM_BIGNUMP(timeout)) {
1336 long usec;
1337 ScmObj sec;
1338 if (Scm_Sign(timeout) < 0) goto badtv;
1339 sec = Scm_BignumDivSI(SCM_BIGNUM(timeout), 1000000, &usec);
1340 tm->tv_sec = Scm_GetInteger(sec);
1341 tm->tv_usec = usec;
1342 return tm;
1343 } else if (SCM_FLONUMP(timeout)) {
1344 long val = Scm_GetInteger(timeout);
1345 if (val < 0) goto badtv;
1346 tm->tv_sec = val / 1000000;
1347 tm->tv_usec = val % 1000000;
1348 return tm;
1349 } else if (SCM_PAIRP(timeout) && SCM_PAIRP(SCM_CDR(timeout))) {
1350 ScmObj sec = SCM_CAR(timeout);
1351 ScmObj usec = SCM_CADR(timeout);
1352 long isec, iusec;
1353 if (!Scm_IntegerP(sec) || !Scm_IntegerP(usec)) goto badtv;
1354 isec = Scm_GetInteger(sec);
1355 iusec = Scm_GetInteger(usec);
1356 if (isec < 0 || iusec < 0) goto badtv;
1357 tm->tv_sec = isec;
1358 tm->tv_usec = iusec;
1359 return tm;
1360 }
1361 badtv:
1362 Scm_Error("timeval needs to be a real number (in microseconds) or a list of two integers (seconds and microseconds), but got %S", timeout);
1363 return NULL; /* dummy */
1364 }
1365
1366 static ScmObj select_int(ScmSysFdset *rfds, ScmSysFdset *wfds,
1367 ScmSysFdset *efds, ScmObj timeout)
1368 {
1369 int numfds, maxfds = 0;
1370 struct timeval tm;
1371 if (rfds) maxfds = rfds->maxfd;
1372 if (wfds && wfds->maxfd > maxfds) maxfds = wfds->maxfd;
1373 if (efds && efds->maxfd > maxfds) maxfds = efds->maxfd;
1374
1375 SCM_SYSCALL(numfds,
1376 select(maxfds+1,
1377 (rfds? &rfds->fdset : NULL),
1378 (wfds? &wfds->fdset : NULL),
1379 (efds? &efds->fdset : NULL),
1380 select_timeval(timeout, &tm)));
1381 if (numfds < 0) Scm_SysError("select failed");
1382 return Scm_Values4(Scm_MakeInteger(numfds),
1383 (rfds? SCM_OBJ(rfds) : SCM_FALSE),
1384 (wfds? SCM_OBJ(wfds) : SCM_FALSE),
1385 (efds? SCM_OBJ(efds) : SCM_FALSE));
1386 }
1387
1388 ScmObj Scm_SysSelect(ScmObj rfds, ScmObj wfds, ScmObj efds, ScmObj timeout)
1389 {
1390 ScmSysFdset *r = select_checkfd(rfds);
1391 ScmSysFdset *w = select_checkfd(wfds);
1392 ScmSysFdset *e = select_checkfd(efds);
1393 return select_int((r? fdset_copy(r) : NULL),
1394 (w? fdset_copy(w) : NULL),
1395 (e? fdset_copy(e) : NULL),
1396 timeout);
1397 }
1398
1399 ScmObj Scm_SysSelectX(ScmObj rfds, ScmObj wfds, ScmObj efds, ScmObj timeout)
1400 {
1401 ScmSysFdset *r = select_checkfd(rfds);
1402 ScmSysFdset *w = select_checkfd(wfds);
1403 ScmSysFdset *e = select_checkfd(efds);
1404 return select_int(r, w, e, timeout);
1405 }
1406
1407 #endif /* HAVE_SELECT */
1408
1409 /*===============================================================
1410 * Emulation layer for MinGW port
1411 */
1412 #ifdef __MINGW32__
1413
1414 /* wide character string -> Scheme-owned MB string.
1415 the result is utf8. we should convert it to Gauche's internal encoding,
1416 but that's the later story... */
1417 static char *w2mdup(LPCWSTR wstr)
1418 {
1419 char *dst = "";
1420 if (wstr) {
1421 /* first, count the required length */
1422 int count;
1423 int mbsize = WideCharToMultiByte(CP_UTF8, 0, wstr, -1,
1424 NULL, 0, NULL, NULL);
1425 SCM_ASSERT(mbsize > 0);
1426 dst = SCM_NEW_ATOMIC2(char*, mbsize+1);
1427 count = WideCharToMultiByte(CP_UTF8, 0, wstr, -1,
1428 dst, mbsize+1, NULL, NULL);
1429 dst[mbsize] = '\0';
1430 SCM_ASSERT(count == mbsize);
1431 }
1432 return dst;
1433 }
1434
1435 static wchar_t *m2wdup(const char *mbstr)
1436 {
1437 wchar_t *dst = NULL;
1438 if (mbstr) {
1439 /* first, count the required length */
1440 int count;
1441 int wcsize = MultiByteToWideChar(CP_UTF8, 0, mbstr, -1, NULL, 0);
1442 SCM_ASSERT(wcsize >= 0);
1443 dst = SCM_NEW_ATOMIC2(wchar_t *, wcsize+1);
1444 count = MultiByteToWideChar(CP_UTF8, 0, mbstr, -1, dst, wcsize);
1445 dst[wcsize] = 0;
1446 SCM_ASSERT(count == wcsize);
1447 }
1448 return dst;
1449 }
1450
1451 /*
1452 * Users and groups
1453 * Kinda Kluge, since we don't have "user id" associated with each
1454 * user. (If a domain server is active, Windows security manager seems
1455 * to assign an unique user id for every user; but it doesn't seem available
1456 * for stand-alone machine.)
1457 */
1458
1459 static void convert_user(const USER_INFO_2 *wuser, struct passwd *res)
1460 {
1461 res->pw_name = w2mdup(wuser->usri2_name);
1462 res->pw_passwd = "*";
1463 res->pw_uid = 0;
1464 res->pw_gid = 0;
1465 res->pw_comment = w2mdup(wuser->usri2_comment);
1466 res->pw_gecos = w2mdup(wuser->usri2_full_name);
1467 res->pw_dir = w2mdup(wuser->usri2_home_dir);
1468 res->pw_shell = "";
1469 }
1470
1471 /* Arrgh! thread unsafe! just for the time being...*/
1472 static struct passwd pwbuf = { "dummy" };
1473
1474 struct passwd *getpwnam(const char *name)
1475 {
1476 USER_INFO_2 *res;
1477 if (NetUserGetInfo(NULL, m2wdup(name), 2, (LPBYTE*)&res) != NERR_Success) {
1478 return NULL;
1479 }
1480 convert_user(res, &pwbuf);
1481 NetApiBufferFree(res);
1482 return &pwbuf;
1483 }
1484
1485 struct passwd *getpwuid(uid_t uid)
1486 {
1487 /* for the time being, we just ignore uid and returns the current
1488 user info. */
1489 #define NAMELENGTH 256
1490 char buf[NAMELENGTH];
1491 DWORD len = NAMELENGTH;
1492 if (GetUserName(buf, &len) == 0) {
1493 return NULL;
1494 }
1495 return getpwnam(buf);
1496 }
1497
1498 static struct group dummy_group = {
1499 "dummy",
1500 "",
1501 100,
1502 NULL
1503 };
1504
1505 struct group *getgrgid(gid_t gid)
1506 {
1507 return &dummy_group;
1508 }
1509
1510 struct group *getgrnam(const char *name)
1511 {
1512 return &dummy_group;
1513 }
1514
1515 /* Kluge kluge kluge */
1516 uid_t getuid(void)
1517 {
1518 return 0;
1519 }
1520
1521 uid_t geteuid(void)
1522 {
1523 return 0;
1524 }
1525
1526 gid_t getgid(void)
1527 {
1528 return 0;
1529 }
1530
1531 gid_t getegid(void)
1532 {
1533 return 0;
1534 }
1535
1536 /*
1537 * Getting parent process ID. I wonder why it is such a hassle, but
1538 * the use of Process32First is indeed suggested in the MS document.
1539 */
1540 pid_t getppid(void)
1541 {
1542 HANDLE snapshot;
1543 PROCESSENTRY32 entry;
1544 DWORD myid = GetCurrentProcessId(), parentid;
1545 int found = FALSE;
1546
1547 snapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
1548 if (snapshot == INVALID_HANDLE_VALUE) {
1549 Scm_Error("couldn't take process snapshot in getppid()");
1550 }
1551 entry.dwSize = sizeof(PROCESSENTRY32);
1552 if (!Process32First(snapshot, &entry)) {
1553 CloseHandle(snapshot);
1554 Scm_Error("Process32First failed in getppid()");
1555 }
1556 do {
1557 if (entry.th32ProcessID == myid) {
1558 parentid = entry.th32ParentProcessID;
1559 found = TRUE;
1560 break;
1561 }
1562 } while (Process32Next(snapshot, &entry));
1563 CloseHandle(snapshot);
1564 if (!found) {
1565 Scm_Error("couldn't find the current process entry in getppid()");
1566 }
1567 return parentid;
1568 }
1569
1570
1571 /*
1572 * Other obscure stuff
1573 */
1574
1575 int fork(void)
1576 {
1577 SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
1578 return -1;
1579 }
1580
1581 int kill(pid_t pid, int signal)
1582 {
1583 SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
1584 return -1; /*TODO: is there any alternative? */
1585 }
1586
1587 int pipe(int fd[])
1588 {
1589 #define PIPE_BUFFER_SIZE 512
1590 int r = _pipe(fd, PIPE_BUFFER_SIZE, O_BINARY);
1591 return r;
1592 }
1593
1594 char *ttyname(int desc)
1595 {
1596 return NULL;
1597 }
1598
1599 int truncate(const char *path, off_t len)
1600 {
1601 return -1;
1602 }
1603
1604 int ftruncate(int fd, off_t len)
1605 {
1606 return -1;
1607 }
1608
1609 unsigned int alarm(unsigned int seconds)
1610 {
1611 SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
1612 Scm_SysError("alarm");
1613 return 0;
1614 }
1615
1616 /* file links */
1617 int link(const char *existing, const char *newpath)
1618 {
1619 SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
1620 Scm_Error("link");
1621 return -1;
1622 #if 0 /* only on NTFS */
1623 BOOL r = CreateHardLink((LPCTSTR)newpath, (LPCTSTR)existing, NULL);
1624 return r? -1 : 0;
1625 #endif
1626 }
1627
1628 #endif /*__MINGW32__*/
1629
1630
1631 /*===============================================================
1632 * Initialization
1633 */
1634 void Scm__InitSystem(void)
1635 {
1636 ScmModule *mod = Scm_GaucheModule();
1637 Scm_InitStaticClass(&Scm_SysStatClass, "<sys-stat>", mod, stat_slots, 0);
1638 Scm_InitStaticClass(&Scm_TimeClass, "<time>", mod, time_slots, 0);
1639 Scm_InitStaticClass(&Scm_SysTmClass, "<sys-tm>", mod, tm_slots, 0);
1640 Scm_InitStaticClass(&Scm_SysGroupClass, "<sys-group>", mod, grp_slots, 0);
1641 Scm_InitStaticClass(&Scm_SysPasswdClass, "<sys-passwd>", mod, pwd_slots, 0);
1642 #ifdef HAVE_SELECT
1643 Scm_InitStaticClass(&Scm_SysFdsetClass, "<sys-fdset>", mod, NULL, 0);
1644 #endif
1645 }