src/runtime/wrap.c

   1 /*
   2  * wrappers around low-level operations to provide a simpler interface
   3  * to the operations that Lisp (and some contributed modules) needs.
   4  *
   5  * The functions in this file are typically called directly from Lisp.
   6  * Thus, when their signature changes, they don't need updates in a .h
   7  * file somewhere, but they do need updates in the Lisp code. FIXME:
   8  * It would be nice to enforce this at compile time. It mighn't even
   9  * be all that hard: make the cross-compiler versions of DEFINE-ALIEN-FOO
  10  * macros accumulate strings in a list which then gets written out at
  11  * the end of sbcl2.h at the end of cross-compilation, then rerun
  12  * 'make' in src/runtime/ using the new sbcl2.h as sbcl.h (and make
  13  * sure that all the files in src/runtime/ include sbcl.h). */
  14
  15 /*
  16  * This software is part of the SBCL system. See the README file for
  17  * more information.
  18  *
  19  * This software is derived from the CMU CL system, which was
  20  * written at Carnegie Mellon University and released into the
  21  * public domain. The software is in the public domain and is
  22  * provided with absolutely no warranty. See the COPYING and CREDITS
  23  * files for more information.
  24  */
  25
  26 #include "sbcl.h"
  27
  28 #include <sys/types.h>
  29 #include <dirent.h>
  30 #include <sys/stat.h>
  31 #include <stdlib.h>
  32 #include <string.h>
  33 #include <ctype.h>
  34 #include <unistd.h>
  35 #include <errno.h>
  36 #include <limits.h>
  37 #include <fcntl.h>
  38
  39 #ifndef LISP_FEATURE_WIN32
  40 #include <pwd.h>
  41 #include <sys/time.h>
  42 #include <sys/wait.h>
  43 #include <sys/resource.h>
  44 #include <netdb.h>
  45 #endif
  46 #include <stdio.h>
  47
  48 #if defined(LISP_FEATURE_WIN32)
  49 #define WIN32_LEAN_AND_MEAN
  50 #include <errno.h>
  51 #include <math.h>
  52 #endif
  53
  54 #include "runtime.h"
  55 #include "wrap.h"
  56
  57 /* Although it might seem as though this should be in some standard
  58    Unix header, according to Perry E. Metzger, in a message on
  59    sbcl-devel dated 2004-03-29, this is the POSIXly-correct way of
  60    using environ: by an explicit declaration.  -- CSR, 2004-03-30 */
  61 extern char **environ;
  62 \f
  63 /*
  64  * stuff needed by CL:DIRECTORY and other Lisp directory operations
  65  */
  66
  67 \f
  68 /*
  69  * readlink(2) stuff
  70  */
  71
  72 #ifndef LISP_FEATURE_WIN32
  73 /* a wrapped version of readlink(2):
  74  *   -- If path isn't a symlink, or is a broken symlink, return 0.
  75  *   -- If path is a symlink, return a newly allocated string holding
  76  *      the thing it's linked to. */
  77 char *
  78 wrapped_readlink(char *path)
  79 {
  80     int bufsiz = strlen(path) + 16;
  81     while (1) {
  82         char *result = malloc(bufsiz);
  83         int n_read = readlink(path, result, bufsiz);
  84         if (n_read < 0) {
  85             free(result);
  86             return 0;
  87         } else if (n_read < bufsiz) {
  88             result[n_read] = 0;
  89             return result;
  90         } else {
  91             free(result);
  92             bufsiz *= 2;
  93         }
  94     }
  95 }
  96 #endif
  97 \f
  98 /*
  99  * realpath(3), including a wrapper for Windows.
 100  */
 101 char * sb_realpath (char *path)
 102 {
 103 #ifndef LISP_FEATURE_WIN32
 104     char *ret;
 105     int errnum;
 106
 107     if ((ret = calloc(PATH_MAX, sizeof(char))) == NULL)
 108         return NULL;
 109     if (realpath(path, ret) == NULL) {
 110         errnum = errno;
 111         free(ret);
 112         errno = errnum;
 113         return NULL;
 114     }
 115     return(ret);
 116 #else
 117     char *ret;
 118     char *cp;
 119     int errnum;
 120
 121     if ((ret = calloc(MAX_PATH, sizeof(char))) == NULL)
 122         return NULL;
 123     if (GetFullPathName(path, MAX_PATH, ret, &cp) == 0) {
 124         errnum = errno;
 125         free(ret);
 126         errno = errnum;
 127         return NULL;
 128     }
 129     return(ret);
 130 #endif
 131 }
 132 \f
 133 /* readdir, closedir, and dirent name accessor. The first three are not strictly
 134  * necessary, but should save us some #!+netbsd in the build, and this also allows
 135  * building Windows versions using the non-ANSI variants of FindFirstFile &co
 136  * under the same API. (Use a structure that appends the handle to the WIN32_FIND_DATA
 137  * as the return value from sb_opendir, on sb_readdir grab the name from the previous
 138  * call and save the new one.) Nikodemus thought he would have to do that to support
 139  * DIRECTORY on UNC paths, but turns out opendir &co do TRT on Windows already -- so
 140  * leaving that bit of tedium for a later date, once we figure out the whole *A vs. *W
 141  * issue out properly. ...FIXME, obviously, as per above.
 142  *
 143  * Once that is done, the lisp side functions are best named OS-OPENDIR, etc.
 144  */
 145 extern DIR *
 146 sb_opendir(char * name)
 147 {
 148     return opendir(name);
 149 }
 150
 151 extern struct dirent *
 152 sb_readdir(DIR * dirp)
 153 {
 154     /* NULL returned from readdir() means it reached the end, NULL and
 155        non-zero errno means an error occured.
 156        When no error has occured, errno is not changed.
 157        Set it to 0 beforehand. */
 158     errno = 0;
 159     return readdir(dirp);
 160 }
 161
 162 extern int
 163 sb_closedir(DIR * dirp)
 164 {
 165     return closedir(dirp);
 166 }
 167
 168 extern char *
 169 sb_dirent_name(struct dirent * ent)
 170 {
 171     return ent->d_name;
 172 }
 173 \f
 174 /*
 175  * stat(2) stuff
 176  */
 177
 178 static void
 179 copy_to_stat_wrapper(struct stat_wrapper *to, struct stat *from)
 180 {
 181 #define FROB(stem) to->wrapped_st_##stem = from->st_##stem
 182 #ifndef LISP_FEATURE_WIN32
 183 #define FROB2(stem) to->wrapped_st_##stem = from->st_##stem
 184 #else
 185 #define FROB2(stem) to->wrapped_st_##stem = 0;
 186 #endif
 187     FROB(dev);
 188     FROB2(ino);
 189     FROB(mode);
 190     FROB(nlink);
 191     FROB2(uid);
 192     FROB2(gid);
 193     FROB(rdev);
 194     FROB(size);
 195     FROB2(blksize);
 196     FROB2(blocks);
 197     FROB(atime);
 198     FROB(mtime);
 199     FROB(ctime);
 200 #undef FROB
 201 }
 202
 203 int
 204 stat_wrapper(const char *file_name, struct stat_wrapper *buf)
 205 {
 206     struct stat real_buf;
 207     int ret;
 208
 209 #ifdef LISP_FEATURE_WIN32
 210     /*
 211      * Windows won't match the last component of a pathname if there
 212      * is a trailing #\/ or #\\, except if it's <drive>:\ or <drive>:/
 213      * in which case it behaves the other way around. So we remove the
 214      * trailing directory separator unless we are being passed just a
 215      * drive name (e.g. "c:\\").  Some, but not all, of this
 216      * strangeness is documented at Microsoft's support site (as of
 217      * 2006-01-08, at
 218      * <http://support.microsoft.com/default.aspx?scid=kb;en-us;168439>)
 219      */
 220     char file_buf[MAX_PATH];
 221     strcpy(file_buf, file_name);
 222     int len = strlen(file_name);
 223     if (len != 0 && (file_name[len-1] == '/' || file_name[len-1] == '\\') &&
 224         !(len == 3 && file_name[1] == ':' && isalpha(file_name[0])))
 225         file_buf[len-1] = '\0';
 226     file_name = file_buf;
 227 #endif
 228
 229     if ((ret = stat(file_name,&real_buf)) >= 0)
 230         copy_to_stat_wrapper(buf, &real_buf);
 231     return ret;
 232 }
 233
 234 #ifndef LISP_FEATURE_WIN32
 235 int
 236 lstat_wrapper(const char *file_name, struct stat_wrapper *buf)
 237 {
 238     struct stat real_buf;
 239     int ret;
 240     if ((ret = lstat(file_name,&real_buf)) >= 0)
 241         copy_to_stat_wrapper(buf, &real_buf);
 242     return ret;
 243 }
 244 #else
 245 /* cleaner to do it here than in Lisp */
 246 int lstat_wrapper(const char *file_name, struct stat_wrapper *buf)
 247 {
 248     return stat_wrapper(file_name, buf);
 249 }
 250 #endif
 251
 252 int
 253 fstat_wrapper(int filedes, struct stat_wrapper *buf)
 254 {
 255     struct stat real_buf;
 256     int ret;
 257     if ((ret = fstat(filedes,&real_buf)) >= 0)
 258         copy_to_stat_wrapper(buf, &real_buf);
 259     return ret;
 260 }
 261 \f
 262 /* A wrapper for mkstemp(3), for two reasons: (1) mkstemp does not
 263    exist on Windows; (2) by passing down a mode_t, we don't need a
 264    binding to chmod in SB-UNIX, and need not concern ourselves with
 265    umask issues if we want to use mkstemp to make new files in
 266    OPEN as implied by the cagey remark (in 'unix.lisp') that
 267      "There are good reasons to implement some OPEN options with a[n]
 268       mkstemp(3)-like routine, but we don't do that yet." */
 269
 270 int sb_mkstemp (char *template, mode_t mode) {
 271   int fd;
 272 #ifdef LISP_FEATURE_WIN32
 273 #define PATHNAME_BUFFER_SIZE MAX_PATH
 274   char buf[PATHNAME_BUFFER_SIZE];
 275
 276   while (1) {
 277     /* Fruit fallen from the tree: for people who like
 278        microoptimizations, we might not need to copy the whole
 279        template on every loop, but only the last several characters.
 280        But I didn't feel like testing the boundary cases in Windows's
 281        _mktemp. */
 282     strncpy(buf, template, PATHNAME_BUFFER_SIZE);
 283     buf[PATHNAME_BUFFER_SIZE-1]=0; /* force NULL-termination */
 284     if (_mktemp(buf)) {
 285       if ((fd=open(buf, O_CREAT|O_EXCL|O_RDWR, mode))!=-1) {
 286         strcpy(template, buf);
 287         return (fd);
 288       } else
 289         if (errno != EEXIST)
 290           return (-1);
 291     } else
 292       return (-1);
 293   }
 294 #undef PATHNAME_BUFFER_SIZE
 295 #else
 296   /* It makes no sense to reimplement mkstemp() with logic susceptible
 297      to the exploit that mkstemp() was designed to avoid.
 298      Unfortunately, there is a subtle bug in this more nearly correct technique.
 299      open() uses the given creation mode ANDed with the process umask,
 300      but fchmod() uses exactly the specified mode.  Attempting to perform the
 301      masking operation manually would result in another race: you can't obtain
 302      the current mask except by calling umask(), which both sets and gets it.
 303      But since RUN-PROGRAM is the only use of this, and the mode given is #o600
 304      which is the default for mkstemp(), RUN-PROGRAM should be indifferent.
 305      [The GNU C library documents but doesn't implement getumask() by the way.]
 306      So we're patching a security hole with a known innocuous design flaw
 307      by necessity to avoid the gcc linker warning that
 308        "the use of `mktemp' is dangerous, better use `mkstemp'" */
 309   fd = mkstemp(template);
 310   if (fd != -1 && fchmod(fd, mode) == -1) {
 311     close(fd); // got a file descriptor but couldn't fchmod() it
 312     return -1;
 313   }
 314   return fd;
 315 #endif
 316 }
 317
 318 \f
 319 /*
 320  * getpwuid() stuff
 321  */
 322
 323 #ifndef LISP_FEATURE_WIN32
 324 /* Return a newly-allocated string holding the username for "uid", or
 325  * NULL if there's no such user.
 326  *
 327  * KLUDGE: We also return NULL if malloc() runs out of memory
 328  * (returning strdup() result) since it's not clear how to handle that
 329  * error better. -- WHN 2001-12-28 */
 330 char *
 331 uid_username(int uid)
 332 {
 333     struct passwd *p = getpwuid(uid);
 334     if (p) {
 335         /* The object *p is a static struct which'll be overwritten by
 336          * the next call to getpwuid(), so it'd be unsafe to return
 337          * p->pw_name without copying. */
 338         return strdup(p->pw_name);
 339     } else {
 340         return 0;
 341     }
 342 }
 343
 344 char *
 345 passwd_homedir(struct passwd *p)
 346 {
 347     if (p) {
 348         /* Let's be careful about this, shall we? */
 349         size_t len = strlen(p->pw_dir);
 350         if (p->pw_dir[len-1] == '/') {
 351             return strdup(p->pw_dir);
 352         } else {
 353             char *result = malloc(len + 2);
 354             if (result) {
 355                 unsigned int nchars = sprintf(result,"%s/",p->pw_dir);
 356                 if (nchars == len + 1) {
 357                     return result;
 358                 } else {
 359                     return 0;
 360                 }
 361             } else {
 362                 return 0;
 363             }
 364         }
 365     } else {
 366         return 0;
 367     }
 368 }
 369
 370 char *
 371 user_homedir(char *name)
 372 {
 373     return passwd_homedir(getpwnam(name));
 374 }
 375
 376 char *
 377 uid_homedir(uid_t uid)
 378 {
 379     return passwd_homedir(getpwuid(uid));
 380 }
 381 #endif /* !LISP_FEATURE_WIN32 */
 382 \f
 383 /*
 384  * functions to get miscellaneous C-level variables
 385  *
 386  * (Doing this by calling functions lets us borrow the smarts of the C
 387  * linker, so that things don't blow up when libc versions and thus
 388  * variable locations change between compile time and run time.)
 389  */
 390
 391 char **
 392 wrapped_environ()
 393 {
 394     return environ;
 395 }
 396
 397 #ifdef LISP_FEATURE_WIN32
 398 #include <windows.h>
 399 #include <time.h>
 400 /*
 401  * faked-up implementation of select(). Right now just enough to get through
 402  * second genesis.
 403  */
 404 int sb_select(int top_fd, DWORD *read_set, DWORD *write_set, DWORD *except_set, time_t *timeout)
 405 {
 406     /*
 407      * FIXME: Going forward, we may want to use MsgWaitForMultipleObjects
 408      * in order to support a windows message loop inside serve-event.
 409      */
 410     HANDLE handles[MAXIMUM_WAIT_OBJECTS];
 411     int fds[MAXIMUM_WAIT_OBJECTS];
 412     int num_handles;
 413     int i;
 414     DWORD retval;
 415     int polling_write;
 416     DWORD win_timeout;
 417
 418     num_handles = 0;
 419     polling_write = 0;
 420     for (i = 0; i < top_fd; i++) {
 421         if (except_set) except_set[i >> 5] = 0;
 422         if (write_set && (write_set[i >> 5] & (1 << (i & 31)))) polling_write = 1;
 423         if (read_set[i >> 5] & (1 << (i & 31))) {
 424             read_set[i >> 5] &= ~(1 << (i & 31));
 425             fds[num_handles] = i;
 426             handles[num_handles++] = (HANDLE) _get_osfhandle(i);
 427         }
 428     }
 429
 430     win_timeout = INFINITE;
 431     if (timeout) win_timeout = (timeout[0] * 1000) + timeout[1];
 432
 433     /* Last parameter here is timeout in milliseconds. */
 434     /* retval = WaitForMultipleObjects(num_handles, handles, 0, INFINITE); */
 435     retval = WaitForMultipleObjects(num_handles, handles, 0, win_timeout);
 436
 437     if (retval < WAIT_ABANDONED) {
 438         /* retval, at this point, is the index of the single live HANDLE/fd. */
 439         read_set[fds[retval] >> 5] |= (1 << (fds[retval] & 31));
 440         return 1;
 441     }
 442     return polling_write;
 443 }
 444
 445 /*
 446  * Windows doesn't have gettimeofday(), and we need it for the compiler,
 447  * for serve-event, and for a couple other things. We don't need a timezone
 448  * yet, however, and the closest we can easily get to a timeval is the
 449  * seconds part. So that's what we do.
 450  */
 451 #define UNIX_EPOCH_FILETIME 116444736000000000ULL
 452
 453 int sb_gettimeofday(long *timeval, long *timezone)
 454 {
 455     FILETIME ft;
 456     ULARGE_INTEGER uft;
 457     GetSystemTimeAsFileTime(&ft);
 458     uft.LowPart = ft.dwLowDateTime;
 459     uft.HighPart = ft.dwHighDateTime;
 460     uft.QuadPart -= UNIX_EPOCH_FILETIME;
 461     timeval[0] = uft.QuadPart / 10000000;
 462     timeval[1] = (uft.QuadPart % 10000000)/10;
 463
 464     return 0;
 465 }
 466 #endif
 467
 468
 469 /* We will need to define these things or their equivalents for Win32
 470    eventually, but for now let's get it working for everyone else. */
 471 #ifndef LISP_FEATURE_WIN32
 472 /* From SB-BSD-SOCKETS, to get h_errno */
 473 int get_h_errno()
 474 {
 475     return h_errno;
 476 }
 477
 478 /* From SB-POSIX, wait-macros */
 479 int wifexited(int status) {
 480     return WIFEXITED(status);
 481 }
 482 int wexitstatus(int status) {
 483     return WEXITSTATUS(status);
 484 }
 485 int wifsignaled(int status) {
 486     return WIFSIGNALED(status);
 487 }
 488 int wtermsig(int status) {
 489     return WTERMSIG(status);
 490 }
 491 int wifstopped(int status) {
 492     return WIFSTOPPED(status);
 493 }
 494 int wstopsig(int status) {
 495     return WSTOPSIG(status);
 496 }
 497 /* FIXME: POSIX also defines WIFCONTINUED, but that appears not to
 498    exist on at least Linux... */
 499 #endif  /* !LISP_FEATURE_WIN32 */
 500
 501 /* From SB-POSIX, stat-macros */
 502 int s_isreg(mode_t mode)
 503 {
 504     return S_ISREG(mode);
 505 }
 506 int s_isdir(mode_t mode)
 507 {
 508     return S_ISDIR(mode);
 509 }
 510 int s_ischr(mode_t mode)
 511 {
 512     return S_ISCHR(mode);
 513 }
 514 int s_isblk(mode_t mode)
 515 {
 516     return S_ISBLK(mode);
 517 }
 518 int s_isfifo(mode_t mode)
 519 {
 520     return S_ISFIFO(mode);
 521 }
 522 #ifndef LISP_FEATURE_WIN32
 523 int s_islnk(mode_t mode)
 524 {
 525 #ifdef S_ISLNK
 526     return S_ISLNK(mode);
 527 #else
 528     return ((mode & S_IFMT) == S_IFLNK);
 529 #endif
 530 }
 531 int s_issock(mode_t mode)
 532 {
 533 #ifdef S_ISSOCK
 534     return S_ISSOCK(mode);
 535 #else
 536     return ((mode & S_IFMT) == S_IFSOCK);
 537 #endif
 538 }
 539 #endif /* !LISP_FEATURE_WIN32 */
 540
 541 #ifndef LISP_FEATURE_WIN32
 542 int sb_getrusage(int who, struct rusage *rusage)
 543 {
 544         return getrusage(who, rusage);
 545 }
 546
 547 int sb_gettimeofday(struct timeval *tp, void *tzp)
 548 {
 549         return gettimeofday(tp, tzp);
 550 }
 551
 552 #ifndef LISP_FEATURE_DARWIN /* reimplements nanosleep in darwin-os.c  */
 553 int sb_nanosleep(struct timespec *rqtp, struct timespec *rmtp)
 554 {
 555         return nanosleep(rqtp, rmtp);
 556 }
 557 #endif
 558
 559 int sb_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds,
 560     struct timeval *timeout)
 561 {
 562         return select(nfds, readfds, writefds, exceptfds, timeout);
 563 }
 564
 565 int sb_getitimer(int which, struct itimerval *value)
 566 {
 567         return getitimer(which, value);
 568 }
 569
 570 int sb_setitimer(int which, struct itimerval *value, struct itimerval *ovalue)
 571 {
 572         return setitimer(which, value, ovalue);
 573 }
 574
 575 int sb_utimes(char *path, struct timeval times[2])
 576 {
 577     return utimes(path, times);
 578 }
 579 #else /* !LISP_FEATURE_WIN32 */
 580 #define SB_TRIG_WRAPPER(name) \
 581     double sb_##name (double x) {               \
 582         return name(x);                         \
 583     }
 584 SB_TRIG_WRAPPER(acos)
 585 SB_TRIG_WRAPPER(asin)
 586 SB_TRIG_WRAPPER(cosh)
 587 SB_TRIG_WRAPPER(sinh)
 588 SB_TRIG_WRAPPER(tanh)
 589 SB_TRIG_WRAPPER(asinh)
 590 SB_TRIG_WRAPPER(acosh)
 591 SB_TRIG_WRAPPER(atanh)
 592
 593 double sb_hypot (double x, double y) {
 594     return hypot(x, y);
 595 }
 596
 597 #endif