root/src/system.c

/* [<][>][^][v][top][bottom][index][help] */

DEFINITIONS

This source file includes following definitions.
  1. Scm_IntegerToOffset
  2. Scm_OffsetToInteger
  3. Scm_SysCall
  4. Scm_PtrSysCall
  5. Scm_GetPortFd
  6. Scm_ReadDirectory
  7. Scm_GlobDirectory
  8. Scm_PathDelimiter
  9. get_first_separator
  10. get_last_separator
  11. skip_separators
  12. truncate_trailing_separators
  13. put_user_home
  14. expand_tilde
  15. put_current_dir
  16. copy_win32_path
  17. Scm_NormalizePathname
  18. Scm_BaseName
  19. Scm_DirName
  20. Scm_Mkstemp
  21. Scm_SysMkstemp
  22. stat_allocate
  23. Scm_MakeSysStat
  24. stat_type_get
  25. stat_perm_get
  26. time_allocate
  27. time_print
  28. time_compare
  29. Scm_MakeTime
  30. Scm_CurrentTime
  31. Scm_IntSecondsToTime
  32. Scm_RealSecondsToTime
  33. time_type_get
  34. time_type_set
  35. time_sec_get
  36. time_sec_set
  37. time_nsec_get
  38. time_nsec_set
  39. Scm_MakeSysTime
  40. Scm_GetSysTime
  41. Scm_TimeToSeconds
  42. Scm_GetTimeSpec
  43. tm_allocate
  44. tm_print
  45. Scm_MakeSysTm
  46. grp_print
  47. make_group
  48. Scm_GetGroupById
  49. Scm_GetGroupByName
  50. pwd_print
  51. make_passwd
  52. Scm_GetPasswdById
  53. Scm_GetPasswdByName
  54. Scm_IsSugid
  55. Scm_SysExec
  56. fdset_allocate
  57. fdset_copy
  58. select_checkfd
  59. select_timeval
  60. select_int
  61. Scm_SysSelect
  62. Scm_SysSelectX
  63. w2mdup
  64. m2wdup
  65. convert_user
  66. getpwnam
  67. getpwuid
  68. getgrgid
  69. getgrnam
  70. getuid
  71. geteuid
  72. getgid
  73. getegid
  74. getppid
  75. fork
  76. kill
  77. pipe
  78. ttyname
  79. truncate
  80. ftruncate
  81. alarm
  82. link
  83. 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 }

/* [<][>][^][v][top][bottom][index][help] */