cmucl-cvs May 2015

cmucl-cvs@common-lisp.net

1 participants
32 discussions

[cmucl/cmucl][rtoy-unix-core] Split the UNIX exports into linux and non-linux parts.
by Raymond Toy 09 May '15

09 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: d76358f8 by Raymond Toy at 2015-05-08T18:35:30Z Split the UNIX exports into linux and non-linux parts. For the non-linux part, add all of the other symbols that are currently exported from the UNIX package. - - - - - 1 changed file: - src/code/exports.lisp Changes: ===================================== src/code/exports.lisp ===================================== --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -196,6 +196,469 @@ "NEGATE-BIGNUM" "SUBTRACT-BIGNUM")) (defpackage "UNIX" + #-linux + (:export "UNIX-CURRENT-DIRECTORY" + "UNIX-OPEN" + "UNIX-READ" + "UNIX-WRITE" + "UNIX-GETPAGESIZE" + "UNIX-ERRNO" + "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" + "UNIX-RESOLVE-LINKS" + "UNIX-SIMPLIFY-PATHNAME" + "UNIX-CLOSE" + "UNIX-STAT" + "UNIX-LSTAT" + "UNIX-FSTAT" + "UNIX-GETHOSTNAME" + "UNIX-LSEEK" + "UNIX-EXIT" + "UNIX-CHDIR" + "UNIX-ACCESS" + "UNIX-DUP" + "UNIX-CHMOD" + "UNIX-READLINK" + "UNIX-RENAME" + "UNIX-SELECT" + "UNIX-FAST-GETRUSAGE" + "UNIX-GETRUSAGE" + "UNIX-GETTIMEOFDAY" + "UNIX-ISATTY" + "UNIX-MKDIR" + "UNIX-RMDIR" + "UNIX-UNLINK" + "TIMEZONE" + "TIMEVAL" + "SIZE-T" + "OFF-T" + "INO-T" + "DEV-T" + "TIME-T" + "TIME-T" + "USER-INFO-NAME" + "INT64-T" + "MODE-T" + "UNIX-FAST-SELECT" + "UNIX-PIPE" + "UNIX-GETPID" + "UNIX-GETHOSTID" + "UNIX-UID" + "UNIX-GID" + "GET-UNIX-ERROR-MSG" + "TCHARS" + "WINSIZE" + "LTCHARS" + "TIMEVAL" + "CLOSE-DIR" + "OPEN-DIR" + "READ-DIR" + "D-NAMLEN" + + ;; filesys.lisp + "UNIX-GETPWUID" + + ;; multi-proc.lisp + "UNIX-SETITIMER" + + ;; run-program.lisp + "SGTTYB" + "UNIX-TTYNAME" + "UNIX-IOCTL" + "UNIX-OPENPTY" + + ;; alien-callback.lisp + "UNIX-MPROTECT" + + ;; internet.lisp + "UNIX-SOCKET" + "UNIX-CONNECT" + "UNIX-BIND" + "UNIX-LISTEN" + "UNIX-ACCEPT" + "UNIX-GETSOCKOPT" + "UNIX-SETSOCKOPT" + "UNIX-GETPEERNAME" + "UNIX-GETSOCKNAME" + "UNIX-RECV" + "UNIX-SEND" + "UNIX-RECVFROM" + "UNIX-SENDTO" + "UNIX-SHUTDOWN" + "UNIX-FCNTL" + + ;; serve-event.lisp + "FD-SETSIZE" + "FD-ISSET" + "FD-CLR" + + ;; Simple streams + "PROT_READ" + "UNIX-MMAP" + "UNIX-MUNMAP" + "UNIX-MSYNC" + + ;; Motif + "UNIX-GETUIO" + + ;; Hemlock + "TERMIOS" + "UNIX-TCGETATTR" + "UNIX-TCSETATTR" + "UNIX-CFGETOSPEED" + "UNIX-FCHMOD" + "UNIX-CREAT" + "UNIX-UTIMES" + + ;; Tests + "UNIX-SYMLINK" + + ;; Other symbols from structures, etc. + "C-CC" + "C-CFLAG" + "C-IFLAG" + "C-ISPEED" + "C-LFLAG" + "C-OFLAG" + "C-OSPEED" + "CHECK" + "D-NAME" + "D-RECLEN" + "DIRECT" + "E2BIG" + "EACCES" + "EADDRINUSE" + "EADDRNOTAVAIL" + "EAFNOSUPPORT" + "EAGAIN" + "EALREADY" + "EBADF" + "EBUSY" + "ECHILD" + "ECONNABORTED" + "ECONNREFUSED" + "ECONNRESET" + "EDEADLK" + "EDESTADDRREQ" + "EDOM" + "EDQUOT" + "EEXIST" + "EFAULT" + "EFBIG" + "EHOSTDOWN" + "EHOSTUNREACH" + "EINPROGRESS" + "EINTR" + "EINVAL" + "EIO" + "EISCONN" + "EISDIR" + "ELOCAL" + "ELOOP" + "EMFILE" + "EMLINK" + "EMSGSIZE" + "ENAMETOOLONG" + "ENETDOWN" + "ENETRESET" + "ENETUNREACH" + "ENFILE" + "ENOBUFS" + "ENODEV" + "ENOENT" + "ENOEXEC" + "ENOMEM" + "ENOPROTOOPT" + "ENOSPC" + "ENOTBLK" + "ENOTCONN" + "ENOTDIR" + "ENOTEMPTY" + "ENOTSOCK" + "ENOTTY" + "ENXIO" + "EOPNOTSUPP" + "EPERM" + "EPFNOSUPPORT" + "EPIPE" + "EPROCLIM" + "EPROTONOSUPPORT" + "EPROTOTYPE" + "ERANGE" + "EREMOTE" + "EROFS" + "ESHUTDOWN" + "ESOCKTNOSUPPORT" + "ESPIPE" + "ESRCH" + "ESUCCESS" + "ETIMEDOUT" + "ETOOMANYREFS" + "ETXTBSY" + "EUSERS" + "EVICEERR" + "EVICEOP" + "EWOULDBLOCK" + "EXDEV" + "EXECGRP" + "EXECOTH" + "EXECOWN" + "F-DUPFD" + "F-GETFD" + "F-GETFL" + "F-GETOWN" + "F-SETFD" + "F-SETFL" + "F-SETOWN" + "FAPPEND" + "FASYNC" + "FCREAT" + "FD-SET" + "FD-ZERO" + "FEXCL" + "FIONREAD" + "FNDELAY" + "FTRUNC" + "F_OK" + "GID-T" + "IT-INTERVAL" + "IT-VALUE" + "ITIMERVAL" + "L_INCR" + "L_SET" + "L_XTND" + "MAP_ANONYMOUS" + "MAP_FIXED" + "MAP_PRIVATE" + "MAP_SHARED" + "MS_ASYNC" + "MS_INVALIDATE" + "MS_SYNC" + "O_APPEND" + "O_CREAT" + "O_EXCL" + "O_NDELAY" + "O_NONBLOCK" + "O_RDONLY" + "O_RDWR" + "O_TRUNC" + "O_WRONLY" + "PROT_EXEC" + "PROT_NONE" + "PROT_WRITE" + "READGRP" + "READOTH" + "READOWN" + "RU-IDRSS" + "RU-INBLOCK" + "RU-ISRSS" + "RU-IXRSS" + "RU-MAJFLT" + "RU-MAXRSS" + "RU-MINFLT" + "RU-MSGRCV" + "RU-MSGSND" + "RU-NIVCSW" + "RU-NSIGNALS" + "RU-NSWAP" + "RU-NVCSW" + "RU-OUBLOCK" + "RU-STIME" + "RU-UTIME" + "RUSAGE_CHILDREN" + "RUSAGE_SELF" + "R_OK" + "S-IEXEC" + "S-IFBLK" + "S-IFCHR" + "S-IFDIR" + "S-IFLNK" + "S-IFMT" + "S-IFREG" + "S-IFSOCK" + "S-IREAD" + "S-ISGID" + "S-ISUID" + "S-ISVTX" + "S-IWRITE" + "SAVETEXT" + "SETGIDEXEC" + "SETUIDEXEC" + "SG-ERASE" + "SG-FLAGS" + "SG-ISPEED" + "SG-KILL" + "SG-OSPEED" + "SIGABRT" + "SIGALRM" + "SIGBUS" + "SIGCHLD" + "SIGCONT" + "SIGCONTEXT" + "SIGEMT" + "SIGFPE" + "SIGHUP" + "SIGILL" + "SIGINT" + "SIGIO" + "SIGIOT" + "SIGKILL" + "SIGMASK" + "SIGPIPE" + "SIGPROF" + "SIGQUIT" + "SIGSEGV" + "SIGSTOP" + "SIGSYS" + "SIGTERM" + "SIGTRAP" + "SIGTSTP" + "SIGTTIN" + "SIGTTOU" + "SIGURG" + "SIGUSR1" + "SIGUSR2" + "SIGVTALRM" + "SIGWINCH" + "SIGXCPU" + "SIGXFSZ" + "ST-ATIME" + "ST-BLKSIZE" + "ST-BLOCKS" + "ST-CTIME" + "ST-DEV" + "ST-GID" + "ST-MODE" + "ST-MTIME" + "ST-NLINK" + "ST-RDEV" + "ST-SIZE" + "ST-UID" + "STAT" + "T-BRKC" + "T-DSUSPC" + "T-EOFC" + "T-FLUSHC" + "T-INTRC" + "T-LNEXTC" + "T-QUITC" + "T-RPRNTC" + "T-STARTC" + "T-STOPC" + "T-SUSPC" + "T-WERASC" + "TCIFLUSH" + "TCIOFLUSH" + "TCOFLUSH" + "TCSADRAIN" + "TCSAFLUSH" + "TCSANOW" + "TERMINAL-SPEEDS" + "TIOCFLUSH" + "TIOCGETC" + "TIOCGETP" + "TIOCGLTC" + "TIOCGPGRP" + "TIOCGWINSZ" + "TIOCNOTTY" + "TIOCSETC" + "TIOCSETP" + "TIOCSLTC" + "TIOCSPGRP" + "TIOCSWINSZ" + "TTY-BRKINT" + "TTY-CBREAK" + "TTY-CLOCAL" + "TTY-CREAD" + "TTY-CRMOD" + "TTY-CS5" + "TTY-CS6" + "TTY-CS7" + "TTY-CS8" + "TTY-CSIZE" + "TTY-CSTOPB" + "TTY-ECHO" + "TTY-ECHOCTL" + "TTY-ECHOE" + "TTY-ECHOK" + "TTY-ECHOKE" + "TTY-ECHONL" + "TTY-ECHOPRT" + "TTY-FLUSHO" + "TTY-HUPCL" + "TTY-ICANON" + "TTY-ICRNL" + "TTY-IEXTEN" + "TTY-IGNBRK" + "TTY-IGNCR" + "TTY-IGNPAR" + "TTY-IMAXBEL" + "TTY-INLCR" + "TTY-INPCK" + "TTY-ISIG" + "TTY-ISTRIP" + "TTY-IXANY" + "TTY-IXOFF" + "TTY-IXON" + "TTY-LCASE" + "TTY-NOFLSH" + "TTY-ONLCR" + "TTY-OPOST" + "TTY-PARENB" + "TTY-PARMRK" + "TTY-PARODD" + "TTY-PENDIN" + "TTY-RAW" + "TTY-TANDEM" + "TTY-TOSTOP" + "TV-SEC" + "TV-USEC" + "TZ-DSTTIME" + "TZ-MINUTESWEST" + "UID-T" + "UNIX-FD" + "UNIX-FILE-KIND" + "UNIX-FILE-MODE" + "UNIX-GETUID" + "UNIX-KILL" + "UNIX-KILLPG" + "UNIX-PATHNAME" + "UNIX-SIGBLOCK" + "UNIX-SIGNAL-DESCRIPTION" + "UNIX-SIGNAL-NAME" + "UNIX-SIGNAL-NUMBER" + "UNIX-SIGPAUSE" + "UNIX-SIGSETMASK" + "USER-INFO" + "USER-INFO-DIR" + "USER-INFO-GECOS" + "USER-INFO-GID" + "USER-INFO-PASSWORD" + "USER-INFO-SHELL" + "USER-INFO-UID" + "VDSUSP" + "VEOF" + "VEOL" + "VEOL2" + "VERASE" + "VINTR" + "VKILL" + "VMIN" + "VQUIT" + "VSTART" + "VSTOP" + "VSUSP" + "VTIME" + "WRITEGRP" + "WRITEOTH" + "WRITEOWN" + "WS-COL" + "WS-ROW" + "WS-XPIXEL" + "WS-YPIXEL" + "W_OK" + "X_OK" + ) + #-linux (:export "UNIX-CURRENT-DIRECTORY" "UNIX-OPEN" "UNIX-READ" @@ -311,6 +774,7 @@ ;; Tests "UNIX-SYMLINK" )) + (defpackage "FORMAT") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/d76358f84169481e9490f0f1d…

1 0

[cmucl/cmucl][rtoy-unix-core] Install the appropriate compiled unix file.
by Raymond Toy 08 May '15

08 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: 6b33a1f0 by Raymond Toy at 2015-05-07T22:43:06Z Install the appropriate compiled unix file. - - - - - 1 changed file: - bin/make-main-dist.sh Changes: ===================================== bin/make-main-dist.sh ===================================== --- a/bin/make-main-dist.sh +++ b/bin/make-main-dist.sh @@ -127,12 +127,21 @@ do done # Create the directories and install the fasl files for asdf and defsystem -for f in asdf defsystem unix +for f in asdf defsystem do install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib/$f install ${GROUP} ${OWNER} -m 0644 $TARGET/contrib/$f/$f.$FASL $DESTDIR/lib/cmucl/lib/contrib/$f done +set -x +case `uname -s` in + Linux*) UCONTRIB="unix-glibc2" ;; + *) UCONTRIB="unix" ;; +esac + +install -d ${GROUP} ${OWNER} -m 0755 $DESTDIR/lib/cmucl/lib/contrib/unix +install ${GROUP} ${OWNER} -m 0644 $TARGET/contrib/unix/$UCONTRIB.$FASL $DESTDIR/lib/cmucl/lib/contrib/unix + # Copy the source files for asdf and defsystem for f in `(cd src; find contrib/asdf contrib/defsystem -type f -print | grep -v CVS)` do View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/6b33a1f0851c69ee404d2a5dd…

1 0

[cmucl/cmucl][rtoy-unix-core] Don't pass in the command line args to lisp when building asdf and
by Raymond Toy 08 May '15

08 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: e549b338 by Raymond Toy at 2015-05-07T22:39:30Z Don't pass in the command line args to lisp when building asdf and friends. The command line args aren't relevant to lisp. - - - - - 1 changed file: - bin/build.sh Changes: ===================================== bin/build.sh ===================================== --- a/bin/build.sh +++ b/bin/build.sh @@ -251,7 +251,7 @@ buildit # Asdf and friends are part of the base install, so we need to build # them now. -$TARGET/lisp/lisp -noinit -nositeinit -batch "$@" << EOF || exit 3 +$TARGET/lisp/lisp -noinit -nositeinit -batch << EOF || exit 3 (in-package :cl-user) (setf (ext:search-list "target:") '("$TARGET/" "src/")) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/e549b338970eee4cef8403651…

1 0

[cmucl/cmucl][rtoy-unix-core] Compile the appropriate unix contrib file.
by Raymond Toy 07 May '15

07 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: 19997c21 by Raymond Toy at 2015-05-06T22:03:22Z Compile the appropriate unix contrib file. - - - - - 1 changed file: - bin/build.sh Changes: ===================================== bin/build.sh ===================================== --- a/bin/build.sh +++ b/bin/build.sh @@ -262,7 +262,8 @@ $TARGET/lisp/lisp -noinit -nositeinit -batch "$@" << EOF || exit 3 (compile-file "modules:defsystem/defsystem") (intl::install) (ext:without-package-locks - (compile-file "modules:unix/unix")) + (compile-file #-linux "modules:unix/unix" + #+linux "modules:unix/unix-glibc2")) EOF View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/19997c21a9184f9321899e4f4…

1 0

[cmucl/cmucl][rtoy-unix-core] For linux, Load unix-glibc2.lisp instead of unix.lisp.
by Raymond Toy 07 May '15

07 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: 3191f538 by Raymond Toy at 2015-05-06T21:07:00Z For linux, Load unix-glibc2.lisp instead of unix.lisp. - - - - - 1 changed file: - src/contrib/load-unix.lisp Changes: ===================================== src/contrib/load-unix.lisp ===================================== --- a/src/contrib/load-unix.lisp +++ b/src/contrib/load-unix.lisp @@ -1,6 +1,7 @@ ;; Load extra functionality in the UNIX package. (ext:without-package-locks - (load "modules:unix/unix")) + (load #-linux "modules:unix/unix" + #+linux "modules:unix/unix-glibc2")) (provide 'unix) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/3191f538dd21d8656e4d79fbf…

1 0

[cmucl/cmucl][rtoy-unix-core] Add support for hemlock.
by Raymond Toy 07 May '15

07 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: 3a837db1 by Raymond Toy at 2015-05-06T21:01:31Z Add support for hemlock. With these additions, hemlock builds now and runs. (I only tested that hemlock starts and that text can be entered.) - - - - - 1 changed file: - src/code/unix-glibc2.lisp Changes: ===================================== src/code/unix-glibc2.lisp ===================================== --- a/src/code/unix-glibc2.lisp +++ b/src/code/unix-glibc2.lisp @@ -1001,6 +1001,10 @@ (declare (type (signed-byte 32) code)) (void-syscall ("exit" int) code)) +(def-alien-routine ("getuid" unix-getuid) int + _N"Unix-getuid returns the real user-id associated with the + current process.") + ;;; Unix-chdir accepts a directory name and makes that the ;;; current working directory. @@ -1109,6 +1113,43 @@ (defconstant prot_exec 4) (defconstant prot_none 0) +(defconstant map_shared 1) +(defconstant map_private 2) +(defconstant map_fixed 16) +(defconstant map_anonymous 32) + +(defconstant ms_async 1) +(defconstant ms_sync 4) +(defconstant ms_invalidate 2) + +;; The return value from mmap that means mmap failed. +(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits)))) + +(defun unix-mmap (addr length prot flags fd offset) + (declare (type (or null system-area-pointer) addr) + (type (unsigned-byte 32) length) + (type (integer 1 7) prot) + (type (unsigned-byte 32) flags) + (type (or null unix-fd) fd) + (type (signed-byte 32) offset)) + ;; Can't use syscall, because the address that is returned could be + ;; "negative". Hence we explicitly check for mmap returning + ;; MAP_FAILED. + (let ((result + (alien-funcall (extern-alien "mmap" (function system-area-pointer + system-area-pointer + size-t int int int off-t)) + (or addr +null+) length prot flags (or fd -1) offset))) + (if (sap= result map_failed) + (values nil (unix-errno)) + (values result 0)))) + +(defun unix-msync (addr length flags) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length) + (type (signed-byte 32) flags)) + (syscall ("msync" system-area-pointer size-t int) t addr length flags)) + ;;; Unix-rename accepts two files names and renames the first to the second. (defun unix-rename (name1 name2) @@ -1196,6 +1237,15 @@ (define-ioctl-command TIOCSPGRP #\T #x10) (define-ioctl-command TIOCGPGRP #\T #x0F) +;;; ioctl-types.h + +(def-alien-type nil + (struct winsize + (ws-row unsigned-short) ; rows, in characters + (ws-col unsigned-short) ; columns, in characters + (ws-xpixel unsigned-short) ; horizontal size, pixels + (ws-ypixel unsigned-short))) ; veritical size, pixels + (defconstant f-getfl 3 _N"Get file flags") (defconstant f-setfl 4 _N"Set file flags") @@ -1736,3 +1786,68 @@ (slot (slot itvo 'it-value) 'tv-usec)) which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + +(def-alien-type cc-t unsigned-char) +(def-alien-type speed-t unsigned-int) +(def-alien-type tcflag-t unsigned-int) + +(defconstant +NCCS+ 32 + _N"Size of control character vector.") + +(def-alien-type nil + (struct termios + (c-iflag tcflag-t) + (c-oflag tcflag-t) + (c-cflag tcflag-t) + (c-lflag tcflag-t) + (c-line cc-t) + (c-cc (array cc-t #.+NCCS+)) + (c-ispeed speed-t) + (c-ospeed speed-t))) + +;; c_cc characters + +(defmacro def-enum (inc cur &rest names) + (flet ((defform (name) + (prog1 (when name `(defconstant ,name ,cur)) + (setf cur (funcall inc cur 1))))) + `(progn ,@(mapcar #'defform names)))) + +(def-enum + 0 vintr vquit verase + vkill veof vtime + vmin vswtc vstart + vstop vsusp veol + vreprint vdiscard vwerase + vlnext veol2) +(defvar vdsusp vsusp) + +(def-enum + 0 tcsanow tcsadrain tcsaflush) + +;; c_iflag bits +(def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck + tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc + tty-ixon tty-ixany tty-ixoff + tty-imaxbel) + +;; c_oflag bits +(def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr + tty-onlret tty-ofill tty-ofdel tty-nldly) + +;; c_lflag bits +(def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe + tty-echok tty-echonl tty-noflsh + tty-tostop tty-echoctl tty-echoprt + tty-echoke tty-flusho + tty-pendin tty-iexten) + +(defun unix-tcgetattr (fd termios) + _N"Get terminal attributes." + (declare (type unix-fd fd)) + (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) + +(defun unix-tcsetattr (fd opt termios) + _N"Set terminal attributes." + (declare (type unix-fd fd)) + (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios)) + +(defconstant writeown #o200 _N"Write by owner") View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/3a837db16fced7579d6cf12d4…

1 0

[cmucl/cmucl][rtoy-unix-core] 2 commits: Move unix-glibc2.lisp to contrib/unix.
by Raymond Toy 04 May '15

04 May '15

Raymond Toy pushed to branch rtoy-unix-core at cmucl / cmucl Commits: 743c80c8 by Raymond Toy at 2015-05-03T22:46:09Z Move unix-glibc2.lisp to contrib/unix. - - - - - d6b8e188 by Raymond Toy at 2015-05-03T22:48:18Z Small version of unix-glibc2.lisp that will compile lisp. This is enough to get do a full build of cmucl, but not motif. More work needed; I didn't yet check build logs for warnings or errors. - - - - - 2 changed files: - src/code/unix-glibc2.lisp - + src/contrib/unix/unix-glibc2.lisp Changes: ===================================== src/code/unix-glibc2.lisp ===================================== --- a/src/code/unix-glibc2.lisp +++ b/src/code/unix-glibc2.lisp @@ -207,7 +207,7 @@ (pushnew :glibc2 *features*) ;; needed for bootstrap -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel :execute) (defmacro %name->file (string) `(if *filename-encoding* (string-encode ,string *filename-encoding*) @@ -217,222 +217,16 @@ (string-decode ,string *filename-encoding*) ,string))) -;;;; Common machine independent structures. - -(eval-when (compile eval) - -(defparameter *compiler-unix-errors* nil) - -(defmacro def-unix-error (name number description) - `(progn - (eval-when (compile eval) - (push (cons ,number ,description) *compiler-unix-errors*)) - (defconstant ,name ,number ,description) - (export ',name))) - -(defmacro emit-unix-errors () - (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) - (array (make-array (1+ max) :initial-element nil))) - (dolist (error *compiler-unix-errors*) - (setf (svref array (car error)) (cdr error))) - `(progn - (defvar *unix-errors* ',array) - (declaim (simple-vector *unix-errors*))))) - -) - -(defmacro def-enum (inc cur &rest names) - (flet ((defform (name) - (prog1 (when name `(defconstant ,name ,cur)) - (setf cur (funcall inc cur 1))))) - `(progn ,@(mapcar #'defform names)))) - -;;;; Memory-mapped files - -(defconstant +null+ (sys:int-sap 0)) - -(defconstant prot_read 1) -(defconstant prot_write 2) -(defconstant prot_exec 4) -(defconstant prot_none 0) - -(defconstant map_shared 1) -(defconstant map_private 2) -(defconstant map_fixed 16) -(defconstant map_anonymous 32) - -(defconstant ms_async 1) -(defconstant ms_sync 4) -(defconstant ms_invalidate 2) - -;; The return value from mmap that means mmap failed. -(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits)))) - -(defun unix-mmap (addr length prot flags fd offset) - (declare (type (or null system-area-pointer) addr) - (type (unsigned-byte 32) length) - (type (integer 1 7) prot) - (type (unsigned-byte 32) flags) - (type (or null unix-fd) fd) - (type (signed-byte 32) offset)) - ;; Can't use syscall, because the address that is returned could be - ;; "negative". Hence we explicitly check for mmap returning - ;; MAP_FAILED. - (let ((result - (alien-funcall (extern-alien "mmap" (function system-area-pointer - system-area-pointer - size-t int int int off-t)) - (or addr +null+) length prot flags (or fd -1) offset))) - (if (sap= result map_failed) - (values nil (unix-errno)) - (values result 0)))) - -(defun unix-munmap (addr length) - (declare (type system-area-pointer addr) - (type (unsigned-byte 32) length)) - (syscall ("munmap" system-area-pointer size-t) t addr length)) - -(defun unix-msync (addr length flags) - (declare (type system-area-pointer addr) - (type (unsigned-byte 32) length) - (type (signed-byte 32) flags)) - (syscall ("msync" system-area-pointer size-t int) t addr length flags)) - -(defun unix-mprotect (addr length prot) - (declare (type system-area-pointer addr) - (type (unsigned-byte 32) length) - (type (integer 1 7) prot)) - (syscall ("mprotect" system-area-pointer size-t int) - t addr length prot)) - -;;;; Lisp types used by syscalls. - -(deftype unix-pathname () 'simple-string) -(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) - -(deftype unix-file-mode () '(unsigned-byte 32)) -(deftype unix-pid () '(unsigned-byte 32)) -(deftype unix-uid () '(unsigned-byte 32)) -(deftype unix-gid () '(unsigned-byte 32)) - - -;;;; User and group database structures: <pwd.h> and <grp.h> - -(defstruct user-info - (name "" :type string) - (password "" :type string) - (uid 0 :type unix-uid) - (gid 0 :type unix-gid) - (gecos "" :type string) - (dir "" :type string) - (shell "" :type string)) - -(defstruct group-info - (name "" :type string) - (password "" :type string) - (gid 0 :type unix-gid) - (members nil :type list)) ; list of logins as strings - -(def-alien-type nil - (struct passwd - (pw-name (* char)) ; user's login name - (pw-passwd (* char)) ; no longer used - (pw-uid uid-t) ; user id - (pw-gid gid-t) ; group id - (pw-gecos (* char)) ; typically user's full name - (pw-dir (* char)) ; user's home directory - (pw-shell (* char)))) ; user's login shell - -(def-alien-type nil - (struct group - (gr-name (* char)) ; name of the group - (gr-passwd (* char)) ; encrypted group password - (gr-gid gid-t) ; numerical group ID - (gr-mem (* (* char))))) ; vector of pointers to member names - - -;;;; System calls. - -(def-alien-routine ("os_get_errno" unix-get-errno) int) -(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int)) -(defun unix-errno () (unix-get-errno)) -(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue)) - -;;; GET-UNIX-ERROR-MSG -- public. -;;; -(defun get-unix-error-msg (&optional (error-number (unix-errno))) - _N"Returns a string describing the error number which was returned by a - UNIX system call." - (declare (type integer error-number)) - - (if (array-in-bounds-p *unix-errors* error-number) - (svref *unix-errors* error-number) - (format nil (intl:gettext "Unknown error [~d]") error-number))) - -(defmacro syscall ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) - (if (minusp result) - (values nil (unix-errno)) - ,success-form))) - -;;; Like syscall, but if it fails, signal an error instead of returning error -;;; codes. Should only be used for syscalls that will never really get an -;;; error. -;;; -(defmacro syscall* ((name &rest arg-types) success-form &rest args) - `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) - ,@args))) - (if (minusp result) - (error (intl:gettext "Syscall ~A failed: ~A") ,name (get-unix-error-msg)) - ,success-form))) - -(defmacro void-syscall ((name &rest arg-types) &rest args) - `(syscall (,name ,@arg-types) (values t 0) ,@args)) - -(defmacro int-syscall ((name &rest arg-types) &rest args) - `(syscall (,name ,@arg-types) (values result 0) ,@args)) - -;;; From stdio.h - -;;; Unix-rename accepts two files names and renames the first to the second. - -(defun unix-rename (name1 name2) - _N"Unix-rename renames the file with string name1 to the string - name2. NIL and an error code is returned if an error occured." - (declare (type unix-pathname name1 name2)) - (void-syscall ("rename" c-string c-string) - (%name->file name1) (%name->file name2))) - -;;; From sys/types.h -;;; and -;;; gnu/types.h - -(defconstant +max-s-long+ 2147483647) (defconstant +max-u-long+ 4294967295) -(def-alien-type quad-t #+alpha long #-alpha (array long 2)) -(def-alien-type uquad-t #+alpha unsigned-long - #-alpha (array unsigned-long 2)) -(def-alien-type qaddr-t (* quad-t)) -(def-alien-type daddr-t int) -(def-alien-type caddr-t (* char)) -(def-alien-type swblk-t long) (def-alien-type size-t #-alpha unsigned-int #+alpha long) (def-alien-type time-t long) -(def-alien-type clock-t long) -(def-alien-type uid-t unsigned-int) -(def-alien-type ssize-t #-alpha int #+alpha long) -(def-alien-type key-t int) -(def-alien-type int8-t char) -(def-alien-type u-int8-t unsigned-char) -(def-alien-type int16-t short) -(def-alien-type u-int16-t unsigned-short) -(def-alien-type int32-t int) + +(def-alien-type uquad-t #+alpha unsigned-long + #-alpha (array unsigned-long 2)) (def-alien-type u-int32-t unsigned-int) (def-alien-type int64-t (signed 64)) (def-alien-type u-int64-t (unsigned 64)) -(def-alien-type register-t #-alpha int #+alpha long) (def-alien-type dev-t #-amd64 uquad-t #+amd64 u-int64-t) (def-alien-type uid-t unsigned-int) @@ -443,1050 +237,484 @@ (def-alien-type nlink-t #-amd64 unsigned-int #+amd64 u-int64-t) (def-alien-type off-t int64-t) (def-alien-type blkcnt-t u-int64-t) -(def-alien-type fsblkcnt-t u-int64-t) -(def-alien-type fsfilcnt-t u-int64-t) -(def-alien-type pid-t int) -;(def-alien-type ssize-t #-alpha int #+alpha long) -(def-alien-type fsid-t (array int 2)) +;;;; Common machine independent structures. -(def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int) + +;; Needed early in bootstrap. +(defun unix-current-directory () + _N"Put the absolute pathname of the current working directory in BUF. + If successful, return BUF. If not, put an error message in + BUF and return NULL. BUF should be at least PATH_MAX bytes long." + ;; 5120 is some randomly selected maximum size for the buffer for getcwd. + (with-alien ((buf (array c-call:char 5120))) + (let ((result (alien-funcall + (extern-alien "getcwd" + (function (* c-call:char) + (* c-call:char) c-call:int)) + (cast buf (* c-call:char)) + 5120))) + + (values (not (zerop (sap-int (alien-sap result)))) + (%file->name (cast buf c-call:c-string)))))) -(defconstant fd-setsize 1024) -(defconstant nfdbits 32) - -(def-alien-type nil - (struct fd-set - (fds-bits (array fd-mask #.(/ fd-setsize nfdbits))))) +(defconstant o_read o_rdonly _N"Open for reading") +(defconstant o_write o_wronly _N"Open for writing") -(def-alien-type key-t int) +(defconstant o_rdonly 0 _N"Read-only flag.") +(defconstant o_wronly 1 _N"Write-only flag.") +(defconstant o_rdwr 2 _N"Read-write flag.") +(defconstant o_accmode 3 _N"Access mode mask.") -(def-alien-type ipc-pid-t unsigned-short) +#-alpha +(progn + (defconstant o_creat #o100 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_excl #o200 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o400 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_trunc #o1000 _N"Truncate flag. (not fcntl)") + (defconstant o_append #o2000 _N"Append flag.") + (defconstant o_ndelay #o4000 _N"Non-blocking I/O") + (defconstant o_nonblock #o4000 _N"Non-blocking I/O") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o10000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) +#+alpha +(progn + (defconstant o_creat #o1000 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_trunc #o2000 _N"Truncate flag. (not fcntl)") + (defconstant o_excl #o4000 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o10000 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_nonblock #o4 _N"Non-blocking I/O") + (defconstant o_append #o10 _N"Append flag.") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o40000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) -;;; direntry.h +#-alpha +(progn + (defconstant f-getlk 5 _N"Get lock") + (defconstant f-setlk 6 _N"Set lock") + (defconstant f-setlkw 7 _N"Set lock, wait for release") + (defconstant f-setown 8 _N"Set owner (for sockets)") + (defconstant f-getown 9 _N"Get owner (for sockets)")) +#+alpha +(progn + (defconstant f-getlk 7 _N"Get lock") + (defconstant f-setlk 8 _N"Set lock") + (defconstant f-setlkw 9 _N"Set lock, wait for release") + (defconstant f-setown 5 _N"Set owner (for sockets)") + (defconstant f-getown 6 _N"Get owner (for sockets)")) -(def-alien-type nil - (struct dirent - #+glibc2.1 - (d-ino ino-t) ; inode number of entry - #-glibc2.1 - (d-ino ino64-t) ; inode number of entry - (d-off off-t) ; offset of next disk directory entry - (d-reclen unsigned-short) ; length of this record - (d_type unsigned-char) - (d-name (array char 256)))) ; name must be no longer than this -;;; dirent.h +(defconstant F-CLOEXEC 1 _N"for f-getfl and f-setfl") +(defun unix-open (path flags mode) + _N"Unix-open opens the file whose pathname is specified by PATH + for reading and/or writing as specified by the FLAGS argument. + Returns an integer file descriptor. + The flags argument can be: -;;; Operations on Unix Directories. + o_rdonly Read-only flag. + o_wronly Write-only flag. + o_rdwr Read-and-write flag. + o_append Append flag. + o_creat Create-if-nonexistant flag. + o_trunc Truncate-to-size-0 flag. + o_excl Error if the file already exists + o_noctty Don't assign controlling tty + o_ndelay Non-blocking I/O + o_sync Synchronous I/O + o_async Asynchronous I/O -(export '(open-dir read-dir close-dir)) + If the o_creat flag is specified, then the file is created with + a permission of argument MODE if the file doesn't exist." + (declare (type unix-pathname path) + (type fixnum flags) + (type unix-file-mode mode)) + (int-syscall ("open64" c-string int int) (%name->file path) flags mode)) -(defstruct (%directory - (:constructor make-directory) - (:conc-name directory-) - (:print-function %print-directory)) - name - (dir-struct (required-argument) :type system-area-pointer)) - -(defun %print-directory (dir stream depth) - (declare (ignore depth)) - (format stream "#<Directory ~S>" (directory-name dir))) +;;; asm/errno.h +(eval-when (compile eval) -(defun open-dir (pathname) - (declare (type unix-pathname pathname)) - (when (string= pathname "") - (setf pathname ".")) - (let ((kind (unix-file-kind pathname))) - (case kind - (:directory - (let ((dir-struct - (alien-funcall (extern-alien "opendir" - (function system-area-pointer - c-string)) - (%name->file pathname)))) - (if (zerop (sap-int dir-struct)) - (values nil (unix-errno)) - (make-directory :name pathname :dir-struct dir-struct)))) - ((nil) - (values nil enoent)) - (t - (values nil enotdir))))) +(defparameter *compiler-unix-errors* nil) -(defun read-dir (dir) - (declare (type %directory dir)) - (let ((daddr (alien-funcall (extern-alien "readdir64" - (function system-area-pointer - system-area-pointer)) - (directory-dir-struct dir)))) - (declare (type system-area-pointer daddr)) - (if (zerop (sap-int daddr)) - nil - (with-alien ((dirent (* (struct dirent)) daddr)) - (values (%file->name (cast (slot dirent 'd-name) c-string)) - (slot dirent 'd-ino)))))) +(defmacro def-unix-error (name number description) + `(progn + (eval-when (compile eval) + (push (cons ,number ,description) *compiler-unix-errors*)) + (defconstant ,name ,number ,description) + (export ',name))) -(defun close-dir (dir) - (declare (type %directory dir)) - (alien-funcall (extern-alien "closedir" - (function void system-area-pointer)) - (directory-dir-struct dir)) - nil) +(defmacro emit-unix-errors () + (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) + (array (make-array (1+ max) :initial-element nil))) + (dolist (error *compiler-unix-errors*) + (setf (svref array (car error)) (cdr error))) + `(progn + (defvar *unix-errors* ',array) + (declaim (simple-vector *unix-errors*))))) -;;; dlfcn.h -> in foreign.lisp +) -;;; fcntl.h -;;; -;;; POSIX Standard: 6.5 File Control Operations <fcntl.h> +(def-unix-error ESUCCESS 0 _N"Successful") +(def-unix-error EPERM 1 _N"Operation not permitted") +(def-unix-error ENOENT 2 _N"No such file or directory") +(def-unix-error ESRCH 3 _N"No such process") +(def-unix-error EINTR 4 _N"Interrupted system call") +(def-unix-error EIO 5 _N"I/O error") +(def-unix-error ENXIO 6 _N"No such device or address") +(def-unix-error E2BIG 7 _N"Arg list too long") +(def-unix-error ENOEXEC 8 _N"Exec format error") +(def-unix-error EBADF 9 _N"Bad file number") +(def-unix-error ECHILD 10 _N"No children") +(def-unix-error EAGAIN 11 _N"Try again") +(def-unix-error ENOMEM 12 _N"Out of memory") +(def-unix-error EACCES 13 _N"Permission denied") +(def-unix-error EFAULT 14 _N"Bad address") +(def-unix-error ENOTBLK 15 _N"Block device required") +(def-unix-error EBUSY 16 _N"Device or resource busy") +(def-unix-error EEXIST 17 _N"File exists") +(def-unix-error EXDEV 18 _N"Cross-device link") +(def-unix-error ENODEV 19 _N"No such device") +(def-unix-error ENOTDIR 20 _N"Not a director") +(def-unix-error EISDIR 21 _N"Is a directory") +(def-unix-error EINVAL 22 _N"Invalid argument") +(def-unix-error ENFILE 23 _N"File table overflow") +(def-unix-error EMFILE 24 _N"Too many open files") +(def-unix-error ENOTTY 25 _N"Not a typewriter") +(def-unix-error ETXTBSY 26 _N"Text file busy") +(def-unix-error EFBIG 27 _N"File too large") +(def-unix-error ENOSPC 28 _N"No space left on device") +(def-unix-error ESPIPE 29 _N"Illegal seek") +(def-unix-error EROFS 30 _N"Read-only file system") +(def-unix-error EMLINK 31 _N"Too many links") +(def-unix-error EPIPE 32 _N"Broken pipe") +;;; +;;; Math +(def-unix-error EDOM 33 _N"Math argument out of domain") +(def-unix-error ERANGE 34 _N"Math result not representable") +;;; +(def-unix-error EDEADLK 35 _N"Resource deadlock would occur") +(def-unix-error ENAMETOOLONG 36 _N"File name too long") +(def-unix-error ENOLCK 37 _N"No record locks available") +(def-unix-error ENOSYS 38 _N"Function not implemented") +(def-unix-error ENOTEMPTY 39 _N"Directory not empty") +(def-unix-error ELOOP 40 _N"Too many symbolic links encountered") +(def-unix-error EWOULDBLOCK 11 _N"Operation would block") +(def-unix-error ENOMSG 42 _N"No message of desired type") +(def-unix-error EIDRM 43 _N"Identifier removed") +(def-unix-error ECHRNG 44 _N"Channel number out of range") +(def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized") +(def-unix-error EL3HLT 46 _N"Level 3 halted") +(def-unix-error EL3RST 47 _N"Level 3 reset") +(def-unix-error ELNRNG 48 _N"Link number out of range") +(def-unix-error EUNATCH 49 _N"Protocol driver not attached") +(def-unix-error ENOCSI 50 _N"No CSI structure available") +(def-unix-error EL2HLT 51 _N"Level 2 halted") +(def-unix-error EBADE 52 _N"Invalid exchange") +(def-unix-error EBADR 53 _N"Invalid request descriptor") +(def-unix-error EXFULL 54 _N"Exchange full") +(def-unix-error ENOANO 55 _N"No anode") +(def-unix-error EBADRQC 56 _N"Invalid request code") +(def-unix-error EBADSLT 57 _N"Invalid slot") +(def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error") +(def-unix-error EBFONT 59 _N"Bad font file format") +(def-unix-error ENOSTR 60 _N"Device not a stream") +(def-unix-error ENODATA 61 _N"No data available") +(def-unix-error ETIME 62 _N"Timer expired") +(def-unix-error ENOSR 63 _N"Out of streams resources") +(def-unix-error ENONET 64 _N"Machine is not on the network") +(def-unix-error ENOPKG 65 _N"Package not installed") +(def-unix-error EREMOTE 66 _N"Object is remote") +(def-unix-error ENOLINK 67 _N"Link has been severed") +(def-unix-error EADV 68 _N"Advertise error") +(def-unix-error ESRMNT 69 _N"Srmount error") +(def-unix-error ECOMM 70 _N"Communication error on send") +(def-unix-error EPROTO 71 _N"Protocol error") +(def-unix-error EMULTIHOP 72 _N"Multihop attempted") +(def-unix-error EDOTDOT 73 _N"RFS specific error") +(def-unix-error EBADMSG 74 _N"Not a data message") +(def-unix-error EOVERFLOW 75 _N"Value too large for defined data type") +(def-unix-error ENOTUNIQ 76 _N"Name not unique on network") +(def-unix-error EBADFD 77 _N"File descriptor in bad state") +(def-unix-error EREMCHG 78 _N"Remote address changed") +(def-unix-error ELIBACC 79 _N"Can not access a needed shared library") +(def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library") +(def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted") +(def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries") +(def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly") +(def-unix-error EILSEQ 84 _N"Illegal byte sequence") +(def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N") +(def-unix-error ESTRPIPE 86 _N"Streams pipe error") +(def-unix-error EUSERS 87 _N"Too many users") +(def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket") +(def-unix-error EDESTADDRREQ 89 _N"Destination address required") +(def-unix-error EMSGSIZE 90 _N"Message too long") +(def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket") +(def-unix-error ENOPROTOOPT 92 _N"Protocol not available") +(def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported") +(def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported") +(def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint") +(def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported") +(def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol") +(def-unix-error EADDRINUSE 98 _N"Address already in use") +(def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address") +(def-unix-error ENETDOWN 100 _N"Network is down") +(def-unix-error ENETUNREACH 101 _N"Network is unreachable") +(def-unix-error ENETRESET 102 _N"Network dropped connection because of reset") +(def-unix-error ECONNABORTED 103 _N"Software caused connection abort") +(def-unix-error ECONNRESET 104 _N"Connection reset by peer") +(def-unix-error ENOBUFS 105 _N"No buffer space available") +(def-unix-error EISCONN 106 _N"Transport endpoint is already connected") +(def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected") +(def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown") +(def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice") +(def-unix-error ETIMEDOUT 110 _N"Connection timed out") +(def-unix-error ECONNREFUSED 111 _N"Connection refused") +(def-unix-error EHOSTDOWN 112 _N"Host is down") +(def-unix-error EHOSTUNREACH 113 _N"No route to host") +(def-unix-error EALREADY 114 _N"Operation already in progress") +(def-unix-error EINPROGRESS 115 _N"Operation now in progress") +(def-unix-error ESTALE 116 _N"Stale NFS file handle") +(def-unix-error EUCLEAN 117 _N"Structure needs cleaning") +(def-unix-error ENOTNAM 118 _N"Not a XENIX named type file") +(def-unix-error ENAVAIL 119 _N"No XENIX semaphores available") +(def-unix-error EISNAM 120 _N"Is a named type file") +(def-unix-error EREMOTEIO 121 _N"Remote I/O error") +(def-unix-error EDQUOT 122 _N"Quota exceeded") -(defconstant r_ok 4 _N"Test for read permission") -(defconstant w_ok 2 _N"Test for write permission") -(defconstant x_ok 1 _N"Test for execute permission") -(defconstant f_ok 0 _N"Test for presence of file") +;;; And now for something completely different ... +(emit-unix-errors) -(defun unix-fcntl (fd cmd arg) - _N"Unix-fcntl manipulates file descriptors accoridng to the - argument CMD which can be one of the following: +(def-alien-type nil + (struct passwd + (pw-name (* char)) ; user's login name + (pw-passwd (* char)) ; no longer used + (pw-uid uid-t) ; user id + (pw-gid gid-t) ; group id + (pw-gecos (* char)) ; typically user's full name + (pw-dir (* char)) ; user's home directory + (pw-shell (* char)))) ; user's login shell - F-DUPFD Duplicate a file descriptor. - F-GETFD Get file descriptor flags. - F-SETFD Set file descriptor flags. - F-GETFL Get file flags. - F-SETFL Set file flags. - F-GETOWN Get owner. - F-SETOWN Set owner. +;;;; System calls. - The flags that can be specified for F-SETFL are: +(def-alien-routine ("os_get_errno" unix-get-errno) int) +(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int)) +(defun unix-errno () (unix-get-errno)) +(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue)) - FNDELAY Non-blocking reads. - FAPPEND Append on each write. - FASYNC Signal pgrp when data ready. - FCREAT Create if nonexistant. - FTRUNC Truncate to zero length. - FEXCL Error if already created. - " - (declare (type unix-fd fd) - (type (unsigned-byte 32) cmd) - (type (unsigned-byte 32) arg)) - (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg)) +;;; GET-UNIX-ERROR-MSG -- public. +;;; +(defun get-unix-error-msg (&optional (error-number (unix-errno))) + _N"Returns a string describing the error number which was returned by a + UNIX system call." + (declare (type integer error-number)) + + (if (array-in-bounds-p *unix-errors* error-number) + (svref *unix-errors* error-number) + (format nil (intl:gettext "Unknown error [~d]") error-number))) -(defun unix-open (path flags mode) - _N"Unix-open opens the file whose pathname is specified by PATH - for reading and/or writing as specified by the FLAGS argument. - Returns an integer file descriptor. - The flags argument can be: +(defmacro syscall ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (values nil (unix-errno)) + ,success-form))) - o_rdonly Read-only flag. - o_wronly Write-only flag. - o_rdwr Read-and-write flag. - o_append Append flag. - o_creat Create-if-nonexistant flag. - o_trunc Truncate-to-size-0 flag. - o_excl Error if the file already exists - o_noctty Don't assign controlling tty - o_ndelay Non-blocking I/O - o_sync Synchronous I/O - o_async Asynchronous I/O - - If the o_creat flag is specified, then the file is created with - a permission of argument MODE if the file doesn't exist." - (declare (type unix-pathname path) - (type fixnum flags) - (type unix-file-mode mode)) - (int-syscall ("open64" c-string int int) (%name->file path) flags mode)) +;;; Like syscall, but if it fails, signal an error instead of returning error +;;; codes. Should only be used for syscalls that will never really get an +;;; error. +;;; +(defmacro syscall* ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (error (intl:gettext "Syscall ~A failed: ~A") ,name (get-unix-error-msg)) + ,success-form))) -(defun unix-getdtablesize () - _N"Unix-getdtablesize returns the maximum size of the file descriptor - table. (i.e. the maximum number of descriptors that can exist at - one time.)" - (int-syscall ("getdtablesize"))) +(defmacro void-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values t 0) ,@args)) -;;; Unix-close accepts a file descriptor and attempts to close the file -;;; associated with it. +(defmacro int-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values result 0) ,@args)) -(defun unix-close (fd) - _N"Unix-close takes an integer file descriptor as an argument and - closes the file associated with it. T is returned upon successful - completion, otherwise NIL and an error number." - (declare (type unix-fd fd)) - (void-syscall ("close" int) fd)) +;;; Unix-write accepts a file descriptor, a buffer, an offset, and the +;;; length to write. It attempts to write len bytes to the device +;;; associated with fd from the the buffer starting at offset. It returns +;;; the actual number of bytes written. -;;; Unix-creat accepts a file name and a mode. It creates a new file -;;; with name and sets it mode to mode (as for chmod). +(defun unix-write (fd buf offset len) + _N"Unix-write attempts to write a character buffer (buf) of length + len to the file described by the file descriptor fd. NIL and an + error is returned if the call is unsuccessful." + (declare (type unix-fd fd) + (type (unsigned-byte 32) offset len)) + (int-syscall ("write" int (* char) int) + fd + (with-alien ((ptr (* char) (etypecase buf + ((simple-array * (*)) + (vector-sap buf)) + (system-area-pointer + buf)))) + (addr (deref ptr offset))) + len)) -(defun unix-creat (name mode) - _N"Unix-creat accepts a file name and a mode (same as those for - unix-chmod) and creates a file by that name with the specified - permission mode. It returns a file descriptor on success, - or NIL and an error number otherwise. +(defun unix-pipe () + _N"Unix-pipe sets up a unix-piping mechanism consisting of + an input pipe and an output pipe. Unix-Pipe returns two + values: if no error occurred the first value is the pipe + to be read from and the second is can be written to. If + an error occurred the first value is NIL and the second + the unix error code." + (with-alien ((fds (array int 2))) + (syscall ("pipe" (* int)) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int))))) - This interface is made obsolete by UNIX-OPEN." - - (declare (type unix-pathname name) - (type unix-file-mode mode)) - (int-syscall ("creat64" c-string int) (%name->file name) mode)) +;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. +;;; It attempts to read len bytes from the device associated with fd +;;; and store them into the buffer. It returns the actual number of +;;; bytes read. -;;; fcntlbits.h +(defun unix-read (fd buf len) + _N"UNIX-READ attempts to read from the file described by fd into + the buffer buf until it is full. Len is the length of the buffer. + The number of bytes actually read is returned or NIL and an error + number if an error occured." + (declare (type unix-fd fd) + (type (unsigned-byte 32) len)) + #+gencgc + ;; With gencgc, the collector tries to keep raw objects like strings + ;; in separate pages that are not write-protected. However, this + ;; isn't always true. Thus, BUF will sometimes be write-protected + ;; and the kernel doesn't like writing to write-protected pages. So + ;; go through and touch each page to give the segv handler a chance + ;; to unprotect the pages. (This is taken from unix.lisp.) + (without-gcing + (let* ((page-size (get-page-size)) + (1-page-size (1- page-size)) + (sap (etypecase buf + (system-area-pointer buf) + (vector (vector-sap buf)))) + (end (sap+ sap len))) + (declare (type (and fixnum unsigned-byte) page-size 1-page-size) + (type system-area-pointer sap end) + (optimize (speed 3) (safety 0))) + ;; Touch the beginning of every page + (do ((sap (int-sap (logand (sap-int sap) + (logxor 1-page-size (ldb (byte 32 0) -1)))) + (sap+ sap page-size))) + ((sap>= sap end)) + (declare (type system-area-pointer sap)) + (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0))))) + (int-syscall ("read" int (* char) int) fd buf len)) -(defconstant o_read o_rdonly _N"Open for reading") -(defconstant o_write o_wronly _N"Open for writing") +;;; Unix-getpagesize returns the number of bytes in the system page. -(defconstant o_rdonly 0 _N"Read-only flag.") -(defconstant o_wronly 1 _N"Write-only flag.") -(defconstant o_rdwr 2 _N"Read-write flag.") -(defconstant o_accmode 3 _N"Access mode mask.") +(defun unix-getpagesize () + _N"Unix-getpagesize returns the number of bytes in a system page." + (int-syscall ("getpagesize"))) -#-alpha -(progn - (defconstant o_creat #o100 _N"Create if nonexistant flag. (not fcntl)") - (defconstant o_excl #o200 _N"Error if already exists. (not fcntl)") - (defconstant o_noctty #o400 _N"Don't assign controlling tty. (not fcntl)") - (defconstant o_trunc #o1000 _N"Truncate flag. (not fcntl)") - (defconstant o_append #o2000 _N"Append flag.") - (defconstant o_ndelay #o4000 _N"Non-blocking I/O") - (defconstant o_nonblock #o4000 _N"Non-blocking I/O") - (defconstant o_ndelay o_nonblock) - (defconstant o_sync #o10000 _N"Synchronous writes (on ext2)") - (defconstant o_fsync o_sync) - (defconstant o_async #o20000 _N"Asynchronous I/O")) -#+alpha -(progn - (defconstant o_creat #o1000 _N"Create if nonexistant flag. (not fcntl)") - (defconstant o_trunc #o2000 _N"Truncate flag. (not fcntl)") - (defconstant o_excl #o4000 _N"Error if already exists. (not fcntl)") - (defconstant o_noctty #o10000 _N"Don't assign controlling tty. (not fcntl)") - (defconstant o_nonblock #o4 _N"Non-blocking I/O") - (defconstant o_append #o10 _N"Append flag.") - (defconstant o_ndelay o_nonblock) - (defconstant o_sync #o40000 _N"Synchronous writes (on ext2)") - (defconstant o_fsync o_sync) - (defconstant o_async #o20000 _N"Asynchronous I/O")) +;;; sys/stat.h -(defconstant f-dupfd 0 _N"Duplicate a file descriptor") -(defconstant f-getfd 1 _N"Get file desc. flags") -(defconstant f-setfd 2 _N"Set file desc. flags") -(defconstant f-getfl 3 _N"Get file flags") -(defconstant f-setfl 4 _N"Set file flags") +(defmacro extract-stat-results (buf) + `(values T + #+(or alpha amd64) + (slot ,buf 'st-dev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-dev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-ino) + (slot ,buf 'st-mode) + (slot ,buf 'st-nlink) + (slot ,buf 'st-uid) + (slot ,buf 'st-gid) + #+(or alpha amd64) + (slot ,buf 'st-rdev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-rdev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-size) + (slot ,buf 'st-atime) + (slot ,buf 'st-mtime) + (slot ,buf 'st-ctime) + (slot ,buf 'st-blksize) + (slot ,buf 'st-blocks))) -#-alpha -(progn - (defconstant f-getlk 5 _N"Get lock") - (defconstant f-setlk 6 _N"Set lock") - (defconstant f-setlkw 7 _N"Set lock, wait for release") - (defconstant f-setown 8 _N"Set owner (for sockets)") - (defconstant f-getown 9 _N"Get owner (for sockets)")) -#+alpha -(progn - (defconstant f-getlk 7 _N"Get lock") - (defconstant f-setlk 8 _N"Set lock") - (defconstant f-setlkw 9 _N"Set lock, wait for release") - (defconstant f-setown 5 _N"Set owner (for sockets)") - (defconstant f-getown 6 _N"Get owner (for sockets)")) +;;; bits/stat.h +(def-alien-type nil + (struct stat + (st-dev dev-t) + #-(or alpha amd64) (st-pad1 unsigned-short) + (st-ino ino-t) + #+alpha (st-pad1 unsigned-int) + #-amd64 (st-mode mode-t) + (st-nlink nlink-t) + #+amd64 (st-mode mode-t) + (st-uid uid-t) + (st-gid gid-t) + (st-rdev dev-t) + #-alpha (st-pad2 unsigned-short) + (st-size off-t) + #-alpha (st-blksize unsigned-long) + #-alpha (st-blocks blkcnt-t) + (st-atime time-t) + #-alpha (unused-1 unsigned-long) + (st-mtime time-t) + #-alpha (unused-2 unsigned-long) + (st-ctime time-t) + #+alpha (st-blocks int) + #+alpha (st-pad2 unsigned-int) + #+alpha (st-blksize unsigned-int) + #+alpha (st-flags unsigned-int) + #+alpha (st-gen unsigned-int) + #+alpha (st-pad3 unsigned-int) + #+alpha (unused-1 unsigned-long) + #+alpha (unused-2 unsigned-long) + (unused-3 unsigned-long) + (unused-4 unsigned-long) + #-alpha (unused-5 unsigned-long))) +(defun unix-stat (name) + _N"UNIX-STAT retrieves information about the specified + file returning them in the form of multiple values. + See the UNIX Programmer's Manual for a description + of the values returned. If the call fails, then NIL + and an error number is returned instead." + (declare (type unix-pathname name)) + (when (string= name "") + (setf name ".")) + (with-alien ((buf (struct stat))) + (syscall ("stat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) -(defconstant F-CLOEXEC 1 _N"for f-getfl and f-setfl") +(defun unix-fstat (fd) + _N"UNIX-FSTAT is similar to UNIX-STAT except the file is specified + by the file descriptor FD." + (declare (type unix-fd fd)) + (with-alien ((buf (struct stat))) + (syscall ("fstat64" int (* (struct stat))) + (extract-stat-results buf) + fd (addr buf)))) -#-alpha -(progn - (defconstant F-RDLCK 0 _N"for fcntl and lockf") - (defconstant F-WRLCK 1 _N"for fcntl and lockf") - (defconstant F-UNLCK 2 _N"for fcntl and lockf") - (defconstant F-EXLCK 4 _N"old bsd flock (depricated)") - (defconstant F-SHLCK 8 _N"old bsd flock (depricated)")) -#+alpha -(progn - (defconstant F-RDLCK 1 _N"for fcntl and lockf") - (defconstant F-WRLCK 2 _N"for fcntl and lockf") - (defconstant F-UNLCK 8 _N"for fcntl and lockf") - (defconstant F-EXLCK 16 _N"old bsd flock (depricated)") - (defconstant F-SHLCK 32 _N"old bsd flock (depricated)")) +(defun unix-lstat (name) + _N"UNIX-LSTAT is similar to UNIX-STAT except the specified + file must be a symbolic link." + (declare (type unix-pathname name)) + (with-alien ((buf (struct stat))) + (syscall ("lstat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) -(defconstant F-LOCK-SH 1 _N"Shared lock for bsd flock") -(defconstant F-LOCK-EX 2 _N"Exclusive lock for bsd flock") -(defconstant F-LOCK-NB 4 _N"Don't block. Combine with F-LOCK-SH or F-LOCK-EX") -(defconstant F-LOCK-UN 8 _N"Remove lock for bsd flock") +;; Encoding of the file mode. -(def-alien-type nil - (struct flock - (l-type short) - (l-whence short) - (l-start off-t) - (l-len off-t) - (l-pid pid-t))) +(defconstant s-ifmt #o0170000 _N"These bits determine file type.") -;;; Define some more compatibility macros to be backward compatible with -;;; BSD systems which did not managed to hide these kernel macros. - -(defconstant FAPPEND o_append _N"depricated stuff") -(defconstant FFSYNC o_fsync _N"depricated stuff") -(defconstant FASYNC o_async _N"depricated stuff") -(defconstant FNONBLOCK o_nonblock _N"depricated stuff") -(defconstant FNDELAY o_ndelay _N"depricated stuff") - - -;;; grp.h - -;;; POSIX Standard: 9.2.1 Group Database Access <grp.h> - -#+(or) -(defun unix-setgrend () - _N"Rewind the group-file stream." - (void-syscall ("setgrend"))) - -#+(or) -(defun unix-endgrent () - _N"Close the group-file stream." - (void-syscall ("endgrent"))) - -#+(or) -(defun unix-getgrent () - _N"Read an entry from the group-file stream, opening it if necessary." - - (let ((result (alien-funcall (extern-alien "getgrent" - (function (* (struct group))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;;; ioctl-types.h - -(def-alien-type nil - (struct winsize - (ws-row unsigned-short) ; rows, in characters - (ws-col unsigned-short) ; columns, in characters - (ws-xpixel unsigned-short) ; horizontal size, pixels - (ws-ypixel unsigned-short))) ; veritical size, pixels - -(defconstant +NCC+ 8 - _N"Size of control character vector.") - -(def-alien-type nil - (struct termio - (c-iflag unsigned-int) ; input mode flags - (c-oflag unsigned-int) ; output mode flags - (c-cflag unsigned-int) ; control mode flags - (c-lflag unsigned-int) ; local mode flags - (c-line unsigned-char) ; line discipline - (c-cc (array unsigned-char #.+NCC+)))) ; control characters - -;;; modem lines -(defconstant tiocm-le 1) -(defconstant tiocm-dtr 2) -(defconstant tiocm-rts 4) -(defconstant tiocm-st 8) -(defconstant tiocm-sr #x10) -(defconstant tiocm-cts #x20) -(defconstant tiocm-car #x40) -(defconstant tiocm-rng #x80) -(defconstant tiocm-dsr #x100) -(defconstant tiocm-cd tiocm-car) -(defconstant tiocm-ri #x80) - -;;; ioctl (fd, TIOCSERGETLSR, &result) where result may be as below - -;;; line disciplines -(defconstant N-TTY 0) -(defconstant N-SLIP 1) -(defconstant N-MOUSE 2) -(defconstant N-PPP 3) -(defconstant N-STRIP 4) -(defconstant N-AX25 5) - - -;;; ioctls.h - -;;; Routing table calls. -(defconstant siocaddrt #x890B) ;; add routing table entry -(defconstant siocdelrt #x890C) ;; delete routing table entry -(defconstant siocrtmsg #x890D) ;; call to routing system - -;;; Socket configuration controls. -(defconstant siocgifname #x8910) ;; get iface name -(defconstant siocsiflink #x8911) ;; set iface channel -(defconstant siocgifconf #x8912) ;; get iface list -(defconstant siocgifflags #x8913) ;; get flags -(defconstant siocsifflags #x8914) ;; set flags -(defconstant siocgifaddr #x8915) ;; get PA address -(defconstant siocsifaddr #x8916) ;; set PA address -(defconstant siocgifdstaddr #x8917 ) ;; get remote PA address -(defconstant siocsifdstaddr #x8918 ) ;; set remote PA address -(defconstant siocgifbrdaddr #x8919 ) ;; get broadcast PA address -(defconstant siocsifbrdaddr #x891a ) ;; set broadcast PA address -(defconstant siocgifnetmask #x891b ) ;; get network PA mask -(defconstant siocsifnetmask #x891c ) ;; set network PA mask -(defconstant siocgifmetric #x891d ) ;; get metric -(defconstant siocsifmetric #x891e ) ;; set metric -(defconstant siocgifmem #x891f ) ;; get memory address (BSD) -(defconstant siocsifmem #x8920 ) ;; set memory address (BSD) -(defconstant siocgifmtu #x8921 ) ;; get MTU size -(defconstant siocsifmtu #x8922 ) ;; set MTU size -(defconstant siocsifhwaddr #x8924 ) ;; set hardware address -(defconstant siocgifencap #x8925 ) ;; get/set encapsulations -(defconstant siocsifencap #x8926) -(defconstant siocgifhwaddr #x8927 ) ;; Get hardware address -(defconstant siocgifslave #x8929 ) ;; Driver slaving support -(defconstant siocsifslave #x8930) -(defconstant siocaddmulti #x8931 ) ;; Multicast address lists -(defconstant siocdelmulti #x8932) -(defconstant siocgifindex #x8933 ) ;; name -> if_index mapping -(defconstant siogifindex SIOCGIFINDEX ) ;; misprint compatibility :-) -(defconstant siocsifpflags #x8934 ) ;; set/get extended flags set -(defconstant siocgifpflags #x8935) -(defconstant siocdifaddr #x8936 ) ;; delete PA address -(defconstant siocsifhwbroadcast #x8937 ) ;; set hardware broadcast addr -(defconstant siocgifcount #x8938 ) ;; get number of devices - -(defconstant siocgifbr #x8940 ) ;; Bridging support -(defconstant siocsifbr #x8941 ) ;; Set bridging options - -(defconstant siocgiftxqlen #x8942 ) ;; Get the tx queue length -(defconstant siocsiftxqlen #x8943 ) ;; Set the tx queue length - - -;;; ARP cache control calls. -;; 0x8950 - 0x8952 * obsolete calls, don't re-use -(defconstant siocdarp #x8953 ) ;; delete ARP table entry -(defconstant siocgarp #x8954 ) ;; get ARP table entry -(defconstant siocsarp #x8955 ) ;; set ARP table entry - -;;; RARP cache control calls. -(defconstant siocdrarp #x8960 ) ;; delete RARP table entry -(defconstant siocgrarp #x8961 ) ;; get RARP table entry -(defconstant siocsrarp #x8962 ) ;; set RARP table entry - -;;; Driver configuration calls - -(defconstant siocgifmap #x8970 ) ;; Get device parameters -(defconstant siocsifmap #x8971 ) ;; Set device parameters - -;;; DLCI configuration calls - -(defconstant siocadddlci #x8980 ) ;; Create new DLCI device -(defconstant siocdeldlci #x8981 ) ;; Delete DLCI device - -;;; Device private ioctl calls. - -;; These 16 ioctls are available to devices via the do_ioctl() device -;; vector. Each device should include this file and redefine these -;; names as their own. Because these are device dependent it is a good -;; idea _NOT_ to issue them to random objects and hope. - -(defconstant siocdevprivate #x89F0 ) ;; to 89FF - - -;;; netdb.h - -;; All data returned by the network data base library are supplied in -;; host order and returned in network order (suitable for use in -;; system calls). - -;;; Absolute file name for network data base files. -(defconstant path-hequiv "/etc/hosts.equiv") -(defconstant path-hosts "/etc/hosts") -(defconstant path-networks "/etc/networks") -(defconstant path-nsswitch_conf "/etc/nsswitch.conf") -(defconstant path-protocols "/etc/protocols") -(defconstant path-services "/etc/services") - - -;;; Possible values left in `h_errno'. -(defconstant netdb-internal -1 _N"See errno.") -(defconstant netdb-success 0 _N"No problem.") -(defconstant host-not-found 1 _N"Authoritative Answer Host not found.") -(defconstant try-again 2 _N"Non-Authoritative Host not found,or SERVERFAIL.") -(defconstant no-recovery 3 _N"Non recoverable errors, FORMERR, REFUSED, NOTIMP.") -(defconstant no-data 4 "Valid name, no data record of requested type.") -(defconstant no-address no-data "No address, look for MX record.") - -;;; Description of data base entry for a single host. - -(def-alien-type nil - (struct hostent - (h-name c-string) ; Official name of host. - (h-aliases (* c-string)) ; Alias list. - (h-addrtype int) ; Host address type. - (h_length int) ; Length of address. - (h-addr-list (* c-string)))) ; List of addresses from name server. - -#+(or) -(defun unix-sethostent (stay-open) - _N"Open host data base files and mark them as staying open even after -a later search if STAY_OPEN is non-zero." - (void-syscall ("sethostent" int) stay-open)) - -#+(or) -(defun unix-endhostent () - _N"Close host data base files and clear `stay open' flag." - (void-syscall ("endhostent"))) - -#+(or) -(defun unix-gethostent () - _N"Get next entry from host data base file. Open data base if -necessary." - (let ((result (alien-funcall (extern-alien "gethostent" - (function (* (struct hostent))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-gethostbyaddr(addr length type) - _N"Return entry from host data base which address match ADDR with -length LEN and type TYPE." - (let ((result (alien-funcall (extern-alien "gethostbyaddr" - (function (* (struct hostent)) - c-string int int)) - addr len type))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-gethostbyname (name) - _N"Return entry from host data base for host with NAME." - (let ((result (alien-funcall (extern-alien "gethostbyname" - (function (* (struct hostent)) - c-string)) - name))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-gethostbyname2 (name af) - _N"Return entry from host data base for host with NAME. AF must be - set to the address type which as `AF_INET' for IPv4 or `AF_INET6' - for IPv6." - (let ((result (alien-funcall (extern-alien "gethostbyname2" - (function (* (struct hostent)) - c-string int)) - name af))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;; Description of data base entry for a single network. NOTE: here a -;; poor assumption is made. The network number is expected to fit -;; into an unsigned long int variable. - -(def-alien-type nil - (struct netent - (n-name c-string) ; Official name of network. - (n-aliases (* c-string)) ; Alias list. - (n-addrtype int) ; Net address type. - (n-net unsigned-long))) ; Network number. - -#+(or) -(defun unix-setnetent (stay-open) - _N"Open network data base files and mark them as staying open even - after a later search if STAY_OPEN is non-zero." - (void-syscall ("setnetent" int) stay-open)) - - -#+(or) -(defun unix-endnetent () - _N"Close network data base files and clear `stay open' flag." - (void-syscall ("endnetent"))) - - -#+(or) -(defun unix-getnetent () - _N"Get next entry from network data base file. Open data base if - necessary." - (let ((result (alien-funcall (extern-alien "getnetent" - (function (* (struct netent))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - - -#+(or) -(defun unix-getnetbyaddr (net type) - _N"Return entry from network data base which address match NET and - type TYPE." - (let ((result (alien-funcall (extern-alien "getnetbyaddr" - (function (* (struct netent)) - unsigned-long int)) - net type))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getnetbyname (name) - _N"Return entry from network data base for network with NAME." - (let ((result (alien-funcall (extern-alien "getnetbyname" - (function (* (struct netent)) - c-string)) - name))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;; Description of data base entry for a single service. -(def-alien-type nil - (struct servent - (s-name c-string) ; Official service name. - (s-aliases (* c-string)) ; Alias list. - (s-port int) ; Port number. - (s-proto c-string))) ; Protocol to use. - -#+(or) -(defun unix-setservent (stay-open) - _N"Open service data base files and mark them as staying open even - after a later search if STAY_OPEN is non-zero." - (void-syscall ("setservent" int) stay-open)) - -#+(or) -(defun unix-endservent (stay-open) - _N"Close service data base files and clear `stay open' flag." - (void-syscall ("endservent"))) - - -#+(or) -(defun unix-getservent () - _N"Get next entry from service data base file. Open data base if - necessary." - (let ((result (alien-funcall (extern-alien "getservent" - (function (* (struct servent))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getservbyname (name proto) - _N"Return entry from network data base for network with NAME and - protocol PROTO." - (let ((result (alien-funcall (extern-alien "getservbyname" - (function (* (struct netent)) - c-string (* char))) - name proto))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getservbyport (port proto) - _N"Return entry from service data base which matches port PORT and - protocol PROTO." - (let ((result (alien-funcall (extern-alien "getservbyport" - (function (* (struct netent)) - int (* char))) - port proto))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;; Description of data base entry for a single service. - -(def-alien-type nil - (struct protoent - (p-name c-string) ; Official protocol name. - (p-aliases (* c-string)) ; Alias list. - (p-proto int))) ; Protocol number. - -#+(or) -(defun unix-setprotoent (stay-open) - _N"Open protocol data base files and mark them as staying open even - after a later search if STAY_OPEN is non-zero." - (void-syscall ("setprotoent" int) stay-open)) - -#+(or) -(defun unix-endprotoent () - _N"Close protocol data base files and clear `stay open' flag." - (void-syscall ("endprotoent"))) - -#+(or) -(defun unix-getprotoent () - _N"Get next entry from protocol data base file. Open data base if - necessary." - (let ((result (alien-funcall (extern-alien "getprotoent" - (function (* (struct protoent))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getprotobyname (name) - _N"Return entry from protocol data base for network with NAME." - (let ((result (alien-funcall (extern-alien "getprotobyname" - (function (* (struct protoent)) - c-string)) - name))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getprotobynumber (proto) - _N"Return entry from protocol data base which number is PROTO." - (let ((result (alien-funcall (extern-alien "getprotobynumber" - (function (* (struct protoent)) - int)) - proto))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-setnetgrent (netgroup) - _N"Establish network group NETGROUP for enumeration." - (int-syscall ("setservent" c-string) netgroup)) - -#+(or) -(defun unix-endnetgrent () - _N"Free all space allocated by previous `setnetgrent' call." - (void-syscall ("endnetgrent"))) - -#+(or) -(defun unix-getnetgrent (hostp userp domainp) - _N"Get next member of netgroup established by last `setnetgrent' call - and return pointers to elements in HOSTP, USERP, and DOMAINP." - (int-syscall ("getnetgrent" (* c-string) (* c-string) (* c-string)) - hostp userp domainp)) - -#+(or) -(defun unix-innetgr (netgroup host user domain) - _N"Test whether NETGROUP contains the triple (HOST,USER,DOMAIN)." - (int-syscall ("innetgr" c-string c-string c-string c-string) - netgroup host user domain)) - -(def-alien-type nil - (struct addrinfo - (ai-flags int) ; Input flags. - (ai-family int) ; Protocol family for socket. - (ai-socktype int) ; Socket type. - (ai-protocol int) ; Protocol for socket. - (ai-addrlen int) ; Length of socket address. - (ai-addr (* (struct sockaddr))) - ; Socket address for socket. - (ai-cononname c-string) - ; Canonical name for service location. - (ai-net (* (struct addrinfo))))) ; Pointer to next in list. - -;; Possible values for `ai_flags' field in `addrinfo' structure. - -(defconstant ai_passive 1 _N"Socket address is intended for `bind'.") -(defconstant ai_canonname 2 _N"Request for canonical name.") - -;; Error values for `getaddrinfo' function. -(defconstant eai_badflags -1 _N"Invalid value for `ai_flags' field.") -(defconstant eai_noname -2 _N"NAME or SERVICE is unknown.") -(defconstant eai_again -3 _N"Temporary failure in name resolution.") -(defconstant eai_fail -4 _N"Non-recoverable failure in name res.") -(defconstant eai_nodata -5 _N"No address associated with NAME.") -(defconstant eai_family -6 _N"ai_family not supported.") -(defconstant eai_socktype -7 _N"ai_socktype not supported.") -(defconstant eai_service -8 _N"SERVICE not supported for ai_socktype.") -(defconstant eai_addrfamily -9 _N"Address family for NAME not supported.") -(defconstant eai_memory -10 _N"Memory allocation failure.") -(defconstant eai_system -11 _N"System error returned in errno.") - - -#+(or) -(defun unix-getaddrinfo (name service req pai) - _N"Translate name of a service location and/or a service name to set of - socket addresses." - (int-syscall ("getaddrinfo" c-string c-string (* (struct addrinfo)) - (* (* struct addrinfo))) - name service req pai)) - - -#+(or) -(defun unix-freeaddrinfo (ai) - _N"Free `addrinfo' structure AI including associated storage." - (void-syscall ("freeaddrinfo" (* struct addrinfo)) - ai)) - - -;;; pty.h - -(defun unix-openpty (name termp winp) - _N"Create pseudo tty master slave pair with NAME and set terminal - attributes according to TERMP and WINP and return handles for both - ends in AMASTER and ASLAVE." - (with-alien ((amaster int) - (aslave int)) - (values - (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios)) - (* (struct winsize))) - (addr amaster) (addr aslave) name termp winp) - amaster aslave))) - -#+(or) -(defun unix-forkpty (amaster name termp winp) - _N"Create child process and establish the slave pseudo terminal as the - child's controlling terminal." - (int-syscall ("forkpty" (* int) c-string (* (struct termios)) - (* (struct winsize))) - amaster name termp winp)) - - -;; POSIX Standard: 9.2.2 User Database Access <pwd.h> - -#+(or) -(defun unix-setpwent () - _N"Rewind the password-file stream." - (void-syscall ("setpwent"))) - -#+(or) -(defun unix-endpwent () - _N"Close the password-file stream." - (void-syscall ("endpwent"))) - -#+(or) -(defun unix-getpwent () - _N"Read an entry from the password-file stream, opening it if necessary." - (let ((result (alien-funcall (extern-alien "getpwent" - (function (* (struct passwd))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;;; resourcebits.h - -(def-alien-type nil - (struct rlimit - (rlim-cur long) ; current (soft) limit - (rlim-max long))); maximum value for rlim-cur - -(defconstant rusage_self 0 _N"The calling process.") -(defconstant rusage_children -1 _N"Terminated child processes.") -(defconstant rusage_both -2) - -(def-alien-type nil - (struct rusage - (ru-utime (struct timeval)) ; user time used - (ru-stime (struct timeval)) ; system time used. - (ru-maxrss long) ; Maximum resident set size (in kilobytes) - (ru-ixrss long) ; integral shared memory size - (ru-idrss long) ; integral unshared data " - (ru-isrss long) ; integral unshared stack " - (ru-minflt long) ; page reclaims - (ru-majflt long) ; page faults - (ru-nswap long) ; swaps - (ru-inblock long) ; block input operations - (ru-oublock long) ; block output operations - (ru-msgsnd long) ; messages sent - (ru-msgrcv long) ; messages received - (ru-nsignals long) ; signals received - (ru-nvcsw long) ; voluntary context switches - (ru-nivcsw long))) ; involuntary " - -;; Priority limits. - -(defconstant prio-min -20 _N"Minimum priority a process can have") -(defconstant prio-max 20 _N"Maximum priority a process can have") - - -;;; The type of the WHICH argument to `getpriority' and `setpriority', -;;; indicating what flavor of entity the WHO argument specifies. - -(defconstant priority-process 0 _N"WHO is a process ID") -(defconstant priority-pgrp 1 _N"WHO is a process group ID") -(defconstant priority-user 2 _N"WHO is a user ID") - -;;; sched.h - -#+(or) -(defun unix-sched_setparam (pid param) - _N"Rewind the password-file stream." - (int-syscall ("sched_setparam" pid-t (struct psched-param)) - pid param)) - -#+(or) -(defun unix-sched_getparam (pid param) - _N"Rewind the password-file stream." - (int-syscall ("sched_getparam" pid-t (struct psched-param)) - pid param)) - - -#+(or) -(defun unix-sched_setscheduler (pid policy param) - _N"Set scheduling algorithm and/or parameters for a process." - (int-syscall ("sched_setscheduler" pid-t int (struct psched-param)) - pid policy param)) - -#+(or) -(defun unix-sched_getscheduler (pid) - _N"Retrieve scheduling algorithm for a particular purpose." - (int-syscall ("sched_getscheduler" pid-t) - pid)) - -(defun unix-sched-yield () - _N"Retrieve scheduling algorithm for a particular purpose." - (int-syscall ("sched_yield"))) - -#+(or) -(defun unix-sched_get_priority_max (algorithm) - _N"Get maximum priority value for a scheduler." - (int-syscall ("sched_get_priority_max" int) - algorithm)) - -#+(or) -(defun unix-sched_get_priority_min (algorithm) - _N"Get minimum priority value for a scheduler." - (int-syscall ("sched_get_priority_min" int) - algorithm)) - - - -#+(or) -(defun unix-sched_rr_get_interval (pid t) - _N"Get the SCHED_RR interval for the named process." - (int-syscall ("sched_rr_get_interval" pid-t (* (struct timespec))) - pid t)) - -;;; schedbits.h - -(defconstant scheduler-other 0) -(defconstant scheduler-fifo 1) -(defconstant scheduler-rr 2) - - -;; Data structure to describe a process' schedulability. - -(def-alien-type nil - (struct sched_param - (sched-priority int))) - -;; Cloning flags. -(defconstant csignal #x000000ff _N"Signal mask to be sent at exit.") -(defconstant clone_vm #x00000100 _N"Set if VM shared between processes.") -(defconstant clone_fs #x00000200 _N"Set if fs info shared between processes") -(defconstant clone_files #x00000400 _N"Set if open files shared between processe") -(defconstant clone_sighand #x00000800 _N"Set if signal handlers shared.") -(defconstant clone_pid #x00001000 _N"Set if pid shared.") - - -;;; shadow.h - -;; Structure of the password file. - -(def-alien-type nil - (struct spwd - (sp-namp c-string) ; Login name. - (sp-pwdp c-string) ; Encrypted password. - (sp-lstchg long) ; Date of last change. - (sp-min long) ; Minimum number of days between changes. - (sp-max long) ; Maximum number of days between changes. - (sp-warn long) ; Number of days to warn user to change the password. - (sp-inact long) ; Number of days the account may be inactive. - (sp-expire long) ; Number of days since 1970-01-01 until account expires. - (sp-flags long))) ; Reserved. - -#+(or) -(defun unix-setspent () - _N"Open database for reading." - (void-syscall ("setspent"))) - -#+(or) -(defun unix-endspent () - _N"Close database." - (void-syscall ("endspent"))) - -#+(or) -(defun unix-getspent () - _N"Get next entry from database, perhaps after opening the file." - (let ((result (alien-funcall (extern-alien "getspent" - (function (* (struct spwd))))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-getspnam (name) - _N"Get shadow entry matching NAME." - (let ((result (alien-funcall (extern-alien "getspnam" - (function (* (struct spwd)) - c-string)) - name))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -#+(or) -(defun unix-sgetspent (string) - _N"Read shadow entry from STRING." - (let ((result (alien-funcall (extern-alien "sgetspent" - (function (* (struct spwd)) - c-string)) - string))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -;; - -#+(or) -(defun unix-lckpwdf () - _N"Protect password file against multi writers." - (void-syscall ("lckpwdf"))) - - -#+(or) -(defun unix-ulckpwdf () - _N"Unlock password file." - (void-syscall ("ulckpwdf"))) - -;;; bits/stat.h - -(def-alien-type nil - (struct stat - (st-dev dev-t) - #-(or alpha amd64) (st-pad1 unsigned-short) - (st-ino ino-t) - #+alpha (st-pad1 unsigned-int) - #-amd64 (st-mode mode-t) - (st-nlink nlink-t) - #+amd64 (st-mode mode-t) - (st-uid uid-t) - (st-gid gid-t) - (st-rdev dev-t) - #-alpha (st-pad2 unsigned-short) - (st-size off-t) - #-alpha (st-blksize unsigned-long) - #-alpha (st-blocks blkcnt-t) - (st-atime time-t) - #-alpha (unused-1 unsigned-long) - (st-mtime time-t) - #-alpha (unused-2 unsigned-long) - (st-ctime time-t) - #+alpha (st-blocks int) - #+alpha (st-pad2 unsigned-int) - #+alpha (st-blksize unsigned-int) - #+alpha (st-flags unsigned-int) - #+alpha (st-gen unsigned-int) - #+alpha (st-pad3 unsigned-int) - #+alpha (unused-1 unsigned-long) - #+alpha (unused-2 unsigned-long) - (unused-3 unsigned-long) - (unused-4 unsigned-long) - #-alpha (unused-5 unsigned-long))) - -;; Encoding of the file mode. - -(defconstant s-ifmt #o0170000 _N"These bits determine file type.") - -;; File types. +;; File types. (defconstant s-ififo #o0010000 _N"FIFO") (defconstant s-ifchr #o0020000 _N"Character device") @@ -1498,281 +726,30 @@ length LEN and type TYPE." (defconstant s-iflnk #o0120000 _N"Symbolic link.") (defconstant s-ifsock #o0140000 _N"Socket.") +(defun unix-file-kind (name &optional check-for-links) + _N"Returns either :file, :directory, :link, :special, or NIL." + (declare (simple-string name)) + (multiple-value-bind (res dev ino mode) + (if check-for-links + (unix-lstat name) + (unix-stat name)) + (declare (type (or fixnum null) mode) + (ignore dev ino)) + (when res + (let ((kind (logand mode s-ifmt))) + (cond ((eql kind s-ifdir) :directory) + ((eql kind s-ifreg) :file) + ((eql kind s-iflnk) :link) + (t :special)))))) -;; Protection bits. - -(defconstant s-isuid #o0004000 _N"Set user ID on execution.") -(defconstant s-isgid #o0002000 _N"Set group ID on execution.") -(defconstant s-isvtx #o0001000 _N"Save swapped text after use (sticky).") -(defconstant s-iread #o0000400 _N"Read by owner") -(defconstant s-iwrite #o0000200 _N"Write by owner.") -(defconstant s-iexec #o0000100 _N"Execute by owner.") - -;;; statfsbuf.h - -(def-alien-type nil - (struct statfs - (f-type int) - (f-bsize int) - (f-blocks fsblkcnt-t) - (f-bfree fsblkcnt-t) - (f-bavail fsblkcnt-t) - (f-files fsfilcnt-t) - (f-ffree fsfilcnt-t) - (f-fsid fsid-t) - (f-namelen int) - (f-spare (array int 6)))) - - -;;; termbits.h - -(def-alien-type cc-t unsigned-char) -(def-alien-type speed-t unsigned-int) -(def-alien-type tcflag-t unsigned-int) - -(defconstant +NCCS+ 32 - _N"Size of control character vector.") - -(def-alien-type nil - (struct termios - (c-iflag tcflag-t) - (c-oflag tcflag-t) - (c-cflag tcflag-t) - (c-lflag tcflag-t) - (c-line cc-t) - (c-cc (array cc-t #.+NCCS+)) - (c-ispeed speed-t) - (c-ospeed speed-t))) - -;; c_cc characters - -(def-enum + 0 vintr vquit verase - vkill veof vtime - vmin vswtc vstart - vstop vsusp veol - vreprint vdiscard vwerase - vlnext veol2) -(defvar vdsusp vsusp) - -(def-enum + 0 tciflush tcoflush tcioflush) - -(def-enum + 0 tcsanow tcsadrain tcsaflush) - -;; c_iflag bits -(def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck - tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc - tty-ixon tty-ixany tty-ixoff - tty-imaxbel) - -;; c_oflag bits -(def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr - tty-onlret tty-ofill tty-ofdel tty-nldly) - -(defconstant tty-nl0 0) -(defconstant tty-nl1 #o400) - -(defconstant tty-crdly #o0003000) -(defconstant tty-cr0 #o0000000) -(defconstant tty-cr1 #o0001000) -(defconstant tty-cr2 #o0002000) -(defconstant tty-cr3 #o0003000) -(defconstant tty-tabdly #o0014000) -(defconstant tty-tab0 #o0000000) -(defconstant tty-tab1 #o0004000) -(defconstant tty-tab2 #o0010000) -(defconstant tty-tab3 #o0014000) -(defconstant tty-xtabs #o0014000) -(defconstant tty-bsdly #o0020000) -(defconstant tty-bs0 #o0000000) -(defconstant tty-bs1 #o0020000) -(defconstant tty-vtdly #o0040000) -(defconstant tty-vt0 #o0000000) -(defconstant tty-vt1 #o0040000) -(defconstant tty-ffdly #o0100000) -(defconstant tty-ff0 #o0000000) -(defconstant tty-ff1 #o0100000) - -;; c-cflag bit meaning -(defconstant tty-cbaud #o0010017) -(defconstant tty-b0 #o0000000) ;; hang up -(defconstant tty-b50 #o0000001) -(defconstant tty-b75 #o0000002) -(defconstant tty-b110 #o0000003) -(defconstant tty-b134 #o0000004) -(defconstant tty-b150 #o0000005) -(defconstant tty-b200 #o0000006) -(defconstant tty-b300 #o0000007) -(defconstant tty-b600 #o0000010) -(defconstant tty-b1200 #o0000011) -(defconstant tty-b1800 #o0000012) -(defconstant tty-b2400 #o0000013) -(defconstant tty-b4800 #o0000014) -(defconstant tty-b9600 #o0000015) -(defconstant tty-b19200 #o0000016) -(defconstant tty-b38400 #o0000017) -(defconstant tty-exta tty-b19200) -(defconstant tty-extb tty-b38400) -(defconstant tty-csize #o0000060) -(defconstant tty-cs5 #o0000000) -(defconstant tty-cs6 #o0000020) -(defconstant tty-cs7 #o0000040) -(defconstant tty-cs8 #o0000060) -(defconstant tty-cstopb #o0000100) -(defconstant tty-cread #o0000200) -(defconstant tty-parenb #o0000400) -(defconstant tty-parodd #o0001000) -(defconstant tty-hupcl #o0002000) -(defconstant tty-clocal #o0004000) -(defconstant tty-cbaudex #o0010000) -(defconstant tty-b57600 #o0010001) -(defconstant tty-b115200 #o0010002) -(defconstant tty-b230400 #o0010003) -(defconstant tty-b460800 #o0010004) -(defconstant tty-cibaud #o002003600000) ; input baud rate (not used) -(defconstant tty-crtscts #o020000000000) ;flow control - -;; c_lflag bits -(def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe - tty-echok tty-echonl tty-noflsh - tty-tostop tty-echoctl tty-echoprt - tty-echoke tty-flusho - tty-pendin tty-iexten) - -;;; tcflow() and TCXONC use these -(def-enum + 0 tty-tcooff tty-tcoon tty-tcioff tty-tcion) - -;; tcflush() and TCFLSH use these */ -(def-enum + 0 tty-tciflush tty-tcoflush tty-tcioflush) - -;; tcsetattr uses these -(def-enum + 0 tty-tcsanow tty-tcsadrain tty-tcsaflush) - -;;; termios.h - -(defun unix-cfgetospeed (termios) - _N"Get terminal output speed." - (multiple-value-bind (speed errno) - (int-syscall ("cfgetospeed" (* (struct termios))) termios) - (if speed - (values (svref terminal-speeds speed) 0) - (values speed errno)))) - -(defun unix-cfsetospeed (termios speed) - _N"Set terminal output speed." - (let ((baud (or (position speed terminal-speeds) - (error _"Bogus baud rate ~S" speed)))) - (void-syscall ("cfsetospeed" (* (struct termios)) int) termios baud))) - -(defun unix-cfgetispeed (termios) - _N"Get terminal input speed." - (multiple-value-bind (speed errno) - (int-syscall ("cfgetispeed" (* (struct termios))) termios) - (if speed - (values (svref terminal-speeds speed) 0) - (values speed errno)))) - -(defun unix-cfsetispeed (termios speed) - _N"Set terminal input speed." - (let ((baud (or (position speed terminal-speeds) - (error _"Bogus baud rate ~S" speed)))) - (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud))) - -(defun unix-tcgetattr (fd termios) - _N"Get terminal attributes." - (declare (type unix-fd fd)) - (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) - -(defun unix-tcsetattr (fd opt termios) - _N"Set terminal attributes." - (declare (type unix-fd fd)) - (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios)) - -(defun unix-tcsendbreak (fd duration) - _N"Send break" - (declare (type unix-fd fd)) - (void-syscall ("tcsendbreak" int int) fd duration)) - -(defun unix-tcdrain (fd) - _N"Wait for output for finish" - (declare (type unix-fd fd)) - (void-syscall ("tcdrain" int) fd)) - -(defun unix-tcflush (fd selector) - _N"See tcflush(3)" - (declare (type unix-fd fd)) - (void-syscall ("tcflush" int int) fd selector)) - -(defun unix-tcflow (fd action) - _N"Flow control" - (declare (type unix-fd fd)) - (void-syscall ("tcflow" int int) fd action)) - -;;; timebits.h - -;; A time value that is accurate to the nearest -;; microsecond but also has a range of years. -(def-alien-type nil - (struct timeval - (tv-sec time-t) ; seconds - (tv-usec time-t))) ; and microseconds - -;;; unistd.h - -(defun sub-unix-execve (program arg-list env-list) - (let ((argv nil) - (argv-bytes 0) - (envp nil) - (envp-bytes 0) - result error-code) - (unwind-protect - (progn - ;; Blast the stuff into the proper format - (multiple-value-setq - (argv argv-bytes) - (string-list-to-c-strvec arg-list)) - (multiple-value-setq - (envp envp-bytes) - (string-list-to-c-strvec env-list)) - ;; - ;; Now do the system call - (multiple-value-setq - (result error-code) - (int-syscall ("execve" - c-string system-area-pointer system-area-pointer) - program argv envp))) - ;; - ;; Deallocate memory - (when argv - (system:deallocate-system-memory argv argv-bytes)) - (when envp - (system:deallocate-system-memory envp envp-bytes))) - (values result error-code))) - -;;;; UNIX-EXECVE - -(defun unix-execve (program &optional arg-list - (environment *environment-list*)) - _N"Executes the Unix execve system call. If the system call suceeds, lisp - will no longer be running in this process. If the system call fails this - function returns two values: NIL and an error code. Arg-list should be a - list of simple-strings which are passed as arguments to the exec'ed program. - Environment should be an a-list mapping symbols to simple-strings which this - function bashes together to form the environment for the exec'ed program." - (check-type program simple-string) - (let ((env-list (let ((envlist nil)) - (dolist (cons environment) - (push (if (cdr cons) - (concatenate 'simple-string - (string (car cons)) "=" - (cdr cons)) - (car cons)) - envlist)) - envlist))) - (sub-unix-execve (%name->file program) arg-list env-list))) - - -(defmacro round-bytes-to-words (n) - `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) +(defun unix-maybe-prepend-current-directory (name) + (declare (simple-string name)) + (if (and (> (length name) 0) (char= (schar name 0) #\/)) + name + (multiple-value-bind (win dir) (unix-current-directory) + (if win + (concatenate 'simple-string dir "/" name) + name)))) ;; Values for the second argument to access. @@ -1816,128 +793,182 @@ length LEN and type TYPE." (if (minusp result) (values nil (unix-errno)) (values result 0)))) +;;; Unix-close accepts a file descriptor and attempts to close the file +;;; associated with it. +(defun unix-close (fd) + _N"Unix-close takes an integer file descriptor as an argument and + closes the file associated with it. T is returned upon successful + completion, otherwise NIL and an error number." + (declare (type unix-fd fd)) + (void-syscall ("close" int) fd)) -;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. -;;; It attempts to read len bytes from the device associated with fd -;;; and store them into the buffer. It returns the actual number of -;;; bytes read. - -(defun unix-read (fd buf len) - _N"UNIX-READ attempts to read from the file described by fd into - the buffer buf until it is full. Len is the length of the buffer. - The number of bytes actually read is returned or NIL and an error - number if an error occured." - (declare (type unix-fd fd) - (type (unsigned-byte 32) len)) - #+gencgc - ;; With gencgc, the collector tries to keep raw objects like strings - ;; in separate pages that are not write-protected. However, this - ;; isn't always true. Thus, BUF will sometimes be write-protected - ;; and the kernel doesn't like writing to write-protected pages. So - ;; go through and touch each page to give the segv handler a chance - ;; to unprotect the pages. (This is taken from unix.lisp.) - (without-gcing - (let* ((page-size (get-page-size)) - (1-page-size (1- page-size)) - (sap (etypecase buf - (system-area-pointer buf) - (vector (vector-sap buf)))) - (end (sap+ sap len))) - (declare (type (and fixnum unsigned-byte) page-size 1-page-size) - (type system-area-pointer sap end) - (optimize (speed 3) (safety 0))) - ;; Touch the beginning of every page - (do ((sap (int-sap (logand (sap-int sap) - (logxor 1-page-size (ldb (byte 32 0) -1)))) - (sap+ sap page-size))) - ((sap>= sap end)) - (declare (type system-area-pointer sap)) - (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0))))) - (int-syscall ("read" int (* char) int) fd buf len)) - - -;;; Unix-write accepts a file descriptor, a buffer, an offset, and the -;;; length to write. It attempts to write len bytes to the device -;;; associated with fd from the the buffer starting at offset. It returns -;;; the actual number of bytes written. - -(defun unix-write (fd buf offset len) - _N"Unix-write attempts to write a character buffer (buf) of length - len to the file described by the file descriptor fd. NIL and an - error is returned if the call is unsuccessful." - (declare (type unix-fd fd) - (type (unsigned-byte 32) offset len)) - (int-syscall ("write" int (* char) int) - fd - (with-alien ((ptr (* char) (etypecase buf - ((simple-array * (*)) - (vector-sap buf)) - (system-area-pointer - buf)))) - (addr (deref ptr offset))) - len)) - -(defun unix-pipe () - _N"Unix-pipe sets up a unix-piping mechanism consisting of - an input pipe and an output pipe. Unix-Pipe returns two - values: if no error occurred the first value is the pipe - to be read from and the second is can be written to. If - an error occurred the first value is NIL and the second - the unix error code." - (with-alien ((fds (array int 2))) - (syscall ("pipe" (* int)) - (values (deref fds 0) (deref fds 1)) - (cast fds (* int))))) - - -(defun unix-chown (path uid gid) - _N"Given a file path, an integer user-id, and an integer group-id, - unix-chown changes the owner of the file and the group of the - file to those specified. Either the owner or the group may be - left unchanged by specifying them as -1. Note: Permission will - fail if the caller is not the superuser." - (declare (type unix-pathname path) - (type (or unix-uid (integer -1 -1)) uid) - (type (or unix-gid (integer -1 -1)) gid)) - (void-syscall ("chown" c-string int int) (%name->file path) uid gid)) - -;;; Unix-fchown is exactly the same as unix-chown except that the file -;;; is specified by a file-descriptor ("fd") instead of a pathname. - -(defun unix-fchown (fd uid gid) - _N"Unix-fchown is like unix-chown, except that it accepts an integer - file descriptor instead of a file path name." - (declare (type unix-fd fd) - (type (or unix-uid (integer -1 -1)) uid) - (type (or unix-gid (integer -1 -1)) gid)) - (void-syscall ("fchown" int int int) fd uid gid)) - -;;; Unix-chdir accepts a directory name and makes that the -;;; current working directory. - -(defun unix-chdir (path) - _N"Given a file path string, unix-chdir changes the current working - directory to the one specified." - (declare (type unix-pathname path)) - (void-syscall ("chdir" c-string) (%name->file path))) +(defun unix-resolve-links (pathname) + _N"Returns the pathname with all symbolic links resolved." + (declare (simple-string pathname)) + (let ((len (length pathname)) + (pending pathname)) + (declare (fixnum len) (simple-string pending)) + (if (zerop len) + pathname + (let ((result (make-string 100 :initial-element (code-char 0))) + (fill-ptr 0) + (name-start 0)) + (loop + (let* ((name-end (or (position #\/ pending :start name-start) len)) + (new-fill-ptr (+ fill-ptr (- name-end name-start)))) + ;; grow the result string, if necessary. the ">=" (instead of + ;; using ">") allows for the trailing "/" if we find this + ;; component is a directory. + (when (>= new-fill-ptr (length result)) + (let ((longer (make-string (* 3 (length result)) + :initial-element (code-char 0)))) + (replace longer result :end1 fill-ptr) + (setq result longer))) + (replace result pending + :start1 fill-ptr + :end1 new-fill-ptr + :start2 name-start + :end2 name-end) + (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t))) + (unless kind (return nil)) + (cond ((eq kind :link) + (multiple-value-bind (link err) (unix-readlink result) + (unless link + (error (intl:gettext "Error reading link ~S: ~S") + (subseq result 0 fill-ptr) + (get-unix-error-msg err))) + (cond ((or (zerop (length link)) + (char/= (schar link 0) #\/)) + ;; It's a relative link + (fill result (code-char 0) + :start fill-ptr + :end new-fill-ptr)) + ((string= result "/../" :end1 4) + ;; It's across the super-root. + (let ((slash (or (position #\/ result :start 4) + 0))) + (fill result (code-char 0) + :start slash + :end new-fill-ptr) + (setf fill-ptr slash))) + (t + ;; It's absolute. + (and (> (length link) 0) + (char= (schar link 0) #\/)) + (fill result (code-char 0) :end new-fill-ptr) + (setf fill-ptr 0))) + (setf pending + (if (= name-end len) + link + (concatenate 'simple-string + link + (subseq pending name-end)))) + (setf len (length pending)) + (setf name-start 0))) + ((= name-end len) + (when (eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (incf new-fill-ptr)) + (return (subseq result 0 new-fill-ptr))) + ((eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (setf fill-ptr (1+ new-fill-ptr)) + (setf name-start (1+ name-end))) + (t + (return nil)))))))))) -(defun unix-current-directory () - _N"Put the absolute pathname of the current working directory in BUF. - If successful, return BUF. If not, put an error message in - BUF and return NULL. BUF should be at least PATH_MAX bytes long." - ;; 5120 is some randomly selected maximum size for the buffer for getcwd. - (with-alien ((buf (array c-call:char 5120))) - (let ((result (alien-funcall - (extern-alien "getcwd" - (function (* c-call:char) - (* c-call:char) c-call:int)) - (cast buf (* c-call:char)) - 5120))) - - (values (not (zerop (sap-int (alien-sap result)))) - (%file->name (cast buf c-call:c-string)))))) +(defun unix-simplify-pathname (src) + (declare (simple-string src)) + (let* ((src-len (length src)) + (dst (make-string src-len)) + (dst-len 0) + (dots 0) + (last-slash nil)) + (macrolet ((deposit (char) + `(progn + (setf (schar dst dst-len) ,char) + (incf dst-len)))) + (dotimes (src-index src-len) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((char= char #\/) + (case dots + (0 + ;; Either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; Either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some random dir. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; Something other than a dot between slashes. + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len)))))) + (when (and last-slash (not (zerop last-slash))) + (case dots + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (char= (schar dst (- last-slash 3)) #\/))) + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from unix-simplify-pathname "./"))))))) + (cond ((zerop dst-len) + "./") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len))))) +(defun unix-gethostname () + _N"Unix-gethostname returns the name of the host machine as a string." + (with-alien ((buf (array char 256))) + (syscall* ("gethostname" (* char) int) + (cast buf c-string) + (cast buf (* char)) 256))) ;;; Unix-dup returns a duplicate copy of the existing file-descriptor ;;; passed as an argument. @@ -1963,8 +994,6 @@ length LEN and type TYPE." (declare (type unix-fd fd1 fd2)) (void-syscall ("dup2" int int) fd1 fd2)) -;;; Unix-exit terminates a program. - (defun unix-exit (&optional (code 0)) _N"Unix-exit terminates the current process with an optional error code. If successful, the call doesn't return. If @@ -1972,189 +1001,43 @@ length LEN and type TYPE." (declare (type (signed-byte 32) code)) (void-syscall ("exit" int) code)) -#+(or) -(defun unix-pathconf (path name) - _N"Get file-specific configuration information about PATH." - (int-syscall ("pathconf" c-string int) (%name->file path) name)) - -#+(or) -(defun unix-sysconf (name) - _N"Get the value of the system variable NAME." - (int-syscall ("sysconf" int) name)) - -#+(or) -(defun unix-confstr (name) - _N"Get the value of the string-valued system variable NAME." - (with-alien ((buf (array char 1024))) - (values (not (zerop (alien-funcall (extern-alien "confstr" - (function int - c-string - size-t)) - name buf 1024))) - (cast buf c-string)))) - +;;; Unix-chdir accepts a directory name and makes that the +;;; current working directory. -(def-alien-routine ("getpid" unix-getpid) int - _N"Unix-getpid returns the process-id of the current process.") +(defun unix-chdir (path) + _N"Given a file path string, unix-chdir changes the current working + directory to the one specified." + (declare (type unix-pathname path)) + (void-syscall ("chdir" c-string) (%name->file path))) -(def-alien-routine ("getppid" unix-getppid) int - _N"Unix-getppid returns the process-id of the parent of the current process.") - -;;; Unix-getpgrp returns the group-id associated with the -;;; current process. - -(defun unix-getpgrp () - _N"Unix-getpgrp returns the group-id of the calling process." - (int-syscall ("getpgrp"))) - -;;; Unix-setpgid sets the group-id of the process specified by -;;; "pid" to the value of "pgrp". The process must either have -;;; the same effective user-id or be a super-user process. - -;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained -;;; for backward compatibility. setpgrp(void)[solaris] is being phased -;;; out in favor of setsid(). - -(defun unix-setpgrp (pid pgrp) - _N"Unix-setpgrp sets the process group on the process pid to - pgrp. NIL and an error number are returned upon failure." - (void-syscall ("setpgid" int int) pid pgrp)) - -(defun unix-setpgid (pid pgrp) - _N"Unix-setpgid sets the process group of the process pid to - pgrp. If pgid is equal to pid, the process becomes a process - group leader. NIL and an error number are returned upon failure." - (void-syscall ("setpgid" int int) pid pgrp)) - -#+(or) -(defun unix-setsid () - _N"Create a new session with the calling process as its leader. - The process group IDs of the session and the calling process - are set to the process ID of the calling process, which is returned." - (void-syscall ( "setsid"))) - -#+(or) -(defun unix-getsid () - _N"Return the session ID of the given process." - (int-syscall ( "getsid"))) - -(def-alien-routine ("getuid" unix-getuid) int - _N"Unix-getuid returns the real user-id associated with the - current process.") - -#+(or) -(def-alien-routine ("geteuid" unix-getuid) int - _N"Get the effective user ID of the calling process.") - -(def-alien-routine ("getgid" unix-getgid) int - _N"Unix-getgid returns the real group-id of the current process.") - -(def-alien-routine ("getegid" unix-getegid) int - _N"Unix-getegid returns the effective group-id of the current process.") - -;/* If SIZE is zero, return the number of supplementary groups -; the calling process is in. Otherwise, fill in the group IDs -; of its supplementary groups in LIST and return the number written. */ -;extern int getgroups __P ((int __size, __gid_t __list[])); - -#+(or) -(defun unix-group-member (gid) - _N"Return nonzero iff the calling process is in group GID." - (int-syscall ( "group-member" gid-t) gid)) - - -(defun unix-setuid (uid) - _N"Set the user ID of the calling process to UID. - If the calling process is the super-user, set the real - and effective user IDs, and the saved set-user-ID to UID; - if not, the effective user ID is set to UID." - (int-syscall ("setuid" uid-t) uid)) - -;;; Unix-setreuid sets the real and effective user-id's of the current -;;; process to the arguments "ruid" and "euid", respectively. Usage is -;;; restricted for anyone but the super-user. Setting either "ruid" or -;;; "euid" to -1 makes the system use the current id instead. - -(defun unix-setreuid (ruid euid) - _N"Unix-setreuid sets the real and effective user-id's of the current - process to the specified ones. NIL and an error number is returned - if the call fails." - (void-syscall ("setreuid" int int) ruid euid)) - -(defun unix-setgid (gid) - _N"Set the group ID of the calling process to GID. - If the calling process is the super-user, set the real - and effective group IDs, and the saved set-group-ID to GID; - if not, the effective group ID is set to GID." - (int-syscall ("setgid" gid-t) gid)) - - -;;; Unix-setregid sets the real and effective group-id's of the current -;;; process to the arguments "rgid" and "egid", respectively. Usage is -;;; restricted for anyone but the super-user. Setting either "rgid" or -;;; "egid" to -1 makes the system use the current id instead. - -(defun unix-setregid (rgid egid) - _N"Unix-setregid sets the real and effective group-id's of the current - process process to the specified ones. NIL and an error number is - returned if the call fails." - (void-syscall ("setregid" int int) rgid egid)) - -(defun unix-fork () - _N"Executes the unix fork system call. Returns 0 in the child and the pid - of the child in the parent if it works, or NIL and an error number if it - doesn't work." - (int-syscall ("fork"))) - -;; Environment maninpulation; man getenv(3) -(def-alien-routine ("getenv" unix-getenv) c-call:c-string - (name c-call:c-string) - _N"Get the value of the environment variable named Name. If no such - variable exists, Nil is returned.") - -(def-alien-routine ("setenv" unix-setenv) c-call:int - (name c-call:c-string) - (value c-call:c-string) - (overwrite c-call:int) - _N"Adds the environment variable named Name to the environment with - the given Value if Name does not already exist. If Name does exist, - the value is changed to Value if Overwrite is non-zero. Otherwise, - the value is not changed.") - -(def-alien-routine ("putenv" unix-putenv) c-call:int - (name c-call:c-string) - _N"Adds or changes the environment. Name-value must be a string of - the form \"name=value\". If the name does not exist, it is added. - If name does exist, the value is updated to the given value.") - -(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int - (name c-call:c-string) - _N"Removes the variable Name from the environment") +;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode. -(def-alien-routine ("ttyname" unix-ttyname) c-string - (fd int)) +(defun unix-chmod (path mode) + _N"Given a file path string and a constant mode, unix-chmod changes the + permission mode for that file to the one specified. The new mode + can be created by logically OR'ing the following: -(def-alien-routine ("isatty" unix-isatty) boolean - _N"Accepts a Unix file descriptor and returns T if the device - associated with it is a terminal." - (fd int)) - -;;; Unix-link creates a hard link from name2 to name1. - -(defun unix-link (name1 name2) - _N"Unix-link creates a hard link from the file with name1 to the - file with name2." - (declare (type unix-pathname name1 name2)) - (void-syscall ("link" c-string c-string) - (%name->file name1) (%name->file name2))) + setuidexec Set user ID on execution. + setgidexec Set group ID on execution. + savetext Save text image after execution. + readown Read by owner. + writeown Write by owner. + execown Execute (search directory) by owner. + readgrp Read by group. + writegrp Write by group. + execgrp Execute (search directory) by group. + readoth Read by others. + writeoth Write by others. + execoth Execute (search directory) by others. -(defun unix-symlink (name1 name2) - _N"Unix-symlink creates a symbolic link named name2 to the file - named name1. NIL and an error number is returned if the call - is unsuccessful." - (declare (type unix-pathname name1 name2)) - (void-syscall ("symlink" c-string c-string) - (%name->file name1) (%name->file name2))) + Thus #o444 and (logior unix:readown unix:readgrp unix:readoth) + are equivalent for 'mode. The octal-base is familar to Unix users. + + It returns T on successfully completion; NIL and an error number + otherwise." + (declare (type unix-pathname path) + (type unix-file-mode mode)) + (void-syscall ("chmod" c-string int) (%name->file path) mode)) (defun unix-readlink (path) _N"Unix-readlink invokes the readlink system call on the file name @@ -2186,349 +1069,254 @@ length LEN and type TYPE." (declare (type unix-pathname name)) (void-syscall ("unlink" c-string) (%name->file name))) -;;; Unix-rmdir accepts a name and removes the associated directory. - -(defun unix-rmdir (name) - _N"Unix-rmdir attempts to remove the directory name. NIL and - an error number is returned if an error occured." - (declare (type unix-pathname name)) - (void-syscall ("rmdir" c-string) (%name->file name))) - -(defun tcgetpgrp (fd) - _N"Get the tty-process-group for the unix file-descriptor FD." - (alien:with-alien ((alien-pgrp c-call:int)) - (multiple-value-bind (ok err) - (unix-ioctl fd - tiocgpgrp - (alien:alien-sap (alien:addr alien-pgrp))) - (if ok - (values alien-pgrp nil) - (values nil err))))) - -(defun tty-process-group (&optional fd) - _N"Get the tty-process-group for the unix file-descriptor FD. If not supplied, - FD defaults to /dev/tty." - (if fd - (tcgetpgrp fd) - (multiple-value-bind (tty-fd errno) - (unix-open "/dev/tty" o_rdwr 0) - (cond (tty-fd - (multiple-value-prog1 - (tcgetpgrp tty-fd) - (unix-close tty-fd))) - (t - (values nil errno)))))) - -(defun tcsetpgrp (fd pgrp) - _N"Set the tty-process-group for the unix file-descriptor FD to PGRP." - (alien:with-alien ((alien-pgrp c-call:int pgrp)) - (unix-ioctl fd - tiocspgrp - (alien:alien-sap (alien:addr alien-pgrp))))) - -(defun %set-tty-process-group (pgrp &optional fd) - _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not - supplied, FD defaults to /dev/tty." - (let ((old-sigs - (unix-sigblock - (sigmask :sigttou :sigttin :sigtstp :sigchld)))) - (declare (type (unsigned-byte 32) old-sigs)) - (unwind-protect - (if fd - (tcsetpgrp fd pgrp) - (multiple-value-bind (tty-fd errno) - (unix-open "/dev/tty" o_rdwr 0) - (cond (tty-fd - (multiple-value-prog1 - (tcsetpgrp tty-fd pgrp) - (unix-close tty-fd))) - (t - (values nil errno))))) - (unix-sigsetmask old-sigs)))) - -(defsetf tty-process-group (&optional fd) (pgrp) - _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not - supplied, FD defaults to /dev/tty." - `(%set-tty-process-group ,pgrp ,fd)) - -#+(or) -(defun unix-getlogin () - _N"Return the login name of the user." - (let ((result (alien-funcall (extern-alien "getlogin" - (function c-string))))) - (declare (type system-area-pointer result)) - (if (zerop (sap-int result)) - nil - result))) - -(def-alien-type nil - (struct utsname - (sysname (array char 65)) - (nodename (array char 65)) - (release (array char 65)) - (version (array char 65)) - (machine (array char 65)) - (domainname (array char 65)))) - -(defun unix-uname () - _N"Unix-uname returns the name and information about the current kernel. The - values returned upon success are: sysname, nodename, release, version, - machine, and domainname. Upon failure, 'nil and the 'errno are returned." - (with-alien ((utsname (struct utsname))) - (syscall* ("uname" (* (struct utsname))) - (values (cast (slot utsname 'sysname) c-string) - (cast (slot utsname 'nodename) c-string) - (cast (slot utsname 'release) c-string) - (cast (slot utsname 'version) c-string) - (cast (slot utsname 'machine) c-string) - (cast (slot utsname 'domainname) c-string)) - (addr utsname)))) - -(defun unix-gethostname () - _N"Unix-gethostname returns the name of the host machine as a string." - (with-alien ((buf (array char 256))) - (syscall* ("gethostname" (* char) int) - (cast buf c-string) - (cast buf (* char)) 256))) +(defconstant r_ok 4 _N"Test for read permission") +(defconstant w_ok 2 _N"Test for write permission") +(defconstant x_ok 1 _N"Test for execute permission") +(defconstant f_ok 0 _N"Test for presence of file") -#+(or) -(defun unix-sethostname (name len) - (int-syscall ("sethostname" c-string size-t) name len)) +(defun unix-fcntl (fd cmd arg) + _N"Unix-fcntl manipulates file descriptors accoridng to the + argument CMD which can be one of the following: -#+(or) -(defun unix-sethostid (id) - (int-syscall ("sethostid" long) id)) + F-DUPFD Duplicate a file descriptor. + F-GETFD Get file descriptor flags. + F-SETFD Set file descriptor flags. + F-GETFL Get file flags. + F-SETFL Set file flags. + F-GETOWN Get owner. + F-SETOWN Set owner. -#+(or) -(defun unix-getdomainname (name len) - (int-syscall ("getdomainname" c-string size-t) name len)) + The flags that can be specified for F-SETFL are: -#+(or) -(defun unix-setdomainname (name len) - (int-syscall ("setdomainname" c-string size-t) name len)) + FNDELAY Non-blocking reads. + FAPPEND Append on each write. + FASYNC Signal pgrp when data ready. + FCREAT Create if nonexistant. + FTRUNC Truncate to zero length. + FEXCL Error if already created. + " + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd) + (type (unsigned-byte 32) arg)) + (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg)) -;;; Unix-fsync writes the core-image of the file described by "fd" to -;;; permanent storage (i.e. disk). +;;;; Memory-mapped files -(defun unix-fsync (fd) - _N"Unix-fsync writes the core image of the file described by - fd to disk." - (declare (type unix-fd fd)) - (void-syscall ("fsync" int) fd)) +(defconstant +null+ (sys:int-sap 0)) +(defconstant prot_read 1) +(defconstant prot_write 2) +(defconstant prot_exec 4) +(defconstant prot_none 0) -#+(or) -(defun unix-vhangup () - _N"Revoke access permissions to all processes currently communicating - with the control terminal, and then send a SIGHUP signal to the process - group of the control terminal." - (int-syscall ("vhangup"))) +;;; Unix-rename accepts two files names and renames the first to the second. -#+(or) -(defun unix-revoke (file) - _N"Revoke the access of all descriptors currently open on FILE." - (int-syscall ("revoke" c-string) (%name->file file))) +(defun unix-rename (name1 name2) + _N"Unix-rename renames the file with string name1 to the string + name2. NIL and an error code is returned if an error occured." + (declare (type unix-pathname name1 name2)) + (void-syscall ("rename" c-string c-string) + (%name->file name1) (%name->file name2))) +(def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int) -#+(or) -(defun unix-chroot (path) - _N"Make PATH be the root directory (the starting point for absolute paths). - This call is restricted to the super-user." - (int-syscall ("chroot" c-string) (%name->file path))) +(defconstant fd-setsize 1024) +(defconstant nfdbits 32) + +(def-alien-type nil + (struct fd-set + (fds-bits (array fd-mask #.(/ fd-setsize nfdbits))))) -(def-alien-routine ("gethostid" unix-gethostid) unsigned-long - _N"Unix-gethostid returns a 32-bit integer which provides unique - identification for the host machine.") +;; not checked for linux... +(defmacro fd-clr (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logand (deref (slot ,fd-set 'fds-bits) ,word) + (32bit-logical-not + (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) -;;; Unix-sync writes all information in core memory which has been modified -;;; to permanent storage (i.e. disk). +;; not checked for linux... +(defmacro fd-isset (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) -(defun unix-sync () - _N"Unix-sync writes all information in core memory which has been - modified to disk. It returns NIL and an error code if an error - occured." - (void-syscall ("sync"))) +;; not checked for linux... +(defmacro fd-set (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) + (deref (slot ,fd-set 'fds-bits) ,word)))))) -;;; Unix-getpagesize returns the number of bytes in the system page. +;; not checked for linux... +(defmacro fd-zero (fd-set) + `(progn + ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) -(defun unix-getpagesize () - _N"Unix-getpagesize returns the number of bytes in a system page." - (int-syscall ("getpagesize"))) +;;; TTY ioctl commands. -;;; Unix-truncate accepts a file name and a new length. The file is -;;; truncated to the new length. +(defconstant iocparm-mask #x3fff) +(defconstant ioc_void #x00000000) +(defconstant ioc_out #x40000000) +(defconstant ioc_in #x80000000) +(defconstant ioc_inout (logior ioc_in ioc_out)) -(defun unix-truncate (name length) - _N"Unix-truncate truncates the named file to the length (in - bytes) specified by LENGTH. NIL and an error number is returned - if the call is unsuccessful." - (declare (type unix-pathname name) - (type (unsigned-byte 64) length)) - (void-syscall ("truncate64" c-string off-t) (%name->file name) length)) +(defmacro define-ioctl-command (name dev cmd &optional arg parm-type) + _N"Define an ioctl command. If the optional ARG and PARM-TYPE are given + then ioctl argument size and direction are included as for ioctls defined + by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type + is the characters code, else DEV may be an integer giving the type." + (let* ((type (if (characterp dev) + (char-code dev) + dev)) + (code (logior (ash type 8) cmd))) + (when arg + (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask) + 16) + ,code))) + (when parm-type + (let ((dir (ecase parm-type + (:void ioc_void) + (:in ioc_in) + (:out ioc_out) + (:inout ioc_inout)))) + (setf code `(logior ,dir ,code)))) + `(eval-when (eval load compile) + (defconstant ,name ,code)))) -(defun unix-ftruncate (fd length) - _N"Unix-ftruncate is similar to unix-truncate except that the first - argument is a file descriptor rather than a file name." - (declare (type unix-fd fd) - (type (unsigned-byte 64) length)) - (void-syscall ("ftruncate64" int off-t) fd length)) +(define-ioctl-command TIOCGWINSZ #\T #x13) +(define-ioctl-command TIOCSWINSZ #\T #x14) +(define-ioctl-command TIOCNOTTY #\T #x22) +(define-ioctl-command TIOCSPGRP #\T #x10) +(define-ioctl-command TIOCGPGRP #\T #x0F) -#+(or) -(defun unix-getdtablesize () - _N"Return the maximum number of file descriptors - the current process could possibly have." - (int-syscall ("getdtablesize"))) +(defconstant f-getfl 3 _N"Get file flags") +(defconstant f-setfl 4 _N"Set file flags") -(defconstant f_ulock 0 _N"Unlock a locked region") -(defconstant f_lock 1 _N"Lock a region for exclusive use") -(defconstant f_tlock 2 _N"Test and lock a region for exclusive use") -(defconstant f_test 3 _N"Test a region for othwer processes locks") +;;; Define some more compatibility macros to be backward compatible with +;;; BSD systems which did not managed to hide these kernel macros. -(defun unix-lockf (fd cmd length) - _N"Unix-locks can lock, unlock and test files according to the cmd - which can be one of the following: +(defconstant FAPPEND o_append _N"depricated stuff") +(defconstant FFSYNC o_fsync _N"depricated stuff") +(defconstant FASYNC o_async _N"depricated stuff") +(defconstant FNONBLOCK o_nonblock _N"depricated stuff") +(defconstant FNDELAY o_ndelay _N"depricated stuff") - f_ulock Unlock a locked region - f_lock Lock a region for exclusive use - f_tlock Test and lock a region for exclusive use - f_test Test a region for othwer processes locks +(defun unix-mprotect (addr length prot) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length) + (type (integer 1 7) prot)) + (syscall ("mprotect" system-area-pointer size-t int) + t addr length prot)) + +;;;; Lisp types used by syscalls. - The lock is for a region from the current location for a length - of length. +(deftype unix-pathname () 'simple-string) +(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) - This is a simpler version of the interface provided by unix-fcntl. - " - (declare (type unix-fd fd) - (type (unsigned-byte 64) length) - (type (integer 0 3) cmd)) - (int-syscall ("lockf64" int int off-t) fd cmd length)) +(deftype unix-file-mode () '(unsigned-byte 32)) +(deftype unix-pid () '(unsigned-byte 32)) +(deftype unix-uid () '(unsigned-byte 32)) +(deftype unix-gid () '(unsigned-byte 32)) -;;; utime.h +;;; Operations on Unix Directories. -;; Structure describing file times. +;;; direntry.h (def-alien-type nil - (struct utimbuf - (actime time-t) ; Access time. - (modtime time-t))) ; Modification time. - -;;; Unix-utimes changes the accessed and updated times on UNIX -;;; files. The first argument is the filename (a string) and -;;; the second argument is a list of the 4 times- accessed and -;;; updated seconds and microseconds. - -(defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec) - _N"Unix-utimes sets the 'last-accessed' and 'last-updated' - times on a specified file. NIL and an error number is - returned if the call is unsuccessful." - (declare (type unix-pathname file) - (type (alien unsigned-long) - atime-sec atime-usec - mtime-sec mtime-usec)) - (with-alien ((tvp (array (struct timeval) 2))) - (setf (slot (deref tvp 0) 'tv-sec) atime-sec) - (setf (slot (deref tvp 0) 'tv-usec) atime-usec) - (setf (slot (deref tvp 1) 'tv-sec) mtime-sec) - (setf (slot (deref tvp 1) 'tv-usec) mtime-usec) - (void-syscall ("utimes" c-string (* (struct timeval))) - file - (cast tvp (* (struct timeval)))))) -;;; waitflags.h - -;; Bits in the third argument to `waitpid'. - -(defconstant waitpid-wnohang 1 _N"Don't block waiting.") -(defconstant waitpid-wuntranced 2 _N"Report status of stopped children.") - -(defconstant waitpid-wclone #x80000000 _N"Wait for cloned process.") - -;;; sys/ioctl.h - -(defun unix-ioctl (fd cmd arg) - _N"Unix-ioctl performs a variety of operations on open i/o - descriptors. See the UNIX Programmer's Manual for more - information." - (declare (type unix-fd fd) - (type (unsigned-byte 32) cmd)) - (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) - - -;;; sys/fsuid.h - -#+(or) -(defun unix-setfsuid (uid) - _N"Change uid used for file access control to UID, without affecting - other priveledges (such as who can send signals at the process)." - (int-syscall ("setfsuid" uid-t) uid)) + (struct dirent + #+glibc2.1 + (d-ino ino-t) ; inode number of entry + #-glibc2.1 + (d-ino ino64-t) ; inode number of entry + (d-off off-t) ; offset of next disk directory entry + (d-reclen unsigned-short) ; length of this record + (d_type unsigned-char) + (d-name (array char 256)))) ; name must be no longer than this -#+(or) -(defun unix-setfsgid (gid) - _N"Change gid used for file access control to GID, without affecting - other priveledges (such as who can send signals at the process)." - (int-syscall ("setfsgid" gid-t) gid)) +(export '(open-dir read-dir close-dir)) -;;; sys/poll.h +(defstruct (%directory + (:constructor make-directory) + (:conc-name directory-) + (:print-function %print-directory)) + name + (dir-struct (required-argument) :type system-area-pointer)) -;; Data structure describing a polling request. +(defun %print-directory (dir stream depth) + (declare (ignore depth)) + (format stream "#<Directory ~S>" (directory-name dir))) -(def-alien-type nil - (struct pollfd - (fd int) ; File descriptor to poll. - (events short) ; Types of events poller cares about. - (revents short))) ; Types of events that actually occurred. - -;; Event types that can be polled for. These bits may be set in `events' -;; to indicate the interesting event types; they will appear in `revents' -;; to indicate the status of the file descriptor. - -(defconstant POLLIN #o1 _N"There is data to read.") -(defconstant POLLPRI #o2 _N"There is urgent data to read.") -(defconstant POLLOUT #o4 _N"Writing now will not block.") - -;; Event types always implicitly polled for. These bits need not be set in -;;`events', but they will appear in `revents' to indicate the status of -;; the file descriptor. */ - - -(defconstant POLLERR #o10 _N"Error condition.") -(defconstant POLLHUP #o20 _N"Hung up.") -(defconstant POLLNVAL #o40 _N"Invalid polling request.") - - -(defconstant +npollfile+ 30 _N"Canonical number of polling requests to read -in at a time in poll.") - -#+(or) -(defun unix-poll (fds nfds timeout) - _N" Poll the file descriptors described by the NFDS structures starting at - FDS. If TIMEOUT is nonzero and not -1, allow TIMEOUT milliseconds for - an event to occur; if TIMEOUT is -1, block until an event occurs. - Returns the number of file descriptors with events, zero if timed out, - or -1 for errors." - (int-syscall ("poll" (* (struct pollfd)) long int) - fds nfds timeout)) - -;;; sys/resource.h - -(defun unix-getrlimit (resource) - _N"Get the soft and hard limits for RESOURCE." - (with-alien ((rlimits (struct rlimit))) - (syscall ("getrlimit" int (* (struct rlimit))) - (values t - (slot rlimits 'rlim-cur) - (slot rlimits 'rlim-max)) - resource (addr rlimits)))) - -(defun unix-setrlimit (resource current maximum) - _N"Set the current soft and hard maximum limits for RESOURCE. - Only the super-user can increase hard limits." - (with-alien ((rlimits (struct rlimit))) - (setf (slot rlimits 'rlim-cur) current) - (setf (slot rlimits 'rlim-max) maximum) - (void-syscall ("setrlimit" int (* (struct rlimit))) - resource (addr rlimits)))) +(defun open-dir (pathname) + (declare (type unix-pathname pathname)) + (when (string= pathname "") + (setf pathname ".")) + (let ((kind (unix-file-kind pathname))) + (case kind + (:directory + (let ((dir-struct + (alien-funcall (extern-alien "opendir" + (function system-area-pointer + c-string)) + (%name->file pathname)))) + (if (zerop (sap-int dir-struct)) + (values nil (unix-errno)) + (make-directory :name pathname :dir-struct dir-struct)))) + ((nil) + (values nil enoent)) + (t + (values nil enotdir))))) -(declaim (inline unix-fast-getrusage)) +(defun read-dir (dir) + (declare (type %directory dir)) + (let ((daddr (alien-funcall (extern-alien "readdir64" + (function system-area-pointer + system-area-pointer)) + (directory-dir-struct dir)))) + (declare (type system-area-pointer daddr)) + (if (zerop (sap-int daddr)) + nil + (with-alien ((dirent (* (struct dirent)) daddr)) + (values (%file->name (cast (slot dirent 'd-name) c-string)) + (slot dirent 'd-ino)))))) + +(defun close-dir (dir) + (declare (type %directory dir)) + (alien-funcall (extern-alien "closedir" + (function void system-area-pointer)) + (directory-dir-struct dir)) + nil) + +(defconstant rusage_self 0 _N"The calling process.") +(defconstant rusage_children -1 _N"Terminated child processes.") +(defconstant rusage_both -2) + +(def-alien-type nil + (struct rusage + (ru-utime (struct timeval)) ; user time used + (ru-stime (struct timeval)) ; system time used. + (ru-maxrss long) ; Maximum resident set size (in kilobytes) + (ru-ixrss long) ; integral shared memory size + (ru-idrss long) ; integral unshared data " + (ru-isrss long) ; integral unshared stack " + (ru-minflt long) ; page reclaims + (ru-majflt long) ; page faults + (ru-nswap long) ; swaps + (ru-inblock long) ; block input operations + (ru-oublock long) ; block output operations + (ru-msgsnd long) ; messages sent + (ru-msgrcv long) ; messages received + (ru-nsignals long) ; signals received + (ru-nvcsw long) ; voluntary context switches + (ru-nivcsw long))) + +(declaim (inline unix-fast-getrusage)) (defun unix-fast-getrusage (who) _N"Like call getrusage, but return only the system and user time, and returns the seconds and microseconds as separate values." @@ -2573,35 +1361,6 @@ in at a time in poll.") (slot usage 'ru-nivcsw)) who (addr usage)))) -#+(or) -(defun unix-ulimit (cmd newlimit) - _N"Function depends on CMD: - 1 = Return the limit on the size of a file, in units of 512 bytes. - 2 = Set the limit on the size of a file to NEWLIMIT. Only the - super-user can increase the limit. - 3 = Return the maximum possible address of the data segment. - 4 = Return the maximum number of files that the calling process can open. - Returns -1 on errors." - (int-syscall ("ulimit" int long) cmd newlimit)) - -#+(or) -(defun unix-getpriority (which who) - _N"Return the highest priority of any process specified by WHICH and WHO - (see above); if WHO is zero, the current process, process group, or user - (as specified by WHO) is used. A lower priority number means higher - priority. Priorities range from PRIO_MIN to PRIO_MAX (above)." - (int-syscall ("getpriority" int int) - which who)) - -#+(or) -(defun unix-setpriority (which who) - _N"Set the priority of all processes specified by WHICH and WHO (see above) - to PRIO. Returns 0 on success, -1 on errors." - (int-syscall ("setpriority" int int) - which who)) - -;;; sys/socket.h - ;;;; Socket support. ;;; Looks a bit naked. @@ -2727,981 +1486,60 @@ in at a time in poll.") collect `(setf (deref (slot ,fdset 'fds-bits) ,index) (ldb (byte nfdbits ,(* index nfdbits)) ,num)))))) -(defmacro fd-set-to-num (nfds fdset) - `(if (<= ,nfds nfdbits) - (deref (slot ,fdset 'fds-bits) 0) - (+ ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) - collect `(ash (deref (slot ,fdset 'fds-bits) ,index) - ,(* index nfdbits)))))) - -(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) - _N"Unix-select examines the sets of descriptors passed as arguments - to see if they are ready for reading and writing. See the UNIX - Programmers Manual for more information." - (declare (type (integer 0 #.FD-SETSIZE) nfds) - (type unsigned-byte rdfds wrfds xpfds) - (type (or (unsigned-byte 31) null) to-secs) - (type (unsigned-byte 31) to-usecs) - (optimize (speed 3) (safety 0) (inhibit-warnings 3))) - (with-alien ((tv (struct timeval)) - (rdf (struct fd-set)) - (wrf (struct fd-set)) - (xpf (struct fd-set))) - (when to-secs - (setf (slot tv 'tv-sec) to-secs) - (setf (slot tv 'tv-usec) to-usecs)) - (num-to-fd-set rdf rdfds) - (num-to-fd-set wrf wrfds) - (num-to-fd-set xpf xpfds) - (macrolet ((frob (lispvar alienvar) - `(if (zerop ,lispvar) - (int-sap 0) - (alien-sap (addr ,alienvar))))) - (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) - (values result - (fd-set-to-num nfds rdf) - (fd-set-to-num nfds wrf) - (fd-set-to-num nfds xpf)) - nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) - (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) - -;;; sys/stat.h - -(defmacro extract-stat-results (buf) - `(values T - #+(or alpha amd64) - (slot ,buf 'st-dev) - #-(or alpha amd64) - (+ (deref (slot ,buf 'st-dev) 0) - (* (+ +max-u-long+ 1) - (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works.. - (slot ,buf 'st-ino) - (slot ,buf 'st-mode) - (slot ,buf 'st-nlink) - (slot ,buf 'st-uid) - (slot ,buf 'st-gid) - #+(or alpha amd64) - (slot ,buf 'st-rdev) - #-(or alpha amd64) - (+ (deref (slot ,buf 'st-rdev) 0) - (* (+ +max-u-long+ 1) - (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works.. - (slot ,buf 'st-size) - (slot ,buf 'st-atime) - (slot ,buf 'st-mtime) - (slot ,buf 'st-ctime) - (slot ,buf 'st-blksize) - (slot ,buf 'st-blocks))) - -(defun unix-stat (name) - _N"UNIX-STAT retrieves information about the specified - file returning them in the form of multiple values. - See the UNIX Programmer's Manual for a description - of the values returned. If the call fails, then NIL - and an error number is returned instead." - (declare (type unix-pathname name)) - (when (string= name "") - (setf name ".")) - (with-alien ((buf (struct stat))) - (syscall ("stat64" c-string (* (struct stat))) - (extract-stat-results buf) - (%name->file name) (addr buf)))) - -(defun unix-fstat (fd) - _N"UNIX-FSTAT is similar to UNIX-STAT except the file is specified - by the file descriptor FD." - (declare (type unix-fd fd)) - (with-alien ((buf (struct stat))) - (syscall ("fstat64" int (* (struct stat))) - (extract-stat-results buf) - fd (addr buf)))) - -(defun unix-lstat (name) - _N"UNIX-LSTAT is similar to UNIX-STAT except the specified - file must be a symbolic link." - (declare (type unix-pathname name)) - (with-alien ((buf (struct stat))) - (syscall ("lstat64" c-string (* (struct stat))) - (extract-stat-results buf) - (%name->file name) (addr buf)))) - -;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode. - -(defun unix-chmod (path mode) - _N"Given a file path string and a constant mode, unix-chmod changes the - permission mode for that file to the one specified. The new mode - can be created by logically OR'ing the following: - - setuidexec Set user ID on execution. - setgidexec Set group ID on execution. - savetext Save text image after execution. - readown Read by owner. - writeown Write by owner. - execown Execute (search directory) by owner. - readgrp Read by group. - writegrp Write by group. - execgrp Execute (search directory) by group. - readoth Read by others. - writeoth Write by others. - execoth Execute (search directory) by others. - - Thus #o444 and (logior unix:readown unix:readgrp unix:readoth) - are equivalent for 'mode. The octal-base is familar to Unix users. - - It returns T on successfully completion; NIL and an error number - otherwise." - (declare (type unix-pathname path) - (type unix-file-mode mode)) - (void-syscall ("chmod" c-string int) (%name->file path) mode)) - -;;; Unix-fchmod accepts a file descriptor ("fd") and a file protection mode -;;; ("mode") and changes the protection of the file described by "fd" to -;;; "mode". - -(defun unix-fchmod (fd mode) - _N"Given an integer file descriptor and a mode (the same as those - used for unix-chmod), unix-fchmod changes the permission mode - for that file to the one specified. T is returned if the call - was successful." - (declare (type unix-fd fd) - (type unix-file-mode mode)) - (void-syscall ("fchmod" int int) fd mode)) - - -(defun unix-umask (mask) - _N"Set the file creation mask of the current process to MASK, - and return the old creation mask." - (int-syscall ("umask" mode-t) mask)) - -;;; Unix-mkdir accepts a name and a mode and attempts to create the -;;; corresponding directory with mode mode. - -(defun unix-mkdir (name mode) - _N"Unix-mkdir creates a new directory with the specified name and mode. - (Same as those for unix-chmod.) It returns T upon success, otherwise - NIL and an error number." - (declare (type unix-pathname name) - (type unix-file-mode mode)) - (void-syscall ("mkdir" c-string int) (%name->file name) mode)) - -#+(or) -(defun unix-makedev (path mode dev) - _N"Create a device file named PATH, with permission and special bits MODE - and device number DEV (which can be constructed from major and minor - device numbers with the `makedev' macro above)." - (declare (type unix-pathname path) - (type unix-file-mode mode)) - (void-syscall ("makedev" c-string mode-t dev-t) (%name->file name) mode dev)) - - -#+(or) -(defun unix-fifo (name mode) - _N"Create a new FIFO named PATH, with permission bits MODE." - (declare (type unix-pathname name) - (type unix-file-mode mode)) - (void-syscall ("mkfifo" c-string int) (%name->file name) mode)) - -;;; sys/statfs.h - -#+(or) -(defun unix-statfs (file buf) - _N"Return information about the filesystem on which FILE resides." - (int-syscall ("statfs64" c-string (* (struct statfs))) - (%name->file file) buf)) - -;;; sys/swap.h - -#+(or) -(defun unix-swapon (path flags) - _N"Make the block special device PATH available to the system for swapping. - This call is restricted to the super-user." - (int-syscall ("swapon" c-string int) (%name->file path) flags)) - -#+(or) -(defun unix-swapoff (path) - _N"Make the block special device PATH unavailable to the system for swapping. - This call is restricted to the super-user." - (int-syscall ("swapoff" c-string) (%name->file path))) - -;;; sys/sysctl.h - -#+(or) -(defun unix-sysctl (name nlen oldval oldlenp newval newlen) - _N"Read or write system parameters." - (int-syscall ("sysctl" int int (* void) (* void) (* void) size-t) - name nlen oldval oldlenp newval newlen)) - -;;; time.h - -;; POSIX.4 structure for a time value. This is like a `struct timeval' but -;; has nanoseconds instead of microseconds. - -(def-alien-type nil - (struct timespec - (tv-sec long) ;Seconds - (tv-nsec long))) ;Nanoseconds - -;; Used by other time functions. - -(def-alien-type nil - (struct tm - (tm-sec int) ; Seconds. [0-60] (1 leap second) - (tm-min int) ; Minutes. [0-59] - (tm-hour int) ; Hours. [0-23] - (tm-mday int) ; Day. [1-31] - (tm-mon int) ; Month. [0-11] - (tm-year int) ; Year - 1900. - (tm-wday int) ; Day of week. [0-6] - (tm-yday int) ; Days in year.[0-365] - (tm-isdst int) ; DST. [-1/0/1] - (tm-gmtoff long) ; Seconds east of UTC. - (tm-zone c-string))) ; Timezone abbreviation. - -#+(or) -(defun unix-clock () - _N"Time used by the program so far (user time + system time). - The result / CLOCKS_PER_SECOND is program time in seconds." - (int-syscall ("clock"))) - -#+(or) -(defun unix-time (timer) - _N"Return the current time and put it in *TIMER if TIMER is not NULL." - (int-syscall ("time" time-t) timer)) - -;; Requires call to tzset() in main. - -(def-alien-variable ("daylight" unix-daylight) int) -(def-alien-variable ("timezone" unix-timezone) time-t) -;(def-alien-variable ("altzone" unix-altzone) time-t) doesn't exist -(def-alien-variable ("tzname" unix-tzname) (array c-string 2)) - -(def-alien-routine get-timezone c-call:void - (when c-call:long :in) - (minutes-west c-call:int :out) - (daylight-savings-p alien:boolean :out)) - -(defun unix-get-minutes-west (secs) - (multiple-value-bind (ignore minutes dst) (get-timezone secs) - (declare (ignore ignore) (ignore dst)) - (values minutes))) - -(defun unix-get-timezone (secs) - (multiple-value-bind (ignore minutes dst) (get-timezone secs) - (declare (ignore ignore) (ignore minutes)) - (values (deref unix-tzname (if dst 1 0))))) - -;;; sys/time.h - -;; Structure crudely representing a timezone. -;; This is obsolete and should never be used. -(def-alien-type nil - (struct timezone - (tz-minuteswest int) ; minutes west of Greenwich - (tz-dsttime int))) ; type of dst correction - - -(declaim (inline unix-gettimeofday)) -(defun unix-gettimeofday () - _N"If it works, unix-gettimeofday returns 5 values: T, the seconds and - microseconds of the current time of day, the timezone (in minutes west - of Greenwich), and a daylight-savings flag. If it doesn't work, it - returns NIL and the errno." - (with-alien ((tv (struct timeval)) - (tz (struct timezone))) - (syscall* ("gettimeofday" (* (struct timeval)) - (* (struct timezone))) - (values T - (slot tv 'tv-sec) - (slot tv 'tv-usec) - (slot tz 'tz-minuteswest) - (slot tz 'tz-dsttime)) - (addr tv) - (addr tz)))) - - -;/* Set the current time of day and timezone information. -; This call is restricted to the super-user. */ -;extern int __settimeofday __P ((__const struct timeval *__tv, -; __const struct timezone *__tz)); -;extern int settimeofday __P ((__const struct timeval *__tv, -; __const struct timezone *__tz)); - -;/* Adjust the current time of day by the amount in DELTA. -; If OLDDELTA is not NULL, it is filled in with the amount -; of time adjustment remaining to be done from the last `adjtime' call. -; This call is restricted to the super-user. */ -;extern int __adjtime __P ((__const struct timeval *__delta, -; struct timeval *__olddelta)); -;extern int adjtime __P ((__const struct timeval *__delta, -; struct timeval *__olddelta)); - - -;; Type of the second argument to `getitimer' and -;; the second and third arguments `setitimer'. -(def-alien-type nil - (struct itimerval - (it-interval (struct timeval)) ; timer interval - (it-value (struct timeval)))) ; current value - -(defconstant ITIMER-REAL 0) -(defconstant ITIMER-VIRTUAL 1) -(defconstant ITIMER-PROF 2) - -(defun unix-getitimer (which) - _N"Unix-getitimer returns the INTERVAL and VALUE slots of one of - three system timers (:real :virtual or :profile). On success, - unix-getitimer returns 5 values, - T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." - (declare (type (member :real :virtual :profile) which) - (values t - (unsigned-byte 29)(mod 1000000) - (unsigned-byte 29)(mod 1000000))) - (let ((which (ecase which - (:real ITIMER-REAL) - (:virtual ITIMER-VIRTUAL) - (:profile ITIMER-PROF)))) - (with-alien ((itv (struct itimerval))) - (syscall* ("getitimer" int (* (struct itimerval))) - (values T - (slot (slot itv 'it-interval) 'tv-sec) - (slot (slot itv 'it-interval) 'tv-usec) - (slot (slot itv 'it-value) 'tv-sec) - (slot (slot itv 'it-value) 'tv-usec)) - which (alien-sap (addr itv)))))) - -(defun unix-setitimer (which int-secs int-usec val-secs val-usec) - _N" Unix-setitimer sets the INTERVAL and VALUE slots of one of - three system timers (:real :virtual or :profile). A SIGALRM signal - will be delivered VALUE <seconds+microseconds> from now. INTERVAL, - when non-zero, is <seconds+microseconds> to be loaded each time - the timer expires. Setting INTERVAL and VALUE to zero disables - the timer. See the Unix man page for more details. On success, - unix-setitimer returns the old contents of the INTERVAL and VALUE - slots as in unix-getitimer." - (declare (type (member :real :virtual :profile) which) - (type (unsigned-byte 29) int-secs val-secs) - (type (integer 0 (1000000)) int-usec val-usec) - (values t - (unsigned-byte 29)(mod 1000000) - (unsigned-byte 29)(mod 1000000))) - (let ((which (ecase which - (:real ITIMER-REAL) - (:virtual ITIMER-VIRTUAL) - (:profile ITIMER-PROF)))) - (with-alien ((itvn (struct itimerval)) - (itvo (struct itimerval))) - (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs - (slot (slot itvn 'it-interval) 'tv-usec) int-usec - (slot (slot itvn 'it-value ) 'tv-sec ) val-secs - (slot (slot itvn 'it-value ) 'tv-usec) val-usec) - (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) - (values T - (slot (slot itvo 'it-interval) 'tv-sec) - (slot (slot itvo 'it-interval) 'tv-usec) - (slot (slot itvo 'it-value) 'tv-sec) - (slot (slot itvo 'it-value) 'tv-usec)) - which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) - -;;; sys/timeb.h - -;; Structure returned by the `ftime' function. - -(def-alien-type nil - (struct timeb - (time time-t) ; Seconds since epoch, as from `time'. - (millitm short) ; Additional milliseconds. - (timezone int) ; Minutes west of GMT. - (dstflag short))) ; Nonzero if Daylight Savings Time used. - -#+(or) -(defun unix-fstime (timebuf) - _N"Fill in TIMEBUF with information about the current time." - (int-syscall ("ftime" (* (struct timeb))) timebuf)) - - -;;; sys/times.h - -;; Structure describing CPU time used by a process and its children. - -(def-alien-type nil - (struct tms - (tms-utime clock-t) ; User CPU time. - (tms-stime clock-t) ; System CPU time. - (tms-cutime clock-t) ; User CPU time of dead children. - (tms-cstime clock-t))) ; System CPU time of dead children. - -#+(or) -(defun unix-times (buffer) - _N"Store the CPU time used by this process and all its - dead children (and their dead children) in BUFFER. - Return the elapsed real time, or (clock_t) -1 for errors. - All times are in CLK_TCKths of a second." - (int-syscall ("times" (* (struct tms))) buffer)) - -;;; sys/wait.h - -#+(or) -(defun unix-wait (status) - _N"Wait for a child to die. When one does, put its status in *STAT_LOC - and return its process ID. For errors, return (pid_t) -1." - (int-syscall ("wait" (* int)) status)) - -#+(or) -(defun unix-waitpid (pid status options) - _N"Wait for a child matching PID to die. - If PID is greater than 0, match any process whose process ID is PID. - If PID is (pid_t) -1, match any process. - If PID is (pid_t) 0, match any process with the - same process group as the current process. - If PID is less than -1, match any process whose - process group is the absolute value of PID. - If the WNOHANG bit is set in OPTIONS, and that child - is not already dead, return (pid_t) 0. If successful, - return PID and store the dead child's status in STAT_LOC. - Return (pid_t) -1 for errors. If the WUNTRACED bit is - set in OPTIONS, return status for stopped children; otherwise don't." - (int-syscall ("waitpit" pid-t (* int) int) - pid status options)) - -;;; asm/errno.h - -(def-unix-error ESUCCESS 0 _N"Successful") -(def-unix-error EPERM 1 _N"Operation not permitted") -(def-unix-error ENOENT 2 _N"No such file or directory") -(def-unix-error ESRCH 3 _N"No such process") -(def-unix-error EINTR 4 _N"Interrupted system call") -(def-unix-error EIO 5 _N"I/O error") -(def-unix-error ENXIO 6 _N"No such device or address") -(def-unix-error E2BIG 7 _N"Arg list too long") -(def-unix-error ENOEXEC 8 _N"Exec format error") -(def-unix-error EBADF 9 _N"Bad file number") -(def-unix-error ECHILD 10 _N"No children") -(def-unix-error EAGAIN 11 _N"Try again") -(def-unix-error ENOMEM 12 _N"Out of memory") -(def-unix-error EACCES 13 _N"Permission denied") -(def-unix-error EFAULT 14 _N"Bad address") -(def-unix-error ENOTBLK 15 _N"Block device required") -(def-unix-error EBUSY 16 _N"Device or resource busy") -(def-unix-error EEXIST 17 _N"File exists") -(def-unix-error EXDEV 18 _N"Cross-device link") -(def-unix-error ENODEV 19 _N"No such device") -(def-unix-error ENOTDIR 20 _N"Not a director") -(def-unix-error EISDIR 21 _N"Is a directory") -(def-unix-error EINVAL 22 _N"Invalid argument") -(def-unix-error ENFILE 23 _N"File table overflow") -(def-unix-error EMFILE 24 _N"Too many open files") -(def-unix-error ENOTTY 25 _N"Not a typewriter") -(def-unix-error ETXTBSY 26 _N"Text file busy") -(def-unix-error EFBIG 27 _N"File too large") -(def-unix-error ENOSPC 28 _N"No space left on device") -(def-unix-error ESPIPE 29 _N"Illegal seek") -(def-unix-error EROFS 30 _N"Read-only file system") -(def-unix-error EMLINK 31 _N"Too many links") -(def-unix-error EPIPE 32 _N"Broken pipe") -;;; -;;; Math -(def-unix-error EDOM 33 _N"Math argument out of domain") -(def-unix-error ERANGE 34 _N"Math result not representable") -;;; -(def-unix-error EDEADLK 35 _N"Resource deadlock would occur") -(def-unix-error ENAMETOOLONG 36 _N"File name too long") -(def-unix-error ENOLCK 37 _N"No record locks available") -(def-unix-error ENOSYS 38 _N"Function not implemented") -(def-unix-error ENOTEMPTY 39 _N"Directory not empty") -(def-unix-error ELOOP 40 _N"Too many symbolic links encountered") -(def-unix-error EWOULDBLOCK 11 _N"Operation would block") -(def-unix-error ENOMSG 42 _N"No message of desired type") -(def-unix-error EIDRM 43 _N"Identifier removed") -(def-unix-error ECHRNG 44 _N"Channel number out of range") -(def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized") -(def-unix-error EL3HLT 46 _N"Level 3 halted") -(def-unix-error EL3RST 47 _N"Level 3 reset") -(def-unix-error ELNRNG 48 _N"Link number out of range") -(def-unix-error EUNATCH 49 _N"Protocol driver not attached") -(def-unix-error ENOCSI 50 _N"No CSI structure available") -(def-unix-error EL2HLT 51 _N"Level 2 halted") -(def-unix-error EBADE 52 _N"Invalid exchange") -(def-unix-error EBADR 53 _N"Invalid request descriptor") -(def-unix-error EXFULL 54 _N"Exchange full") -(def-unix-error ENOANO 55 _N"No anode") -(def-unix-error EBADRQC 56 _N"Invalid request code") -(def-unix-error EBADSLT 57 _N"Invalid slot") -(def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error") -(def-unix-error EBFONT 59 _N"Bad font file format") -(def-unix-error ENOSTR 60 _N"Device not a stream") -(def-unix-error ENODATA 61 _N"No data available") -(def-unix-error ETIME 62 _N"Timer expired") -(def-unix-error ENOSR 63 _N"Out of streams resources") -(def-unix-error ENONET 64 _N"Machine is not on the network") -(def-unix-error ENOPKG 65 _N"Package not installed") -(def-unix-error EREMOTE 66 _N"Object is remote") -(def-unix-error ENOLINK 67 _N"Link has been severed") -(def-unix-error EADV 68 _N"Advertise error") -(def-unix-error ESRMNT 69 _N"Srmount error") -(def-unix-error ECOMM 70 _N"Communication error on send") -(def-unix-error EPROTO 71 _N"Protocol error") -(def-unix-error EMULTIHOP 72 _N"Multihop attempted") -(def-unix-error EDOTDOT 73 _N"RFS specific error") -(def-unix-error EBADMSG 74 _N"Not a data message") -(def-unix-error EOVERFLOW 75 _N"Value too large for defined data type") -(def-unix-error ENOTUNIQ 76 _N"Name not unique on network") -(def-unix-error EBADFD 77 _N"File descriptor in bad state") -(def-unix-error EREMCHG 78 _N"Remote address changed") -(def-unix-error ELIBACC 79 _N"Can not access a needed shared library") -(def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library") -(def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted") -(def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries") -(def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly") -(def-unix-error EILSEQ 84 _N"Illegal byte sequence") -(def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N") -(def-unix-error ESTRPIPE 86 _N"Streams pipe error") -(def-unix-error EUSERS 87 _N"Too many users") -(def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket") -(def-unix-error EDESTADDRREQ 89 _N"Destination address required") -(def-unix-error EMSGSIZE 90 _N"Message too long") -(def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket") -(def-unix-error ENOPROTOOPT 92 _N"Protocol not available") -(def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported") -(def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported") -(def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint") -(def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported") -(def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol") -(def-unix-error EADDRINUSE 98 _N"Address already in use") -(def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address") -(def-unix-error ENETDOWN 100 _N"Network is down") -(def-unix-error ENETUNREACH 101 _N"Network is unreachable") -(def-unix-error ENETRESET 102 _N"Network dropped connection because of reset") -(def-unix-error ECONNABORTED 103 _N"Software caused connection abort") -(def-unix-error ECONNRESET 104 _N"Connection reset by peer") -(def-unix-error ENOBUFS 105 _N"No buffer space available") -(def-unix-error EISCONN 106 _N"Transport endpoint is already connected") -(def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected") -(def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown") -(def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice") -(def-unix-error ETIMEDOUT 110 _N"Connection timed out") -(def-unix-error ECONNREFUSED 111 _N"Connection refused") -(def-unix-error EHOSTDOWN 112 _N"Host is down") -(def-unix-error EHOSTUNREACH 113 _N"No route to host") -(def-unix-error EALREADY 114 _N"Operation already in progress") -(def-unix-error EINPROGRESS 115 _N"Operation now in progress") -(def-unix-error ESTALE 116 _N"Stale NFS file handle") -(def-unix-error EUCLEAN 117 _N"Structure needs cleaning") -(def-unix-error ENOTNAM 118 _N"Not a XENIX named type file") -(def-unix-error ENAVAIL 119 _N"No XENIX semaphores available") -(def-unix-error EISNAM 120 _N"Is a named type file") -(def-unix-error EREMOTEIO 121 _N"Remote I/O error") -(def-unix-error EDQUOT 122 _N"Quota exceeded") - -;;; And now for something completely different ... -(emit-unix-errors) - -;;; the ioctl's. -;;; -;;; I've deleted all the stuff that wasn't in the header files. -;;; This is what survived. - -;; 0x54 is just a magic number to make these relatively unique ('T') - -(eval-when (compile load eval) - -(defconstant iocparm-mask #x3fff) -(defconstant ioc_void #x00000000) -(defconstant ioc_out #x40000000) -(defconstant ioc_in #x80000000) -(defconstant ioc_inout (logior ioc_in ioc_out)) - -(defmacro define-ioctl-command (name dev cmd &optional arg parm-type) - _N"Define an ioctl command. If the optional ARG and PARM-TYPE are given - then ioctl argument size and direction are included as for ioctls defined - by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type - is the characters code, else DEV may be an integer giving the type." - (let* ((type (if (characterp dev) - (char-code dev) - dev)) - (code (logior (ash type 8) cmd))) - (when arg - (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask) - 16) - ,code))) - (when parm-type - (let ((dir (ecase parm-type - (:void ioc_void) - (:in ioc_in) - (:out ioc_out) - (:inout ioc_inout)))) - (setf code `(logior ,dir ,code)))) - `(eval-when (eval load compile) - (defconstant ,name ,code)))) - -) - -;;; TTY ioctl commands. - -(define-ioctl-command TIOCGWINSZ #\T #x13) -(define-ioctl-command TIOCSWINSZ #\T #x14) -(define-ioctl-command TIOCNOTTY #\T #x22) -(define-ioctl-command TIOCSPGRP #\T #x10) -(define-ioctl-command TIOCGPGRP #\T #x0F) - -;;; File ioctl commands. -(define-ioctl-command FIONREAD #\T #x1B) - -;;; asm/sockios.h - -;;; Socket options. - -(define-ioctl-command SIOCSPGRP #x89 #x02) - -(defun siocspgrp (fd pgrp) - _N"Set the socket process-group for the unix file-descriptor FD to PGRP." - (alien:with-alien ((alien-pgrp c-call:int pgrp)) - (unix-ioctl fd - siocspgrp - (alien:alien-sap (alien:addr alien-pgrp))))) - -;;; A few random constants and functions - -(defconstant setuidexec #o4000 _N"Set user ID on execution") -(defconstant setgidexec #o2000 _N"Set group ID on execution") -(defconstant savetext #o1000 _N"Save text image after execution") -(defconstant readown #o400 _N"Read by owner") -(defconstant writeown #o200 _N"Write by owner") -(defconstant execown #o100 _N"Execute (search directory) by owner") -(defconstant readgrp #o40 _N"Read by group") -(defconstant writegrp #o20 _N"Write by group") -(defconstant execgrp #o10 _N"Execute (search directory) by group") -(defconstant readoth #o4 _N"Read by others") -(defconstant writeoth #o2 _N"Write by others") -(defconstant execoth #o1 _N"Execute (search directory) by others") - -(defconstant terminal-speeds - '#(0 50 75 110 134 150 200 300 600 1200 1800 2400 - 4800 9600 19200 38400 57600 115200 230400)) - -;;;; Support routines for dealing with unix pathnames. - -(export '(unix-file-kind unix-maybe-prepend-current-directory - unix-resolve-links unix-simplify-pathname)) - -(defun unix-file-kind (name &optional check-for-links) - _N"Returns either :file, :directory, :link, :special, or NIL." - (declare (simple-string name)) - (multiple-value-bind (res dev ino mode) - (if check-for-links - (unix-lstat name) - (unix-stat name)) - (declare (type (or fixnum null) mode) - (ignore dev ino)) - (when res - (let ((kind (logand mode s-ifmt))) - (cond ((eql kind s-ifdir) :directory) - ((eql kind s-ifreg) :file) - ((eql kind s-iflnk) :link) - (t :special)))))) - -(defun unix-maybe-prepend-current-directory (name) - (declare (simple-string name)) - (if (and (> (length name) 0) (char= (schar name 0) #\/)) - name - (multiple-value-bind (win dir) (unix-current-directory) - (if win - (concatenate 'simple-string dir "/" name) - name)))) - -(defun unix-resolve-links (pathname) - _N"Returns the pathname with all symbolic links resolved." - (declare (simple-string pathname)) - (let ((len (length pathname)) - (pending pathname)) - (declare (fixnum len) (simple-string pending)) - (if (zerop len) - pathname - (let ((result (make-string 100 :initial-element (code-char 0))) - (fill-ptr 0) - (name-start 0)) - (loop - (let* ((name-end (or (position #\/ pending :start name-start) len)) - (new-fill-ptr (+ fill-ptr (- name-end name-start)))) - ;; grow the result string, if necessary. the ">=" (instead of - ;; using ">") allows for the trailing "/" if we find this - ;; component is a directory. - (when (>= new-fill-ptr (length result)) - (let ((longer (make-string (* 3 (length result)) - :initial-element (code-char 0)))) - (replace longer result :end1 fill-ptr) - (setq result longer))) - (replace result pending - :start1 fill-ptr - :end1 new-fill-ptr - :start2 name-start - :end2 name-end) - (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t))) - (unless kind (return nil)) - (cond ((eq kind :link) - (multiple-value-bind (link err) (unix-readlink result) - (unless link - (error (intl:gettext "Error reading link ~S: ~S") - (subseq result 0 fill-ptr) - (get-unix-error-msg err))) - (cond ((or (zerop (length link)) - (char/= (schar link 0) #\/)) - ;; It's a relative link - (fill result (code-char 0) - :start fill-ptr - :end new-fill-ptr)) - ((string= result "/../" :end1 4) - ;; It's across the super-root. - (let ((slash (or (position #\/ result :start 4) - 0))) - (fill result (code-char 0) - :start slash - :end new-fill-ptr) - (setf fill-ptr slash))) - (t - ;; It's absolute. - (and (> (length link) 0) - (char= (schar link 0) #\/)) - (fill result (code-char 0) :end new-fill-ptr) - (setf fill-ptr 0))) - (setf pending - (if (= name-end len) - link - (concatenate 'simple-string - link - (subseq pending name-end)))) - (setf len (length pending)) - (setf name-start 0))) - ((= name-end len) - (when (eq kind :directory) - (setf (schar result new-fill-ptr) #\/) - (incf new-fill-ptr)) - (return (subseq result 0 new-fill-ptr))) - ((eq kind :directory) - (setf (schar result new-fill-ptr) #\/) - (setf fill-ptr (1+ new-fill-ptr)) - (setf name-start (1+ name-end))) - (t - (return nil)))))))))) - -(defun unix-simplify-pathname (src) - (declare (simple-string src)) - (let* ((src-len (length src)) - (dst (make-string src-len)) - (dst-len 0) - (dots 0) - (last-slash nil)) - (macrolet ((deposit (char) - `(progn - (setf (schar dst dst-len) ,char) - (incf dst-len)))) - (dotimes (src-index src-len) - (let ((char (schar src src-index))) - (cond ((char= char #\.) - (when dots - (incf dots)) - (deposit char)) - ((char= char #\/) - (case dots - (0 - ;; Either ``/...' or ``...//...' - (unless last-slash - (setf last-slash dst-len) - (deposit char))) - (1 - ;; Either ``./...'' or ``..././...'' - (decf dst-len)) - (2 - ;; We've found .. - (cond - ((and last-slash (not (zerop last-slash))) - ;; There is something before this .. - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (cond ((and (= (+ (or prev-prev-slash 0) 2) - last-slash) - (char= (schar dst (- last-slash 2)) #\.) - (char= (schar dst (1- last-slash)) #\.)) - ;; The something before this .. is another .. - (deposit char) - (setf last-slash dst-len)) - (t - ;; The something is some random dir. - (setf dst-len - (if prev-prev-slash - (1+ prev-prev-slash) - 0)) - (setf last-slash prev-prev-slash))))) - (t - ;; There is nothing before this .., so we need to keep it - (setf last-slash dst-len) - (deposit char)))) - (t - ;; Something other than a dot between slashes. - (setf last-slash dst-len) - (deposit char))) - (setf dots 0)) - (t - (setf dots nil) - (setf (schar dst dst-len) char) - (incf dst-len)))))) - (when (and last-slash (not (zerop last-slash))) - (case dots - (1 - ;; We've got ``foobar/.'' - (decf dst-len)) - (2 - ;; We've got ``foobar/..'' - (unless (and (>= last-slash 2) - (char= (schar dst (1- last-slash)) #\.) - (char= (schar dst (- last-slash 2)) #\.) - (or (= last-slash 2) - (char= (schar dst (- last-slash 3)) #\/))) - (let ((prev-prev-slash - (position #\/ dst :end last-slash :from-end t))) - (if prev-prev-slash - (setf dst-len (1+ prev-prev-slash)) - (return-from unix-simplify-pathname "./"))))))) - (cond ((zerop dst-len) - "./") - ((= dst-len src-len) - dst) - (t - (subseq dst 0 dst-len))))) - -;;; -;;; STRING-LIST-TO-C-STRVEC -- Internal -;;; -;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of -;;; simple-strings and constructs a C-style string vector (strvec) -- -;;; a null-terminated array of pointers to null-terminated strings. -;;; This function returns two values: a sap and a byte count. When the -;;; memory is no longer needed it should be deallocated with -;;; vm_deallocate. -;;; -(defun string-list-to-c-strvec (string-list) - ;; - ;; Make a pass over string-list to calculate the amount of memory - ;; needed to hold the strvec. - (let ((string-bytes 0) - (vec-bytes (* 4 (1+ (length string-list))))) - (declare (fixnum string-bytes vec-bytes)) - (dolist (s string-list) - (check-type s simple-string) - (incf string-bytes (round-bytes-to-words (1+ (length s))))) - ;; - ;; Now allocate the memory and fill it in. - (let* ((total-bytes (+ string-bytes vec-bytes)) - (vec-sap (system:allocate-system-memory total-bytes)) - (string-sap (sap+ vec-sap vec-bytes)) - (i 0)) - (declare (type (and unsigned-byte fixnum) total-bytes i) - (type system:system-area-pointer vec-sap string-sap)) - (dolist (s string-list) - (declare (simple-string s)) - (let ((n (length s))) - ;; - ;; Blast the string into place - #-unicode - (kernel:copy-to-system-area (the simple-string s) - (* vm:vector-data-offset vm:word-bits) - string-sap 0 - (* (1+ n) vm:byte-bits)) - #+unicode - (progn - ;; FIXME: Do we need to apply some kind of transformation - ;; to convert Lisp unicode strings to C strings? Utf-8? - (dotimes (k n) - (setf (sap-ref-8 string-sap k) - (logand #xff (char-code (aref s k))))) - (setf (sap-ref-8 string-sap n) 0)) - ;; - ;; Blast the pointer to the string into place - (setf (sap-ref-sap vec-sap i) string-sap) - (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) - (incf i 4))) - ;; Blast in last null pointer - (setf (sap-ref-sap vec-sap i) (int-sap 0)) - (values vec-sap total-bytes)))) - -;;; Stuff not yet found in the header files... -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Abandon all hope who enters here... - - -;; not checked for linux... -(defmacro fd-set (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) - (setf (deref (slot ,fd-set 'fds-bits) ,word) - (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) - (deref (slot ,fd-set 'fds-bits) ,word)))))) - -;; not checked for linux... -(defmacro fd-clr (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) - (setf (deref (slot ,fd-set 'fds-bits) ,word) - (logand (deref (slot ,fd-set 'fds-bits) ,word) - (32bit-logical-not - (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) - -;; not checked for linux... -(defmacro fd-isset (offset fd-set) - (let ((word (gensym)) - (bit (gensym))) - `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) - (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) - -;; not checked for linux... -(defmacro fd-zero (fd-set) - `(progn - ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) - collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) - +(defmacro fd-set-to-num (nfds fdset) + `(if (<= ,nfds nfdbits) + (deref (slot ,fdset 'fds-bits) 0) + (+ ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(ash (deref (slot ,fdset 'fds-bits) ,index) + ,(* index nfdbits)))))) +(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) + _N"Unix-select examines the sets of descriptors passed as arguments + to see if they are ready for reading and writing. See the UNIX + Programmers Manual for more information." + (declare (type (integer 0 #.FD-SETSIZE) nfds) + (type unsigned-byte rdfds wrfds xpfds) + (type (or (unsigned-byte 31) null) to-secs) + (type (unsigned-byte 31) to-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (with-alien ((tv (struct timeval)) + (rdf (struct fd-set)) + (wrf (struct fd-set)) + (xpf (struct fd-set))) + (when to-secs + (setf (slot tv 'tv-sec) to-secs) + (setf (slot tv 'tv-usec) to-usecs)) + (num-to-fd-set rdf rdfds) + (num-to-fd-set wrf wrfds) + (num-to-fd-set xpf xpfds) + (macrolet ((frob (lispvar alienvar) + `(if (zerop ,lispvar) + (int-sap 0) + (alien-sap (addr ,alienvar))))) + (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + (values result + (fd-set-to-num nfds rdf) + (fd-set-to-num nfds wrf) + (fd-set-to-num nfds xpf)) + nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) + (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) - -;;;; User and group database access, POSIX Standard 9.2.2 +(def-alien-routine ("gethostid" unix-gethostid) unsigned-long + _N"Unix-gethostid returns a 32-bit integer which provides unique + identification for the host machine.") -(defun unix-getpwnam (login) - _N"Return a USER-INFO structure for the user identified by LOGIN, or NIL if not found." - (declare (type simple-string login)) - (with-alien ((buf (array c-call:char 1024)) - (user-info (struct passwd)) - (result (* (struct passwd)))) - (let ((returned - (alien-funcall - (extern-alien "getpwnam_r" - (function c-call:int - c-call:c-string - (* (struct passwd)) - (* c-call:char) - c-call:unsigned-int - (* (* (struct passwd))))) - login - (addr user-info) - (cast buf (* c-call:char)) - 1024 - (addr result)))) - (when (zerop returned) - (make-user-info - :name (string (cast (slot result 'pw-name) c-call:c-string)) - :password (string (cast (slot result 'pw-passwd) c-call:c-string)) - :uid (slot result 'pw-uid) - :gid (slot result 'pw-gid) - :gecos (string (cast (slot result 'pw-gecos) c-call:c-string)) - :dir (string (cast (slot result 'pw-dir) c-call:c-string)) - :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))) +(def-alien-routine ("getpid" unix-getpid) int + _N"Unix-getpid returns the process-id of the current process.") + +(defstruct user-info + (name "" :type string) + (password "" :type string) + (uid 0 :type unix-uid) + (gid 0 :type unix-gid) + (gecos "" :type string) + (dir "" :type string) + (shell "" :type string)) (defun unix-getpwuid (uid) _N"Return a USER-INFO structure for the user identified by UID, or NIL if not found." @@ -3733,67 +1571,168 @@ in at a time in poll.") :dir (string (cast (slot result 'pw-dir) c-call:c-string)) :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))) -(defun unix-getgrnam (name) - _N"Return a GROUP-INFO structure for the group identified by NAME, or NIL if not found." - (declare (type simple-string name)) - (with-alien ((buf (array c-call:char 2048)) - (group-info (struct group)) - (result (* (struct group)))) - (let ((returned - (alien-funcall - (extern-alien "getgrnam_r" - (function c-call:int - c-call:c-string - (* (struct group)) - (* c-call:char) - c-call:unsigned-int - (* (* (struct group))))) - name - (addr group-info) - (cast buf (* c-call:char)) - 2048 - (addr result)))) - (when (zerop returned) - (make-group-info - :name (string (cast (slot result 'gr-name) c-call:c-string)) - :password (string (cast (slot result 'gr-passwd) c-call:c-string)) - :gid (slot result 'gr-gid) - :members (loop :with members = (slot result 'gr-mem) - :for i :from 0 - :for member = (deref members i) - :until (zerop (sap-int (alien-sap member))) - :collect (string (cast member c-call:c-string)))))))) - -(defun unix-getgrgid (gid) - _N"Return a GROUP-INFO structure for the group identified by GID, or NIL if not found." - (declare (type unix-gid gid)) - (with-alien ((buf (array c-call:char 2048)) - (group-info (struct group)) - (result (* (struct group)))) - (let ((returned - (alien-funcall - (extern-alien "getgrgid_r" - (function c-call:int - c-call:unsigned-int - (* (struct group)) - (* c-call:char) - c-call:unsigned-int - (* (* (struct group))))) - gid - (addr group-info) - (cast buf (* c-call:char)) - 2048 - (addr result)))) - (when (zerop returned) - (make-group-info - :name (string (cast (slot result 'gr-name) c-call:c-string)) - :password (string (cast (slot result 'gr-passwd) c-call:c-string)) - :gid (slot result 'gr-gid) - :members (loop :with members = (slot result 'gr-mem) - :for i :from 0 - :for member = (deref members i) - :until (zerop (sap-int (alien-sap member))) - :collect (string (cast member c-call:c-string)))))))) - - -;; EOF +(declaim (inline unix-gettimeofday)) +(defun unix-gettimeofday () + _N"If it works, unix-gettimeofday returns 5 values: T, the seconds and + microseconds of the current time of day, the timezone (in minutes west + of Greenwich), and a daylight-savings flag. If it doesn't work, it + returns NIL and the errno." + (with-alien ((tv (struct timeval)) + (tz (struct timezone))) + (syscall* ("gettimeofday" (* (struct timeval)) + (* (struct timezone))) + (values T + (slot tv 'tv-sec) + (slot tv 'tv-usec) + (slot tz 'tz-minuteswest) + (slot tz 'tz-dsttime)) + (addr tv) + (addr tz)))) + +(def-alien-routine ("ttyname" unix-ttyname) c-string + (fd int)) + +(def-alien-routine ("isatty" unix-isatty) boolean + _N"Accepts a Unix file descriptor and returns T if the device + associated with it is a terminal." + (fd int)) + +;;; pty.h + +(defun unix-openpty (name termp winp) + _N"Create pseudo tty master slave pair with NAME and set terminal + attributes according to TERMP and WINP and return handles for both + ends in AMASTER and ASLAVE." + (with-alien ((amaster int) + (aslave int)) + (values + (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios)) + (* (struct winsize))) + (addr amaster) (addr aslave) name termp winp) + amaster aslave))) + +(def-alien-type nil + (struct utsname + (sysname (array char 65)) + (nodename (array char 65)) + (release (array char 65)) + (version (array char 65)) + (machine (array char 65)) + (domainname (array char 65)))) + +(defun unix-uname () + _N"Unix-uname returns the name and information about the current kernel. The + values returned upon success are: sysname, nodename, release, version, + machine, and domainname. Upon failure, 'nil and the 'errno are returned." + (with-alien ((utsname (struct utsname))) + (syscall* ("uname" (* (struct utsname))) + (values (cast (slot utsname 'sysname) c-string) + (cast (slot utsname 'nodename) c-string) + (cast (slot utsname 'release) c-string) + (cast (slot utsname 'version) c-string) + (cast (slot utsname 'machine) c-string) + (cast (slot utsname 'domainname) c-string)) + (addr utsname)))) + +(defun unix-ioctl (fd cmd arg) + _N"Unix-ioctl performs a variety of operations on open i/o + descriptors. See the UNIX Programmer's Manual for more + information." + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd)) + (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) + + +;;; Unix-mkdir accepts a name and a mode and attempts to create the +;;; corresponding directory with mode mode. + +(defun unix-mkdir (name mode) + _N"Unix-mkdir creates a new directory with the specified name and mode. + (Same as those for unix-chmod.) It returns T upon success, otherwise + NIL and an error number." + (declare (type unix-pathname name) + (type unix-file-mode mode)) + (void-syscall ("mkdir" c-string int) (%name->file name) mode)) + +;; A time value that is accurate to the nearest +;; microsecond but also has a range of years. +(def-alien-type nil + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec time-t))) ; and microseconds + +;;; sys/time.h + +;; Structure crudely representing a timezone. +;; This is obsolete and should never be used. +(def-alien-type nil + (struct timezone + (tz-minuteswest int) ; minutes west of Greenwich + (tz-dsttime int))) ; type of dst correction + +;; Type of the second argument to `getitimer' and +;; the second and third arguments `setitimer'. +(def-alien-type nil + (struct itimerval + (it-interval (struct timeval)) ; timer interval + (it-value (struct timeval)))) ; current value + +(defconstant ITIMER-REAL 0) +(defconstant ITIMER-VIRTUAL 1) +(defconstant ITIMER-PROF 2) + +(defun unix-getitimer (which) + _N"Unix-getitimer returns the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). On success, + unix-getitimer returns 5 values, + T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." + (declare (type (member :real :virtual :profile) which) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itv (struct itimerval))) + (syscall* ("getitimer" int (* (struct itimerval))) + (values T + (slot (slot itv 'it-interval) 'tv-sec) + (slot (slot itv 'it-interval) 'tv-usec) + (slot (slot itv 'it-value) 'tv-sec) + (slot (slot itv 'it-value) 'tv-usec)) + which (alien-sap (addr itv)))))) + +(defun unix-setitimer (which int-secs int-usec val-secs val-usec) + _N" Unix-setitimer sets the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). A SIGALRM signal + will be delivered VALUE <seconds+microseconds> from now. INTERVAL, + when non-zero, is <seconds+microseconds> to be loaded each time + the timer expires. Setting INTERVAL and VALUE to zero disables + the timer. See the Unix man page for more details. On success, + unix-setitimer returns the old contents of the INTERVAL and VALUE + slots as in unix-getitimer." + (declare (type (member :real :virtual :profile) which) + (type (unsigned-byte 29) int-secs val-secs) + (type (integer 0 (1000000)) int-usec val-usec) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itvn (struct itimerval)) + (itvo (struct itimerval))) + (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs + (slot (slot itvn 'it-interval) 'tv-usec) int-usec + (slot (slot itvn 'it-value ) 'tv-sec ) val-secs + (slot (slot itvn 'it-value ) 'tv-usec) val-usec) + (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) + (values T + (slot (slot itvo 'it-interval) 'tv-sec) + (slot (slot itvo 'it-interval) 'tv-usec) + (slot (slot itvo 'it-value) 'tv-sec) + (slot (slot itvo 'it-value) 'tv-usec)) + which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + ===================================== src/contrib/unix/unix-glibc2.lisp ===================================== --- /dev/null +++ b/src/contrib/unix/unix-glibc2.lisp @@ -0,0 +1,3799 @@ +;;; -*- Package: UNIX -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; +(ext:file-comment + "$Header: src/code/unix-glibc2.lisp $") +;;; +;;; ********************************************************************** +;;; +;;; This file contains the UNIX low-level support for glibc2. Based +;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998). +;;; Alpha support by Julian Dolby, 1999. +;;; +;;; All the functions with #+(or) in front are work in progress, +;;; and mostly don't work. +;;; +;; Todo: #+(or)'ed stuff and ioctl's +;; +;; +;; Large File Support (LFS) added by Pierre Mai and Eric Marsden, Feb +;; 2003. This is necessary to be able to read/write/stat files that +;; are larger than 2GB on a 32-bit system. From a C program, defining +;; a preprocessor macro _LARGEFILE64_SOURCE makes the preproccessor +;; replace a call to open() by open64(), and similarly for stat, +;; fstat, lstat, lseek, readdir and friends. Furthermore, certain data +;; types, that are normally 32 bits wide, are replaced by 64-bit wide +;; equivalents: off_t -> off64_t etc. The libc.so fiddles around with +;; weak symbols to support this mess. +;; +;; From CMUCL, we make FFI calls to the xxx64 functions, and use the +;; 64-bit wide versions of the data structures. The most ugly aspect +;; is that some of the stat functions are not available via dlsym, so +;; we reference them explicitly from linux-stubs.S. Another amusing +;; fact is that on glibc 2.2, stat64() returns a struct stat with a +;; 32-bit ino_t, whereas readdir64() returns a struct dirent that +;; contains a 64-bit ino_t. On glibc 2.1, OTOH, both stat64 and +;; readdir64 use structs with 32-bit ino_t. +;; +;; The current version deals with this by going with the glibc 2.2 +;; definitions, unless the keyword :glibc2.1 also occurs on *features*, +;; in addition to :glibc2, in which case we go with the glibc 2.1 +;; definitions. Note that binaries compiled against glibc 2.1 do in +;; fact work fine on glibc 2.2, because readdir64 is available in both +;; glibc 2.1 and glibc 2.2 versions in glibc 2.2, disambiguated through +;; ELF symbol versioning. We use an entry for readdir64 in linux-stubs.S +;; in order to force usage of the correct version of readdir64 at runtime. +;; +;; So in order to compile for glibc 2.2 and newer, just compile CMUCL +;; on a glibc 2.2 system, and make sure that :glibc2.1 doesn't appear +;; on the *features* list. In order to compile for glibc 2.1 and newer, +;; compile CMUCL on a glibc 2.1 system, and make sure that :glibc2.1 does +;; appear on the *features* list. + +(in-package "UNIX") +(use-package "ALIEN") +(use-package "C-CALL") +(use-package "SYSTEM") +(use-package "EXT") +(intl:textdomain "cmucl-unix-glibc2") + +;; Check the G_BROKEN_FILENAMES environment variable; if set the encoding +;; is locale-dependent...else use :utf-8 on Unicode Lisps. On 8 bit Lisps +;; it must be set to :iso8859-1 (or left as NIL), making files with +;; non-Latin-1 characters "mojibake", but otherwise they'll be inaccessible. +;; Must be set to NIL initially to enable building Lisp! +(defvar *filename-encoding* nil) + +(export '( + daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t + blkcnt-t fsblkcnt-t fsfilcnt-t + unix-lockf f_ulock f_lock f_tlock f_test + timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime + itimerval it-interval it-value tchars t-intrc t-quitc t-startc + t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc + t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill + sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel + direct d-off d-ino d-reclen d-name + stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size + st-atime st-mtime st-ctime st-blksize st-blocks + s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock + s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec + ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss + ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock + ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw + rlimit rlim-cur rlim-max sc-onstack sc-mask sc-pc + unix-errno get-unix-error-msg + prot_read prot_write prot_exec prot_none + map_shared map_private map_fixed map_anonymous + ms_async ms_sync ms_invalidate + unix-mmap unix-munmap unix-msync unix-mprotect + unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid + unix-setitimer unix-getitimer + unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec + setgidexec savetext readown writeown execown readgrp writegrp + execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown + unix-getdtablesize unix-close unix-creat unix-dup unix-dup2 + unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown + fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek + l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr + o_ndelay + o_noctty + o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink + unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr + fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate + unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl + unix-uname utsname + tcsetpgrp tcgetpgrp tty-process-group + terminal-speeds tty-raw tty-crmod tty-echo tty-lcase + tty-cbreak + termios + c-lflag + c-iflag + c-oflag + tty-icrnl + tty-ocrnl + veof + vintr + vquit + vstart + vstop + vsusp + c-cflag + c-cc + tty-icanon + vmin + vtime + tty-ixon + tcsanow + tcsadrain + tciflush + tcoflush + tcioflush + tcsaflush + unix-tcgetattr + unix-tcsetattr + tty-ignbrk + tty-brkint + tty-ignpar + tty-parmrk + tty-inpck + tty-istrip + tty-inlcr + tty-igncr + tty-iuclc + tty-ixany + tty-ixoff + tty-imaxbel + tty-opost + tty-olcuc + tty-onlcr + tty-onocr + tty-onlret + tty-ofill + tty-ofdel + tty-isig + tty-xcase + tty-echoe + tty-echok + tty-echonl + tty-noflsh + tty-iexten + tty-tostop + tty-echoctl + tty-echoprt + tty-echoke + tty-pendin + tty-cstopb + tty-cread + tty-parenb + tty-parodd + tty-hupcl + tty-clocal + vintr + verase + vkill + veol + veol2 + TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC + TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ + TIOCSIGSEND + + KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK + KBDSCLICK FIONREAD unix-exit unix-stat unix-lstat unix-fstat + unix-getrusage unix-fast-getrusage rusage_self rusage_children + unix-gettimeofday + unix-utimes unix-sched-yield unix-setreuid + unix-setregid + unix-getpid unix-getppid + unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid + unix-getpagesize unix-gethostname unix-gethostid unix-fork + unix-getenv unix-setenv unix-putenv unix-unsetenv + unix-current-directory unix-isatty unix-ttyname unix-execve + unix-socket unix-connect unix-bind unix-listen unix-accept + unix-recv unix-send unix-getpeername unix-getsockname + unix-getsockopt unix-setsockopt unix-openpty + + unix-recvfrom unix-sendto unix-shutdown + + unix-getpwnam unix-getpwuid unix-getgrnam unix-getgrgid + user-info user-info-name user-info-password user-info-uid + user-info-gid user-info-gecos user-info-dir user-info-shell + group-info group-info-name group-info-gid group-info-members)) + +(pushnew :unix *features*) +(pushnew :glibc2 *features*) + +;; needed for bootstrap +(eval-when (:compile-toplevel) + (defmacro %name->file (string) + `(if *filename-encoding* + (string-encode ,string *filename-encoding*) + ,string)) + (defmacro %file->name (string) + `(if *filename-encoding* + (string-decode ,string *filename-encoding*) + ,string))) + +;;;; Common machine independent structures. + +(eval-when (compile eval) + +(defparameter *compiler-unix-errors* nil) + +(defmacro def-unix-error (name number description) + `(progn + (eval-when (compile eval) + (push (cons ,number ,description) *compiler-unix-errors*)) + (defconstant ,name ,number ,description) + (export ',name))) + +(defmacro emit-unix-errors () + (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*))) + (array (make-array (1+ max) :initial-element nil))) + (dolist (error *compiler-unix-errors*) + (setf (svref array (car error)) (cdr error))) + `(progn + (defvar *unix-errors* ',array) + (declaim (simple-vector *unix-errors*))))) + +) + +(defmacro def-enum (inc cur &rest names) + (flet ((defform (name) + (prog1 (when name `(defconstant ,name ,cur)) + (setf cur (funcall inc cur 1))))) + `(progn ,@(mapcar #'defform names)))) + +;;;; Memory-mapped files + +(defconstant +null+ (sys:int-sap 0)) + +(defconstant prot_read 1) +(defconstant prot_write 2) +(defconstant prot_exec 4) +(defconstant prot_none 0) + +(defconstant map_shared 1) +(defconstant map_private 2) +(defconstant map_fixed 16) +(defconstant map_anonymous 32) + +(defconstant ms_async 1) +(defconstant ms_sync 4) +(defconstant ms_invalidate 2) + +;; The return value from mmap that means mmap failed. +(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits)))) + +(defun unix-mmap (addr length prot flags fd offset) + (declare (type (or null system-area-pointer) addr) + (type (unsigned-byte 32) length) + (type (integer 1 7) prot) + (type (unsigned-byte 32) flags) + (type (or null unix-fd) fd) + (type (signed-byte 32) offset)) + ;; Can't use syscall, because the address that is returned could be + ;; "negative". Hence we explicitly check for mmap returning + ;; MAP_FAILED. + (let ((result + (alien-funcall (extern-alien "mmap" (function system-area-pointer + system-area-pointer + size-t int int int off-t)) + (or addr +null+) length prot flags (or fd -1) offset))) + (if (sap= result map_failed) + (values nil (unix-errno)) + (values result 0)))) + +(defun unix-munmap (addr length) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length)) + (syscall ("munmap" system-area-pointer size-t) t addr length)) + +(defun unix-msync (addr length flags) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length) + (type (signed-byte 32) flags)) + (syscall ("msync" system-area-pointer size-t int) t addr length flags)) + +(defun unix-mprotect (addr length prot) + (declare (type system-area-pointer addr) + (type (unsigned-byte 32) length) + (type (integer 1 7) prot)) + (syscall ("mprotect" system-area-pointer size-t int) + t addr length prot)) + +;;;; Lisp types used by syscalls. + +(deftype unix-pathname () 'simple-string) +(deftype unix-fd () `(integer 0 ,most-positive-fixnum)) + +(deftype unix-file-mode () '(unsigned-byte 32)) +(deftype unix-pid () '(unsigned-byte 32)) +(deftype unix-uid () '(unsigned-byte 32)) +(deftype unix-gid () '(unsigned-byte 32)) + + +;;;; User and group database structures: <pwd.h> and <grp.h> + +(defstruct user-info + (name "" :type string) + (password "" :type string) + (uid 0 :type unix-uid) + (gid 0 :type unix-gid) + (gecos "" :type string) + (dir "" :type string) + (shell "" :type string)) + +(defstruct group-info + (name "" :type string) + (password "" :type string) + (gid 0 :type unix-gid) + (members nil :type list)) ; list of logins as strings + +(def-alien-type nil + (struct passwd + (pw-name (* char)) ; user's login name + (pw-passwd (* char)) ; no longer used + (pw-uid uid-t) ; user id + (pw-gid gid-t) ; group id + (pw-gecos (* char)) ; typically user's full name + (pw-dir (* char)) ; user's home directory + (pw-shell (* char)))) ; user's login shell + +(def-alien-type nil + (struct group + (gr-name (* char)) ; name of the group + (gr-passwd (* char)) ; encrypted group password + (gr-gid gid-t) ; numerical group ID + (gr-mem (* (* char))))) ; vector of pointers to member names + + +;;;; System calls. + +(def-alien-routine ("os_get_errno" unix-get-errno) int) +(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int)) +(defun unix-errno () (unix-get-errno)) +(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue)) + +;;; GET-UNIX-ERROR-MSG -- public. +;;; +(defun get-unix-error-msg (&optional (error-number (unix-errno))) + _N"Returns a string describing the error number which was returned by a + UNIX system call." + (declare (type integer error-number)) + + (if (array-in-bounds-p *unix-errors* error-number) + (svref *unix-errors* error-number) + (format nil (intl:gettext "Unknown error [~d]") error-number))) + +(defmacro syscall ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (values nil (unix-errno)) + ,success-form))) + +;;; Like syscall, but if it fails, signal an error instead of returning error +;;; codes. Should only be used for syscalls that will never really get an +;;; error. +;;; +(defmacro syscall* ((name &rest arg-types) success-form &rest args) + `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types)) + ,@args))) + (if (minusp result) + (error (intl:gettext "Syscall ~A failed: ~A") ,name (get-unix-error-msg)) + ,success-form))) + +(defmacro void-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values t 0) ,@args)) + +(defmacro int-syscall ((name &rest arg-types) &rest args) + `(syscall (,name ,@arg-types) (values result 0) ,@args)) + +;;; From stdio.h + +;;; Unix-rename accepts two files names and renames the first to the second. + +(defun unix-rename (name1 name2) + _N"Unix-rename renames the file with string name1 to the string + name2. NIL and an error code is returned if an error occured." + (declare (type unix-pathname name1 name2)) + (void-syscall ("rename" c-string c-string) + (%name->file name1) (%name->file name2))) + +;;; From sys/types.h +;;; and +;;; gnu/types.h + +(defconstant +max-s-long+ 2147483647) +(defconstant +max-u-long+ 4294967295) + +(def-alien-type quad-t #+alpha long #-alpha (array long 2)) +(def-alien-type uquad-t #+alpha unsigned-long + #-alpha (array unsigned-long 2)) +(def-alien-type qaddr-t (* quad-t)) +(def-alien-type daddr-t int) +(def-alien-type caddr-t (* char)) +(def-alien-type swblk-t long) +(def-alien-type size-t #-alpha unsigned-int #+alpha long) +(def-alien-type time-t long) +(def-alien-type clock-t long) +(def-alien-type uid-t unsigned-int) +(def-alien-type ssize-t #-alpha int #+alpha long) +(def-alien-type key-t int) +(def-alien-type int8-t char) +(def-alien-type u-int8-t unsigned-char) +(def-alien-type int16-t short) +(def-alien-type u-int16-t unsigned-short) +(def-alien-type int32-t int) +(def-alien-type u-int32-t unsigned-int) +(def-alien-type int64-t (signed 64)) +(def-alien-type u-int64-t (unsigned 64)) +(def-alien-type register-t #-alpha int #+alpha long) + +(def-alien-type dev-t #-amd64 uquad-t #+amd64 u-int64-t) +(def-alien-type uid-t unsigned-int) +(def-alien-type gid-t unsigned-int) +(def-alien-type ino-t #-amd64 u-int32-t #+amd64 u-int64-t) +(def-alien-type ino64-t u-int64-t) +(def-alien-type mode-t u-int32-t) +(def-alien-type nlink-t #-amd64 unsigned-int #+amd64 u-int64-t) +(def-alien-type off-t int64-t) +(def-alien-type blkcnt-t u-int64-t) +(def-alien-type fsblkcnt-t u-int64-t) +(def-alien-type fsfilcnt-t u-int64-t) +(def-alien-type pid-t int) +;(def-alien-type ssize-t #-alpha int #+alpha long) + +(def-alien-type fsid-t (array int 2)) + +(def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int) + +(defconstant fd-setsize 1024) +(defconstant nfdbits 32) + +(def-alien-type nil + (struct fd-set + (fds-bits (array fd-mask #.(/ fd-setsize nfdbits))))) + +(def-alien-type key-t int) + +(def-alien-type ipc-pid-t unsigned-short) + +;;; direntry.h + +(def-alien-type nil + (struct dirent + #+glibc2.1 + (d-ino ino-t) ; inode number of entry + #-glibc2.1 + (d-ino ino64-t) ; inode number of entry + (d-off off-t) ; offset of next disk directory entry + (d-reclen unsigned-short) ; length of this record + (d_type unsigned-char) + (d-name (array char 256)))) ; name must be no longer than this +;;; dirent.h + +;;; Operations on Unix Directories. + +(export '(open-dir read-dir close-dir)) + +(defstruct (%directory + (:constructor make-directory) + (:conc-name directory-) + (:print-function %print-directory)) + name + (dir-struct (required-argument) :type system-area-pointer)) + +(defun %print-directory (dir stream depth) + (declare (ignore depth)) + (format stream "#<Directory ~S>" (directory-name dir))) + +(defun open-dir (pathname) + (declare (type unix-pathname pathname)) + (when (string= pathname "") + (setf pathname ".")) + (let ((kind (unix-file-kind pathname))) + (case kind + (:directory + (let ((dir-struct + (alien-funcall (extern-alien "opendir" + (function system-area-pointer + c-string)) + (%name->file pathname)))) + (if (zerop (sap-int dir-struct)) + (values nil (unix-errno)) + (make-directory :name pathname :dir-struct dir-struct)))) + ((nil) + (values nil enoent)) + (t + (values nil enotdir))))) + +(defun read-dir (dir) + (declare (type %directory dir)) + (let ((daddr (alien-funcall (extern-alien "readdir64" + (function system-area-pointer + system-area-pointer)) + (directory-dir-struct dir)))) + (declare (type system-area-pointer daddr)) + (if (zerop (sap-int daddr)) + nil + (with-alien ((dirent (* (struct dirent)) daddr)) + (values (%file->name (cast (slot dirent 'd-name) c-string)) + (slot dirent 'd-ino)))))) + +(defun close-dir (dir) + (declare (type %directory dir)) + (alien-funcall (extern-alien "closedir" + (function void system-area-pointer)) + (directory-dir-struct dir)) + nil) + +;;; dlfcn.h -> in foreign.lisp + +;;; fcntl.h +;;; +;;; POSIX Standard: 6.5 File Control Operations <fcntl.h> + +(defconstant r_ok 4 _N"Test for read permission") +(defconstant w_ok 2 _N"Test for write permission") +(defconstant x_ok 1 _N"Test for execute permission") +(defconstant f_ok 0 _N"Test for presence of file") + +(defun unix-fcntl (fd cmd arg) + _N"Unix-fcntl manipulates file descriptors accoridng to the + argument CMD which can be one of the following: + + F-DUPFD Duplicate a file descriptor. + F-GETFD Get file descriptor flags. + F-SETFD Set file descriptor flags. + F-GETFL Get file flags. + F-SETFL Set file flags. + F-GETOWN Get owner. + F-SETOWN Set owner. + + The flags that can be specified for F-SETFL are: + + FNDELAY Non-blocking reads. + FAPPEND Append on each write. + FASYNC Signal pgrp when data ready. + FCREAT Create if nonexistant. + FTRUNC Truncate to zero length. + FEXCL Error if already created. + " + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd) + (type (unsigned-byte 32) arg)) + (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg)) + +(defun unix-open (path flags mode) + _N"Unix-open opens the file whose pathname is specified by PATH + for reading and/or writing as specified by the FLAGS argument. + Returns an integer file descriptor. + The flags argument can be: + + o_rdonly Read-only flag. + o_wronly Write-only flag. + o_rdwr Read-and-write flag. + o_append Append flag. + o_creat Create-if-nonexistant flag. + o_trunc Truncate-to-size-0 flag. + o_excl Error if the file already exists + o_noctty Don't assign controlling tty + o_ndelay Non-blocking I/O + o_sync Synchronous I/O + o_async Asynchronous I/O + + If the o_creat flag is specified, then the file is created with + a permission of argument MODE if the file doesn't exist." + (declare (type unix-pathname path) + (type fixnum flags) + (type unix-file-mode mode)) + (int-syscall ("open64" c-string int int) (%name->file path) flags mode)) + +(defun unix-getdtablesize () + _N"Unix-getdtablesize returns the maximum size of the file descriptor + table. (i.e. the maximum number of descriptors that can exist at + one time.)" + (int-syscall ("getdtablesize"))) + +;;; Unix-close accepts a file descriptor and attempts to close the file +;;; associated with it. + +(defun unix-close (fd) + _N"Unix-close takes an integer file descriptor as an argument and + closes the file associated with it. T is returned upon successful + completion, otherwise NIL and an error number." + (declare (type unix-fd fd)) + (void-syscall ("close" int) fd)) + +;;; Unix-creat accepts a file name and a mode. It creates a new file +;;; with name and sets it mode to mode (as for chmod). + +(defun unix-creat (name mode) + _N"Unix-creat accepts a file name and a mode (same as those for + unix-chmod) and creates a file by that name with the specified + permission mode. It returns a file descriptor on success, + or NIL and an error number otherwise. + + This interface is made obsolete by UNIX-OPEN." + + (declare (type unix-pathname name) + (type unix-file-mode mode)) + (int-syscall ("creat64" c-string int) (%name->file name) mode)) + +;;; fcntlbits.h + +(defconstant o_read o_rdonly _N"Open for reading") +(defconstant o_write o_wronly _N"Open for writing") + +(defconstant o_rdonly 0 _N"Read-only flag.") +(defconstant o_wronly 1 _N"Write-only flag.") +(defconstant o_rdwr 2 _N"Read-write flag.") +(defconstant o_accmode 3 _N"Access mode mask.") + +#-alpha +(progn + (defconstant o_creat #o100 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_excl #o200 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o400 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_trunc #o1000 _N"Truncate flag. (not fcntl)") + (defconstant o_append #o2000 _N"Append flag.") + (defconstant o_ndelay #o4000 _N"Non-blocking I/O") + (defconstant o_nonblock #o4000 _N"Non-blocking I/O") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o10000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) +#+alpha +(progn + (defconstant o_creat #o1000 _N"Create if nonexistant flag. (not fcntl)") + (defconstant o_trunc #o2000 _N"Truncate flag. (not fcntl)") + (defconstant o_excl #o4000 _N"Error if already exists. (not fcntl)") + (defconstant o_noctty #o10000 _N"Don't assign controlling tty. (not fcntl)") + (defconstant o_nonblock #o4 _N"Non-blocking I/O") + (defconstant o_append #o10 _N"Append flag.") + (defconstant o_ndelay o_nonblock) + (defconstant o_sync #o40000 _N"Synchronous writes (on ext2)") + (defconstant o_fsync o_sync) + (defconstant o_async #o20000 _N"Asynchronous I/O")) + +(defconstant f-dupfd 0 _N"Duplicate a file descriptor") +(defconstant f-getfd 1 _N"Get file desc. flags") +(defconstant f-setfd 2 _N"Set file desc. flags") +(defconstant f-getfl 3 _N"Get file flags") +(defconstant f-setfl 4 _N"Set file flags") + +#-alpha +(progn + (defconstant f-getlk 5 _N"Get lock") + (defconstant f-setlk 6 _N"Set lock") + (defconstant f-setlkw 7 _N"Set lock, wait for release") + (defconstant f-setown 8 _N"Set owner (for sockets)") + (defconstant f-getown 9 _N"Get owner (for sockets)")) +#+alpha +(progn + (defconstant f-getlk 7 _N"Get lock") + (defconstant f-setlk 8 _N"Set lock") + (defconstant f-setlkw 9 _N"Set lock, wait for release") + (defconstant f-setown 5 _N"Set owner (for sockets)") + (defconstant f-getown 6 _N"Get owner (for sockets)")) + + + +(defconstant F-CLOEXEC 1 _N"for f-getfl and f-setfl") + +#-alpha +(progn + (defconstant F-RDLCK 0 _N"for fcntl and lockf") + (defconstant F-WRLCK 1 _N"for fcntl and lockf") + (defconstant F-UNLCK 2 _N"for fcntl and lockf") + (defconstant F-EXLCK 4 _N"old bsd flock (depricated)") + (defconstant F-SHLCK 8 _N"old bsd flock (depricated)")) +#+alpha +(progn + (defconstant F-RDLCK 1 _N"for fcntl and lockf") + (defconstant F-WRLCK 2 _N"for fcntl and lockf") + (defconstant F-UNLCK 8 _N"for fcntl and lockf") + (defconstant F-EXLCK 16 _N"old bsd flock (depricated)") + (defconstant F-SHLCK 32 _N"old bsd flock (depricated)")) + +(defconstant F-LOCK-SH 1 _N"Shared lock for bsd flock") +(defconstant F-LOCK-EX 2 _N"Exclusive lock for bsd flock") +(defconstant F-LOCK-NB 4 _N"Don't block. Combine with F-LOCK-SH or F-LOCK-EX") +(defconstant F-LOCK-UN 8 _N"Remove lock for bsd flock") + +(def-alien-type nil + (struct flock + (l-type short) + (l-whence short) + (l-start off-t) + (l-len off-t) + (l-pid pid-t))) + +;;; Define some more compatibility macros to be backward compatible with +;;; BSD systems which did not managed to hide these kernel macros. + +(defconstant FAPPEND o_append _N"depricated stuff") +(defconstant FFSYNC o_fsync _N"depricated stuff") +(defconstant FASYNC o_async _N"depricated stuff") +(defconstant FNONBLOCK o_nonblock _N"depricated stuff") +(defconstant FNDELAY o_ndelay _N"depricated stuff") + + +;;; grp.h + +;;; POSIX Standard: 9.2.1 Group Database Access <grp.h> + +#+(or) +(defun unix-setgrend () + _N"Rewind the group-file stream." + (void-syscall ("setgrend"))) + +#+(or) +(defun unix-endgrent () + _N"Close the group-file stream." + (void-syscall ("endgrent"))) + +#+(or) +(defun unix-getgrent () + _N"Read an entry from the group-file stream, opening it if necessary." + + (let ((result (alien-funcall (extern-alien "getgrent" + (function (* (struct group))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;;; ioctl-types.h + +(def-alien-type nil + (struct winsize + (ws-row unsigned-short) ; rows, in characters + (ws-col unsigned-short) ; columns, in characters + (ws-xpixel unsigned-short) ; horizontal size, pixels + (ws-ypixel unsigned-short))) ; veritical size, pixels + +(defconstant +NCC+ 8 + _N"Size of control character vector.") + +(def-alien-type nil + (struct termio + (c-iflag unsigned-int) ; input mode flags + (c-oflag unsigned-int) ; output mode flags + (c-cflag unsigned-int) ; control mode flags + (c-lflag unsigned-int) ; local mode flags + (c-line unsigned-char) ; line discipline + (c-cc (array unsigned-char #.+NCC+)))) ; control characters + +;;; modem lines +(defconstant tiocm-le 1) +(defconstant tiocm-dtr 2) +(defconstant tiocm-rts 4) +(defconstant tiocm-st 8) +(defconstant tiocm-sr #x10) +(defconstant tiocm-cts #x20) +(defconstant tiocm-car #x40) +(defconstant tiocm-rng #x80) +(defconstant tiocm-dsr #x100) +(defconstant tiocm-cd tiocm-car) +(defconstant tiocm-ri #x80) + +;;; ioctl (fd, TIOCSERGETLSR, &result) where result may be as below + +;;; line disciplines +(defconstant N-TTY 0) +(defconstant N-SLIP 1) +(defconstant N-MOUSE 2) +(defconstant N-PPP 3) +(defconstant N-STRIP 4) +(defconstant N-AX25 5) + + +;;; ioctls.h + +;;; Routing table calls. +(defconstant siocaddrt #x890B) ;; add routing table entry +(defconstant siocdelrt #x890C) ;; delete routing table entry +(defconstant siocrtmsg #x890D) ;; call to routing system + +;;; Socket configuration controls. +(defconstant siocgifname #x8910) ;; get iface name +(defconstant siocsiflink #x8911) ;; set iface channel +(defconstant siocgifconf #x8912) ;; get iface list +(defconstant siocgifflags #x8913) ;; get flags +(defconstant siocsifflags #x8914) ;; set flags +(defconstant siocgifaddr #x8915) ;; get PA address +(defconstant siocsifaddr #x8916) ;; set PA address +(defconstant siocgifdstaddr #x8917 ) ;; get remote PA address +(defconstant siocsifdstaddr #x8918 ) ;; set remote PA address +(defconstant siocgifbrdaddr #x8919 ) ;; get broadcast PA address +(defconstant siocsifbrdaddr #x891a ) ;; set broadcast PA address +(defconstant siocgifnetmask #x891b ) ;; get network PA mask +(defconstant siocsifnetmask #x891c ) ;; set network PA mask +(defconstant siocgifmetric #x891d ) ;; get metric +(defconstant siocsifmetric #x891e ) ;; set metric +(defconstant siocgifmem #x891f ) ;; get memory address (BSD) +(defconstant siocsifmem #x8920 ) ;; set memory address (BSD) +(defconstant siocgifmtu #x8921 ) ;; get MTU size +(defconstant siocsifmtu #x8922 ) ;; set MTU size +(defconstant siocsifhwaddr #x8924 ) ;; set hardware address +(defconstant siocgifencap #x8925 ) ;; get/set encapsulations +(defconstant siocsifencap #x8926) +(defconstant siocgifhwaddr #x8927 ) ;; Get hardware address +(defconstant siocgifslave #x8929 ) ;; Driver slaving support +(defconstant siocsifslave #x8930) +(defconstant siocaddmulti #x8931 ) ;; Multicast address lists +(defconstant siocdelmulti #x8932) +(defconstant siocgifindex #x8933 ) ;; name -> if_index mapping +(defconstant siogifindex SIOCGIFINDEX ) ;; misprint compatibility :-) +(defconstant siocsifpflags #x8934 ) ;; set/get extended flags set +(defconstant siocgifpflags #x8935) +(defconstant siocdifaddr #x8936 ) ;; delete PA address +(defconstant siocsifhwbroadcast #x8937 ) ;; set hardware broadcast addr +(defconstant siocgifcount #x8938 ) ;; get number of devices + +(defconstant siocgifbr #x8940 ) ;; Bridging support +(defconstant siocsifbr #x8941 ) ;; Set bridging options + +(defconstant siocgiftxqlen #x8942 ) ;; Get the tx queue length +(defconstant siocsiftxqlen #x8943 ) ;; Set the tx queue length + + +;;; ARP cache control calls. +;; 0x8950 - 0x8952 * obsolete calls, don't re-use +(defconstant siocdarp #x8953 ) ;; delete ARP table entry +(defconstant siocgarp #x8954 ) ;; get ARP table entry +(defconstant siocsarp #x8955 ) ;; set ARP table entry + +;;; RARP cache control calls. +(defconstant siocdrarp #x8960 ) ;; delete RARP table entry +(defconstant siocgrarp #x8961 ) ;; get RARP table entry +(defconstant siocsrarp #x8962 ) ;; set RARP table entry + +;;; Driver configuration calls + +(defconstant siocgifmap #x8970 ) ;; Get device parameters +(defconstant siocsifmap #x8971 ) ;; Set device parameters + +;;; DLCI configuration calls + +(defconstant siocadddlci #x8980 ) ;; Create new DLCI device +(defconstant siocdeldlci #x8981 ) ;; Delete DLCI device + +;;; Device private ioctl calls. + +;; These 16 ioctls are available to devices via the do_ioctl() device +;; vector. Each device should include this file and redefine these +;; names as their own. Because these are device dependent it is a good +;; idea _NOT_ to issue them to random objects and hope. + +(defconstant siocdevprivate #x89F0 ) ;; to 89FF + + +;;; netdb.h + +;; All data returned by the network data base library are supplied in +;; host order and returned in network order (suitable for use in +;; system calls). + +;;; Absolute file name for network data base files. +(defconstant path-hequiv "/etc/hosts.equiv") +(defconstant path-hosts "/etc/hosts") +(defconstant path-networks "/etc/networks") +(defconstant path-nsswitch_conf "/etc/nsswitch.conf") +(defconstant path-protocols "/etc/protocols") +(defconstant path-services "/etc/services") + + +;;; Possible values left in `h_errno'. +(defconstant netdb-internal -1 _N"See errno.") +(defconstant netdb-success 0 _N"No problem.") +(defconstant host-not-found 1 _N"Authoritative Answer Host not found.") +(defconstant try-again 2 _N"Non-Authoritative Host not found,or SERVERFAIL.") +(defconstant no-recovery 3 _N"Non recoverable errors, FORMERR, REFUSED, NOTIMP.") +(defconstant no-data 4 "Valid name, no data record of requested type.") +(defconstant no-address no-data "No address, look for MX record.") + +;;; Description of data base entry for a single host. + +(def-alien-type nil + (struct hostent + (h-name c-string) ; Official name of host. + (h-aliases (* c-string)) ; Alias list. + (h-addrtype int) ; Host address type. + (h_length int) ; Length of address. + (h-addr-list (* c-string)))) ; List of addresses from name server. + +#+(or) +(defun unix-sethostent (stay-open) + _N"Open host data base files and mark them as staying open even after +a later search if STAY_OPEN is non-zero." + (void-syscall ("sethostent" int) stay-open)) + +#+(or) +(defun unix-endhostent () + _N"Close host data base files and clear `stay open' flag." + (void-syscall ("endhostent"))) + +#+(or) +(defun unix-gethostent () + _N"Get next entry from host data base file. Open data base if +necessary." + (let ((result (alien-funcall (extern-alien "gethostent" + (function (* (struct hostent))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-gethostbyaddr(addr length type) + _N"Return entry from host data base which address match ADDR with +length LEN and type TYPE." + (let ((result (alien-funcall (extern-alien "gethostbyaddr" + (function (* (struct hostent)) + c-string int int)) + addr len type))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-gethostbyname (name) + _N"Return entry from host data base for host with NAME." + (let ((result (alien-funcall (extern-alien "gethostbyname" + (function (* (struct hostent)) + c-string)) + name))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-gethostbyname2 (name af) + _N"Return entry from host data base for host with NAME. AF must be + set to the address type which as `AF_INET' for IPv4 or `AF_INET6' + for IPv6." + (let ((result (alien-funcall (extern-alien "gethostbyname2" + (function (* (struct hostent)) + c-string int)) + name af))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;; Description of data base entry for a single network. NOTE: here a +;; poor assumption is made. The network number is expected to fit +;; into an unsigned long int variable. + +(def-alien-type nil + (struct netent + (n-name c-string) ; Official name of network. + (n-aliases (* c-string)) ; Alias list. + (n-addrtype int) ; Net address type. + (n-net unsigned-long))) ; Network number. + +#+(or) +(defun unix-setnetent (stay-open) + _N"Open network data base files and mark them as staying open even + after a later search if STAY_OPEN is non-zero." + (void-syscall ("setnetent" int) stay-open)) + + +#+(or) +(defun unix-endnetent () + _N"Close network data base files and clear `stay open' flag." + (void-syscall ("endnetent"))) + + +#+(or) +(defun unix-getnetent () + _N"Get next entry from network data base file. Open data base if + necessary." + (let ((result (alien-funcall (extern-alien "getnetent" + (function (* (struct netent))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + + +#+(or) +(defun unix-getnetbyaddr (net type) + _N"Return entry from network data base which address match NET and + type TYPE." + (let ((result (alien-funcall (extern-alien "getnetbyaddr" + (function (* (struct netent)) + unsigned-long int)) + net type))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getnetbyname (name) + _N"Return entry from network data base for network with NAME." + (let ((result (alien-funcall (extern-alien "getnetbyname" + (function (* (struct netent)) + c-string)) + name))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;; Description of data base entry for a single service. +(def-alien-type nil + (struct servent + (s-name c-string) ; Official service name. + (s-aliases (* c-string)) ; Alias list. + (s-port int) ; Port number. + (s-proto c-string))) ; Protocol to use. + +#+(or) +(defun unix-setservent (stay-open) + _N"Open service data base files and mark them as staying open even + after a later search if STAY_OPEN is non-zero." + (void-syscall ("setservent" int) stay-open)) + +#+(or) +(defun unix-endservent (stay-open) + _N"Close service data base files and clear `stay open' flag." + (void-syscall ("endservent"))) + + +#+(or) +(defun unix-getservent () + _N"Get next entry from service data base file. Open data base if + necessary." + (let ((result (alien-funcall (extern-alien "getservent" + (function (* (struct servent))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getservbyname (name proto) + _N"Return entry from network data base for network with NAME and + protocol PROTO." + (let ((result (alien-funcall (extern-alien "getservbyname" + (function (* (struct netent)) + c-string (* char))) + name proto))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getservbyport (port proto) + _N"Return entry from service data base which matches port PORT and + protocol PROTO." + (let ((result (alien-funcall (extern-alien "getservbyport" + (function (* (struct netent)) + int (* char))) + port proto))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;; Description of data base entry for a single service. + +(def-alien-type nil + (struct protoent + (p-name c-string) ; Official protocol name. + (p-aliases (* c-string)) ; Alias list. + (p-proto int))) ; Protocol number. + +#+(or) +(defun unix-setprotoent (stay-open) + _N"Open protocol data base files and mark them as staying open even + after a later search if STAY_OPEN is non-zero." + (void-syscall ("setprotoent" int) stay-open)) + +#+(or) +(defun unix-endprotoent () + _N"Close protocol data base files and clear `stay open' flag." + (void-syscall ("endprotoent"))) + +#+(or) +(defun unix-getprotoent () + _N"Get next entry from protocol data base file. Open data base if + necessary." + (let ((result (alien-funcall (extern-alien "getprotoent" + (function (* (struct protoent))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getprotobyname (name) + _N"Return entry from protocol data base for network with NAME." + (let ((result (alien-funcall (extern-alien "getprotobyname" + (function (* (struct protoent)) + c-string)) + name))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getprotobynumber (proto) + _N"Return entry from protocol data base which number is PROTO." + (let ((result (alien-funcall (extern-alien "getprotobynumber" + (function (* (struct protoent)) + int)) + proto))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-setnetgrent (netgroup) + _N"Establish network group NETGROUP for enumeration." + (int-syscall ("setservent" c-string) netgroup)) + +#+(or) +(defun unix-endnetgrent () + _N"Free all space allocated by previous `setnetgrent' call." + (void-syscall ("endnetgrent"))) + +#+(or) +(defun unix-getnetgrent (hostp userp domainp) + _N"Get next member of netgroup established by last `setnetgrent' call + and return pointers to elements in HOSTP, USERP, and DOMAINP." + (int-syscall ("getnetgrent" (* c-string) (* c-string) (* c-string)) + hostp userp domainp)) + +#+(or) +(defun unix-innetgr (netgroup host user domain) + _N"Test whether NETGROUP contains the triple (HOST,USER,DOMAIN)." + (int-syscall ("innetgr" c-string c-string c-string c-string) + netgroup host user domain)) + +(def-alien-type nil + (struct addrinfo + (ai-flags int) ; Input flags. + (ai-family int) ; Protocol family for socket. + (ai-socktype int) ; Socket type. + (ai-protocol int) ; Protocol for socket. + (ai-addrlen int) ; Length of socket address. + (ai-addr (* (struct sockaddr))) + ; Socket address for socket. + (ai-cononname c-string) + ; Canonical name for service location. + (ai-net (* (struct addrinfo))))) ; Pointer to next in list. + +;; Possible values for `ai_flags' field in `addrinfo' structure. + +(defconstant ai_passive 1 _N"Socket address is intended for `bind'.") +(defconstant ai_canonname 2 _N"Request for canonical name.") + +;; Error values for `getaddrinfo' function. +(defconstant eai_badflags -1 _N"Invalid value for `ai_flags' field.") +(defconstant eai_noname -2 _N"NAME or SERVICE is unknown.") +(defconstant eai_again -3 _N"Temporary failure in name resolution.") +(defconstant eai_fail -4 _N"Non-recoverable failure in name res.") +(defconstant eai_nodata -5 _N"No address associated with NAME.") +(defconstant eai_family -6 _N"ai_family not supported.") +(defconstant eai_socktype -7 _N"ai_socktype not supported.") +(defconstant eai_service -8 _N"SERVICE not supported for ai_socktype.") +(defconstant eai_addrfamily -9 _N"Address family for NAME not supported.") +(defconstant eai_memory -10 _N"Memory allocation failure.") +(defconstant eai_system -11 _N"System error returned in errno.") + + +#+(or) +(defun unix-getaddrinfo (name service req pai) + _N"Translate name of a service location and/or a service name to set of + socket addresses." + (int-syscall ("getaddrinfo" c-string c-string (* (struct addrinfo)) + (* (* struct addrinfo))) + name service req pai)) + + +#+(or) +(defun unix-freeaddrinfo (ai) + _N"Free `addrinfo' structure AI including associated storage." + (void-syscall ("freeaddrinfo" (* struct addrinfo)) + ai)) + + +;;; pty.h + +(defun unix-openpty (name termp winp) + _N"Create pseudo tty master slave pair with NAME and set terminal + attributes according to TERMP and WINP and return handles for both + ends in AMASTER and ASLAVE." + (with-alien ((amaster int) + (aslave int)) + (values + (int-syscall ("openpty" (* int) (* int) c-string (* (struct termios)) + (* (struct winsize))) + (addr amaster) (addr aslave) name termp winp) + amaster aslave))) + +#+(or) +(defun unix-forkpty (amaster name termp winp) + _N"Create child process and establish the slave pseudo terminal as the + child's controlling terminal." + (int-syscall ("forkpty" (* int) c-string (* (struct termios)) + (* (struct winsize))) + amaster name termp winp)) + + +;; POSIX Standard: 9.2.2 User Database Access <pwd.h> + +#+(or) +(defun unix-setpwent () + _N"Rewind the password-file stream." + (void-syscall ("setpwent"))) + +#+(or) +(defun unix-endpwent () + _N"Close the password-file stream." + (void-syscall ("endpwent"))) + +#+(or) +(defun unix-getpwent () + _N"Read an entry from the password-file stream, opening it if necessary." + (let ((result (alien-funcall (extern-alien "getpwent" + (function (* (struct passwd))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;;; resourcebits.h + +(def-alien-type nil + (struct rlimit + (rlim-cur long) ; current (soft) limit + (rlim-max long))); maximum value for rlim-cur + +(defconstant rusage_self 0 _N"The calling process.") +(defconstant rusage_children -1 _N"Terminated child processes.") +(defconstant rusage_both -2) + +(def-alien-type nil + (struct rusage + (ru-utime (struct timeval)) ; user time used + (ru-stime (struct timeval)) ; system time used. + (ru-maxrss long) ; Maximum resident set size (in kilobytes) + (ru-ixrss long) ; integral shared memory size + (ru-idrss long) ; integral unshared data " + (ru-isrss long) ; integral unshared stack " + (ru-minflt long) ; page reclaims + (ru-majflt long) ; page faults + (ru-nswap long) ; swaps + (ru-inblock long) ; block input operations + (ru-oublock long) ; block output operations + (ru-msgsnd long) ; messages sent + (ru-msgrcv long) ; messages received + (ru-nsignals long) ; signals received + (ru-nvcsw long) ; voluntary context switches + (ru-nivcsw long))) ; involuntary " + +;; Priority limits. + +(defconstant prio-min -20 _N"Minimum priority a process can have") +(defconstant prio-max 20 _N"Maximum priority a process can have") + + +;;; The type of the WHICH argument to `getpriority' and `setpriority', +;;; indicating what flavor of entity the WHO argument specifies. + +(defconstant priority-process 0 _N"WHO is a process ID") +(defconstant priority-pgrp 1 _N"WHO is a process group ID") +(defconstant priority-user 2 _N"WHO is a user ID") + +;;; sched.h + +#+(or) +(defun unix-sched_setparam (pid param) + _N"Rewind the password-file stream." + (int-syscall ("sched_setparam" pid-t (struct psched-param)) + pid param)) + +#+(or) +(defun unix-sched_getparam (pid param) + _N"Rewind the password-file stream." + (int-syscall ("sched_getparam" pid-t (struct psched-param)) + pid param)) + + +#+(or) +(defun unix-sched_setscheduler (pid policy param) + _N"Set scheduling algorithm and/or parameters for a process." + (int-syscall ("sched_setscheduler" pid-t int (struct psched-param)) + pid policy param)) + +#+(or) +(defun unix-sched_getscheduler (pid) + _N"Retrieve scheduling algorithm for a particular purpose." + (int-syscall ("sched_getscheduler" pid-t) + pid)) + +(defun unix-sched-yield () + _N"Retrieve scheduling algorithm for a particular purpose." + (int-syscall ("sched_yield"))) + +#+(or) +(defun unix-sched_get_priority_max (algorithm) + _N"Get maximum priority value for a scheduler." + (int-syscall ("sched_get_priority_max" int) + algorithm)) + +#+(or) +(defun unix-sched_get_priority_min (algorithm) + _N"Get minimum priority value for a scheduler." + (int-syscall ("sched_get_priority_min" int) + algorithm)) + + + +#+(or) +(defun unix-sched_rr_get_interval (pid t) + _N"Get the SCHED_RR interval for the named process." + (int-syscall ("sched_rr_get_interval" pid-t (* (struct timespec))) + pid t)) + +;;; schedbits.h + +(defconstant scheduler-other 0) +(defconstant scheduler-fifo 1) +(defconstant scheduler-rr 2) + + +;; Data structure to describe a process' schedulability. + +(def-alien-type nil + (struct sched_param + (sched-priority int))) + +;; Cloning flags. +(defconstant csignal #x000000ff _N"Signal mask to be sent at exit.") +(defconstant clone_vm #x00000100 _N"Set if VM shared between processes.") +(defconstant clone_fs #x00000200 _N"Set if fs info shared between processes") +(defconstant clone_files #x00000400 _N"Set if open files shared between processe") +(defconstant clone_sighand #x00000800 _N"Set if signal handlers shared.") +(defconstant clone_pid #x00001000 _N"Set if pid shared.") + + +;;; shadow.h + +;; Structure of the password file. + +(def-alien-type nil + (struct spwd + (sp-namp c-string) ; Login name. + (sp-pwdp c-string) ; Encrypted password. + (sp-lstchg long) ; Date of last change. + (sp-min long) ; Minimum number of days between changes. + (sp-max long) ; Maximum number of days between changes. + (sp-warn long) ; Number of days to warn user to change the password. + (sp-inact long) ; Number of days the account may be inactive. + (sp-expire long) ; Number of days since 1970-01-01 until account expires. + (sp-flags long))) ; Reserved. + +#+(or) +(defun unix-setspent () + _N"Open database for reading." + (void-syscall ("setspent"))) + +#+(or) +(defun unix-endspent () + _N"Close database." + (void-syscall ("endspent"))) + +#+(or) +(defun unix-getspent () + _N"Get next entry from database, perhaps after opening the file." + (let ((result (alien-funcall (extern-alien "getspent" + (function (* (struct spwd))))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-getspnam (name) + _N"Get shadow entry matching NAME." + (let ((result (alien-funcall (extern-alien "getspnam" + (function (* (struct spwd)) + c-string)) + name))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +#+(or) +(defun unix-sgetspent (string) + _N"Read shadow entry from STRING." + (let ((result (alien-funcall (extern-alien "sgetspent" + (function (* (struct spwd)) + c-string)) + string))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +;; + +#+(or) +(defun unix-lckpwdf () + _N"Protect password file against multi writers." + (void-syscall ("lckpwdf"))) + + +#+(or) +(defun unix-ulckpwdf () + _N"Unlock password file." + (void-syscall ("ulckpwdf"))) + +;;; bits/stat.h + +(def-alien-type nil + (struct stat + (st-dev dev-t) + #-(or alpha amd64) (st-pad1 unsigned-short) + (st-ino ino-t) + #+alpha (st-pad1 unsigned-int) + #-amd64 (st-mode mode-t) + (st-nlink nlink-t) + #+amd64 (st-mode mode-t) + (st-uid uid-t) + (st-gid gid-t) + (st-rdev dev-t) + #-alpha (st-pad2 unsigned-short) + (st-size off-t) + #-alpha (st-blksize unsigned-long) + #-alpha (st-blocks blkcnt-t) + (st-atime time-t) + #-alpha (unused-1 unsigned-long) + (st-mtime time-t) + #-alpha (unused-2 unsigned-long) + (st-ctime time-t) + #+alpha (st-blocks int) + #+alpha (st-pad2 unsigned-int) + #+alpha (st-blksize unsigned-int) + #+alpha (st-flags unsigned-int) + #+alpha (st-gen unsigned-int) + #+alpha (st-pad3 unsigned-int) + #+alpha (unused-1 unsigned-long) + #+alpha (unused-2 unsigned-long) + (unused-3 unsigned-long) + (unused-4 unsigned-long) + #-alpha (unused-5 unsigned-long))) + +;; Encoding of the file mode. + +(defconstant s-ifmt #o0170000 _N"These bits determine file type.") + +;; File types. + +(defconstant s-ififo #o0010000 _N"FIFO") +(defconstant s-ifchr #o0020000 _N"Character device") +(defconstant s-ifdir #o0040000 _N"Directory") +(defconstant s-ifblk #o0060000 _N"Block device") +(defconstant s-ifreg #o0100000 _N"Regular file") + +;; These don't actually exist on System V, but having them doesn't hurt. + +(defconstant s-iflnk #o0120000 _N"Symbolic link.") +(defconstant s-ifsock #o0140000 _N"Socket.") + +;; Protection bits. + +(defconstant s-isuid #o0004000 _N"Set user ID on execution.") +(defconstant s-isgid #o0002000 _N"Set group ID on execution.") +(defconstant s-isvtx #o0001000 _N"Save swapped text after use (sticky).") +(defconstant s-iread #o0000400 _N"Read by owner") +(defconstant s-iwrite #o0000200 _N"Write by owner.") +(defconstant s-iexec #o0000100 _N"Execute by owner.") + +;;; statfsbuf.h + +(def-alien-type nil + (struct statfs + (f-type int) + (f-bsize int) + (f-blocks fsblkcnt-t) + (f-bfree fsblkcnt-t) + (f-bavail fsblkcnt-t) + (f-files fsfilcnt-t) + (f-ffree fsfilcnt-t) + (f-fsid fsid-t) + (f-namelen int) + (f-spare (array int 6)))) + + +;;; termbits.h + +(def-alien-type cc-t unsigned-char) +(def-alien-type speed-t unsigned-int) +(def-alien-type tcflag-t unsigned-int) + +(defconstant +NCCS+ 32 + _N"Size of control character vector.") + +(def-alien-type nil + (struct termios + (c-iflag tcflag-t) + (c-oflag tcflag-t) + (c-cflag tcflag-t) + (c-lflag tcflag-t) + (c-line cc-t) + (c-cc (array cc-t #.+NCCS+)) + (c-ispeed speed-t) + (c-ospeed speed-t))) + +;; c_cc characters + +(def-enum + 0 vintr vquit verase + vkill veof vtime + vmin vswtc vstart + vstop vsusp veol + vreprint vdiscard vwerase + vlnext veol2) +(defvar vdsusp vsusp) + +(def-enum + 0 tciflush tcoflush tcioflush) + +(def-enum + 0 tcsanow tcsadrain tcsaflush) + +;; c_iflag bits +(def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck + tty-istrip tty-inlcr tty-igncr tty-icrnl tty-iuclc + tty-ixon tty-ixany tty-ixoff + tty-imaxbel) + +;; c_oflag bits +(def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr + tty-onlret tty-ofill tty-ofdel tty-nldly) + +(defconstant tty-nl0 0) +(defconstant tty-nl1 #o400) + +(defconstant tty-crdly #o0003000) +(defconstant tty-cr0 #o0000000) +(defconstant tty-cr1 #o0001000) +(defconstant tty-cr2 #o0002000) +(defconstant tty-cr3 #o0003000) +(defconstant tty-tabdly #o0014000) +(defconstant tty-tab0 #o0000000) +(defconstant tty-tab1 #o0004000) +(defconstant tty-tab2 #o0010000) +(defconstant tty-tab3 #o0014000) +(defconstant tty-xtabs #o0014000) +(defconstant tty-bsdly #o0020000) +(defconstant tty-bs0 #o0000000) +(defconstant tty-bs1 #o0020000) +(defconstant tty-vtdly #o0040000) +(defconstant tty-vt0 #o0000000) +(defconstant tty-vt1 #o0040000) +(defconstant tty-ffdly #o0100000) +(defconstant tty-ff0 #o0000000) +(defconstant tty-ff1 #o0100000) + +;; c-cflag bit meaning +(defconstant tty-cbaud #o0010017) +(defconstant tty-b0 #o0000000) ;; hang up +(defconstant tty-b50 #o0000001) +(defconstant tty-b75 #o0000002) +(defconstant tty-b110 #o0000003) +(defconstant tty-b134 #o0000004) +(defconstant tty-b150 #o0000005) +(defconstant tty-b200 #o0000006) +(defconstant tty-b300 #o0000007) +(defconstant tty-b600 #o0000010) +(defconstant tty-b1200 #o0000011) +(defconstant tty-b1800 #o0000012) +(defconstant tty-b2400 #o0000013) +(defconstant tty-b4800 #o0000014) +(defconstant tty-b9600 #o0000015) +(defconstant tty-b19200 #o0000016) +(defconstant tty-b38400 #o0000017) +(defconstant tty-exta tty-b19200) +(defconstant tty-extb tty-b38400) +(defconstant tty-csize #o0000060) +(defconstant tty-cs5 #o0000000) +(defconstant tty-cs6 #o0000020) +(defconstant tty-cs7 #o0000040) +(defconstant tty-cs8 #o0000060) +(defconstant tty-cstopb #o0000100) +(defconstant tty-cread #o0000200) +(defconstant tty-parenb #o0000400) +(defconstant tty-parodd #o0001000) +(defconstant tty-hupcl #o0002000) +(defconstant tty-clocal #o0004000) +(defconstant tty-cbaudex #o0010000) +(defconstant tty-b57600 #o0010001) +(defconstant tty-b115200 #o0010002) +(defconstant tty-b230400 #o0010003) +(defconstant tty-b460800 #o0010004) +(defconstant tty-cibaud #o002003600000) ; input baud rate (not used) +(defconstant tty-crtscts #o020000000000) ;flow control + +;; c_lflag bits +(def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe + tty-echok tty-echonl tty-noflsh + tty-tostop tty-echoctl tty-echoprt + tty-echoke tty-flusho + tty-pendin tty-iexten) + +;;; tcflow() and TCXONC use these +(def-enum + 0 tty-tcooff tty-tcoon tty-tcioff tty-tcion) + +;; tcflush() and TCFLSH use these */ +(def-enum + 0 tty-tciflush tty-tcoflush tty-tcioflush) + +;; tcsetattr uses these +(def-enum + 0 tty-tcsanow tty-tcsadrain tty-tcsaflush) + +;;; termios.h + +(defun unix-cfgetospeed (termios) + _N"Get terminal output speed." + (multiple-value-bind (speed errno) + (int-syscall ("cfgetospeed" (* (struct termios))) termios) + (if speed + (values (svref terminal-speeds speed) 0) + (values speed errno)))) + +(defun unix-cfsetospeed (termios speed) + _N"Set terminal output speed." + (let ((baud (or (position speed terminal-speeds) + (error _"Bogus baud rate ~S" speed)))) + (void-syscall ("cfsetospeed" (* (struct termios)) int) termios baud))) + +(defun unix-cfgetispeed (termios) + _N"Get terminal input speed." + (multiple-value-bind (speed errno) + (int-syscall ("cfgetispeed" (* (struct termios))) termios) + (if speed + (values (svref terminal-speeds speed) 0) + (values speed errno)))) + +(defun unix-cfsetispeed (termios speed) + _N"Set terminal input speed." + (let ((baud (or (position speed terminal-speeds) + (error _"Bogus baud rate ~S" speed)))) + (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud))) + +(defun unix-tcgetattr (fd termios) + _N"Get terminal attributes." + (declare (type unix-fd fd)) + (void-syscall ("tcgetattr" int (* (struct termios))) fd termios)) + +(defun unix-tcsetattr (fd opt termios) + _N"Set terminal attributes." + (declare (type unix-fd fd)) + (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios)) + +(defun unix-tcsendbreak (fd duration) + _N"Send break" + (declare (type unix-fd fd)) + (void-syscall ("tcsendbreak" int int) fd duration)) + +(defun unix-tcdrain (fd) + _N"Wait for output for finish" + (declare (type unix-fd fd)) + (void-syscall ("tcdrain" int) fd)) + +(defun unix-tcflush (fd selector) + _N"See tcflush(3)" + (declare (type unix-fd fd)) + (void-syscall ("tcflush" int int) fd selector)) + +(defun unix-tcflow (fd action) + _N"Flow control" + (declare (type unix-fd fd)) + (void-syscall ("tcflow" int int) fd action)) + +;;; timebits.h + +;; A time value that is accurate to the nearest +;; microsecond but also has a range of years. +(def-alien-type nil + (struct timeval + (tv-sec time-t) ; seconds + (tv-usec time-t))) ; and microseconds + +;;; unistd.h + +(defun sub-unix-execve (program arg-list env-list) + (let ((argv nil) + (argv-bytes 0) + (envp nil) + (envp-bytes 0) + result error-code) + (unwind-protect + (progn + ;; Blast the stuff into the proper format + (multiple-value-setq + (argv argv-bytes) + (string-list-to-c-strvec arg-list)) + (multiple-value-setq + (envp envp-bytes) + (string-list-to-c-strvec env-list)) + ;; + ;; Now do the system call + (multiple-value-setq + (result error-code) + (int-syscall ("execve" + c-string system-area-pointer system-area-pointer) + program argv envp))) + ;; + ;; Deallocate memory + (when argv + (system:deallocate-system-memory argv argv-bytes)) + (when envp + (system:deallocate-system-memory envp envp-bytes))) + (values result error-code))) + +;;;; UNIX-EXECVE + +(defun unix-execve (program &optional arg-list + (environment *environment-list*)) + _N"Executes the Unix execve system call. If the system call suceeds, lisp + will no longer be running in this process. If the system call fails this + function returns two values: NIL and an error code. Arg-list should be a + list of simple-strings which are passed as arguments to the exec'ed program. + Environment should be an a-list mapping symbols to simple-strings which this + function bashes together to form the environment for the exec'ed program." + (check-type program simple-string) + (let ((env-list (let ((envlist nil)) + (dolist (cons environment) + (push (if (cdr cons) + (concatenate 'simple-string + (string (car cons)) "=" + (cdr cons)) + (car cons)) + envlist)) + envlist))) + (sub-unix-execve (%name->file program) arg-list env-list))) + + +(defmacro round-bytes-to-words (n) + `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3))) + +;; Values for the second argument to access. + +;;; Unix-access accepts a path and a mode. It returns two values the +;;; first is T if the file is accessible and NIL otherwise. The second +;;; only has meaning in the second case and is the unix errno value. + +(defun unix-access (path mode) + _N"Given a file path (a string) and one of four constant modes, + unix-access returns T if the file is accessible with that + mode and NIL if not. It also returns an errno value with + NIL which determines why the file was not accessible. + + The access modes are: + r_ok Read permission. + w_ok Write permission. + x_ok Execute permission. + f_ok Presence of file." + (declare (type unix-pathname path) + (type (mod 8) mode)) + (void-syscall ("access" c-string int) (%name->file path) mode)) + +(defconstant l_set 0 _N"set the file pointer") +(defconstant l_incr 1 _N"increment the file pointer") +(defconstant l_xtnd 2 _N"extend the file size") + +(defun unix-lseek (fd offset whence) + _N"UNIX-LSEEK accepts a file descriptor and moves the file pointer ahead + a certain OFFSET for that file. WHENCE can be any of the following: + + l_set Set the file pointer. + l_incr Increment the file pointer. + l_xtnd Extend the file size. + " + (declare (type unix-fd fd) + (type (signed-byte 64) offset) + (type (integer 0 2) whence)) + (let ((result (alien-funcall + (extern-alien "lseek64" (function off-t int off-t int)) + fd offset whence))) + (if (minusp result) + (values nil (unix-errno)) + (values result 0)))) + + +;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read. +;;; It attempts to read len bytes from the device associated with fd +;;; and store them into the buffer. It returns the actual number of +;;; bytes read. + +(defun unix-read (fd buf len) + _N"UNIX-READ attempts to read from the file described by fd into + the buffer buf until it is full. Len is the length of the buffer. + The number of bytes actually read is returned or NIL and an error + number if an error occured." + (declare (type unix-fd fd) + (type (unsigned-byte 32) len)) + #+gencgc + ;; With gencgc, the collector tries to keep raw objects like strings + ;; in separate pages that are not write-protected. However, this + ;; isn't always true. Thus, BUF will sometimes be write-protected + ;; and the kernel doesn't like writing to write-protected pages. So + ;; go through and touch each page to give the segv handler a chance + ;; to unprotect the pages. (This is taken from unix.lisp.) + (without-gcing + (let* ((page-size (get-page-size)) + (1-page-size (1- page-size)) + (sap (etypecase buf + (system-area-pointer buf) + (vector (vector-sap buf)))) + (end (sap+ sap len))) + (declare (type (and fixnum unsigned-byte) page-size 1-page-size) + (type system-area-pointer sap end) + (optimize (speed 3) (safety 0))) + ;; Touch the beginning of every page + (do ((sap (int-sap (logand (sap-int sap) + (logxor 1-page-size (ldb (byte 32 0) -1)))) + (sap+ sap page-size))) + ((sap>= sap end)) + (declare (type system-area-pointer sap)) + (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0))))) + (int-syscall ("read" int (* char) int) fd buf len)) + + +;;; Unix-write accepts a file descriptor, a buffer, an offset, and the +;;; length to write. It attempts to write len bytes to the device +;;; associated with fd from the the buffer starting at offset. It returns +;;; the actual number of bytes written. + +(defun unix-write (fd buf offset len) + _N"Unix-write attempts to write a character buffer (buf) of length + len to the file described by the file descriptor fd. NIL and an + error is returned if the call is unsuccessful." + (declare (type unix-fd fd) + (type (unsigned-byte 32) offset len)) + (int-syscall ("write" int (* char) int) + fd + (with-alien ((ptr (* char) (etypecase buf + ((simple-array * (*)) + (vector-sap buf)) + (system-area-pointer + buf)))) + (addr (deref ptr offset))) + len)) + +(defun unix-pipe () + _N"Unix-pipe sets up a unix-piping mechanism consisting of + an input pipe and an output pipe. Unix-Pipe returns two + values: if no error occurred the first value is the pipe + to be read from and the second is can be written to. If + an error occurred the first value is NIL and the second + the unix error code." + (with-alien ((fds (array int 2))) + (syscall ("pipe" (* int)) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int))))) + + +(defun unix-chown (path uid gid) + _N"Given a file path, an integer user-id, and an integer group-id, + unix-chown changes the owner of the file and the group of the + file to those specified. Either the owner or the group may be + left unchanged by specifying them as -1. Note: Permission will + fail if the caller is not the superuser." + (declare (type unix-pathname path) + (type (or unix-uid (integer -1 -1)) uid) + (type (or unix-gid (integer -1 -1)) gid)) + (void-syscall ("chown" c-string int int) (%name->file path) uid gid)) + +;;; Unix-fchown is exactly the same as unix-chown except that the file +;;; is specified by a file-descriptor ("fd") instead of a pathname. + +(defun unix-fchown (fd uid gid) + _N"Unix-fchown is like unix-chown, except that it accepts an integer + file descriptor instead of a file path name." + (declare (type unix-fd fd) + (type (or unix-uid (integer -1 -1)) uid) + (type (or unix-gid (integer -1 -1)) gid)) + (void-syscall ("fchown" int int int) fd uid gid)) + +;;; Unix-chdir accepts a directory name and makes that the +;;; current working directory. + +(defun unix-chdir (path) + _N"Given a file path string, unix-chdir changes the current working + directory to the one specified." + (declare (type unix-pathname path)) + (void-syscall ("chdir" c-string) (%name->file path))) + +(defun unix-current-directory () + _N"Put the absolute pathname of the current working directory in BUF. + If successful, return BUF. If not, put an error message in + BUF and return NULL. BUF should be at least PATH_MAX bytes long." + ;; 5120 is some randomly selected maximum size for the buffer for getcwd. + (with-alien ((buf (array c-call:char 5120))) + (let ((result (alien-funcall + (extern-alien "getcwd" + (function (* c-call:char) + (* c-call:char) c-call:int)) + (cast buf (* c-call:char)) + 5120))) + + (values (not (zerop (sap-int (alien-sap result)))) + (%file->name (cast buf c-call:c-string)))))) + + +;;; Unix-dup returns a duplicate copy of the existing file-descriptor +;;; passed as an argument. + +(defun unix-dup (fd) + _N"Unix-dup duplicates an existing file descriptor (given as the + argument) and return it. If FD is not a valid file descriptor, NIL + and an error number are returned." + (declare (type unix-fd fd)) + (int-syscall ("dup" int) fd)) + +;;; Unix-dup2 makes the second file-descriptor describe the same file +;;; as the first. If the second file-descriptor points to an open +;;; file, it is first closed. In any case, the second should have a +;;; value which is a valid file-descriptor. + +(defun unix-dup2 (fd1 fd2) + _N"Unix-dup2 duplicates an existing file descriptor just as unix-dup + does only the new value of the duplicate descriptor may be requested + through the second argument. If a file already exists with the + requested descriptor number, it will be closed and the number + assigned to the duplicate." + (declare (type unix-fd fd1 fd2)) + (void-syscall ("dup2" int int) fd1 fd2)) + +;;; Unix-exit terminates a program. + +(defun unix-exit (&optional (code 0)) + _N"Unix-exit terminates the current process with an optional + error code. If successful, the call doesn't return. If + unsuccessful, the call returns NIL and an error number." + (declare (type (signed-byte 32) code)) + (void-syscall ("exit" int) code)) + +#+(or) +(defun unix-pathconf (path name) + _N"Get file-specific configuration information about PATH." + (int-syscall ("pathconf" c-string int) (%name->file path) name)) + +#+(or) +(defun unix-sysconf (name) + _N"Get the value of the system variable NAME." + (int-syscall ("sysconf" int) name)) + +#+(or) +(defun unix-confstr (name) + _N"Get the value of the string-valued system variable NAME." + (with-alien ((buf (array char 1024))) + (values (not (zerop (alien-funcall (extern-alien "confstr" + (function int + c-string + size-t)) + name buf 1024))) + (cast buf c-string)))) + + +(def-alien-routine ("getpid" unix-getpid) int + _N"Unix-getpid returns the process-id of the current process.") + +(def-alien-routine ("getppid" unix-getppid) int + _N"Unix-getppid returns the process-id of the parent of the current process.") + +;;; Unix-getpgrp returns the group-id associated with the +;;; current process. + +(defun unix-getpgrp () + _N"Unix-getpgrp returns the group-id of the calling process." + (int-syscall ("getpgrp"))) + +;;; Unix-setpgid sets the group-id of the process specified by +;;; "pid" to the value of "pgrp". The process must either have +;;; the same effective user-id or be a super-user process. + +;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained +;;; for backward compatibility. setpgrp(void)[solaris] is being phased +;;; out in favor of setsid(). + +(defun unix-setpgrp (pid pgrp) + _N"Unix-setpgrp sets the process group on the process pid to + pgrp. NIL and an error number are returned upon failure." + (void-syscall ("setpgid" int int) pid pgrp)) + +(defun unix-setpgid (pid pgrp) + _N"Unix-setpgid sets the process group of the process pid to + pgrp. If pgid is equal to pid, the process becomes a process + group leader. NIL and an error number are returned upon failure." + (void-syscall ("setpgid" int int) pid pgrp)) + +#+(or) +(defun unix-setsid () + _N"Create a new session with the calling process as its leader. + The process group IDs of the session and the calling process + are set to the process ID of the calling process, which is returned." + (void-syscall ( "setsid"))) + +#+(or) +(defun unix-getsid () + _N"Return the session ID of the given process." + (int-syscall ( "getsid"))) + +(def-alien-routine ("getuid" unix-getuid) int + _N"Unix-getuid returns the real user-id associated with the + current process.") + +#+(or) +(def-alien-routine ("geteuid" unix-getuid) int + _N"Get the effective user ID of the calling process.") + +(def-alien-routine ("getgid" unix-getgid) int + _N"Unix-getgid returns the real group-id of the current process.") + +(def-alien-routine ("getegid" unix-getegid) int + _N"Unix-getegid returns the effective group-id of the current process.") + +;/* If SIZE is zero, return the number of supplementary groups +; the calling process is in. Otherwise, fill in the group IDs +; of its supplementary groups in LIST and return the number written. */ +;extern int getgroups __P ((int __size, __gid_t __list[])); + +#+(or) +(defun unix-group-member (gid) + _N"Return nonzero iff the calling process is in group GID." + (int-syscall ( "group-member" gid-t) gid)) + + +(defun unix-setuid (uid) + _N"Set the user ID of the calling process to UID. + If the calling process is the super-user, set the real + and effective user IDs, and the saved set-user-ID to UID; + if not, the effective user ID is set to UID." + (int-syscall ("setuid" uid-t) uid)) + +;;; Unix-setreuid sets the real and effective user-id's of the current +;;; process to the arguments "ruid" and "euid", respectively. Usage is +;;; restricted for anyone but the super-user. Setting either "ruid" or +;;; "euid" to -1 makes the system use the current id instead. + +(defun unix-setreuid (ruid euid) + _N"Unix-setreuid sets the real and effective user-id's of the current + process to the specified ones. NIL and an error number is returned + if the call fails." + (void-syscall ("setreuid" int int) ruid euid)) + +(defun unix-setgid (gid) + _N"Set the group ID of the calling process to GID. + If the calling process is the super-user, set the real + and effective group IDs, and the saved set-group-ID to GID; + if not, the effective group ID is set to GID." + (int-syscall ("setgid" gid-t) gid)) + + +;;; Unix-setregid sets the real and effective group-id's of the current +;;; process to the arguments "rgid" and "egid", respectively. Usage is +;;; restricted for anyone but the super-user. Setting either "rgid" or +;;; "egid" to -1 makes the system use the current id instead. + +(defun unix-setregid (rgid egid) + _N"Unix-setregid sets the real and effective group-id's of the current + process process to the specified ones. NIL and an error number is + returned if the call fails." + (void-syscall ("setregid" int int) rgid egid)) + +(defun unix-fork () + _N"Executes the unix fork system call. Returns 0 in the child and the pid + of the child in the parent if it works, or NIL and an error number if it + doesn't work." + (int-syscall ("fork"))) + +;; Environment maninpulation; man getenv(3) +(def-alien-routine ("getenv" unix-getenv) c-call:c-string + (name c-call:c-string) + _N"Get the value of the environment variable named Name. If no such + variable exists, Nil is returned.") + +(def-alien-routine ("setenv" unix-setenv) c-call:int + (name c-call:c-string) + (value c-call:c-string) + (overwrite c-call:int) + _N"Adds the environment variable named Name to the environment with + the given Value if Name does not already exist. If Name does exist, + the value is changed to Value if Overwrite is non-zero. Otherwise, + the value is not changed.") + +(def-alien-routine ("putenv" unix-putenv) c-call:int + (name c-call:c-string) + _N"Adds or changes the environment. Name-value must be a string of + the form \"name=value\". If the name does not exist, it is added. + If name does exist, the value is updated to the given value.") + +(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int + (name c-call:c-string) + _N"Removes the variable Name from the environment") + +(def-alien-routine ("ttyname" unix-ttyname) c-string + (fd int)) + +(def-alien-routine ("isatty" unix-isatty) boolean + _N"Accepts a Unix file descriptor and returns T if the device + associated with it is a terminal." + (fd int)) + +;;; Unix-link creates a hard link from name2 to name1. + +(defun unix-link (name1 name2) + _N"Unix-link creates a hard link from the file with name1 to the + file with name2." + (declare (type unix-pathname name1 name2)) + (void-syscall ("link" c-string c-string) + (%name->file name1) (%name->file name2))) + +(defun unix-symlink (name1 name2) + _N"Unix-symlink creates a symbolic link named name2 to the file + named name1. NIL and an error number is returned if the call + is unsuccessful." + (declare (type unix-pathname name1 name2)) + (void-syscall ("symlink" c-string c-string) + (%name->file name1) (%name->file name2))) + +(defun unix-readlink (path) + _N"Unix-readlink invokes the readlink system call on the file name + specified by the simple string path. It returns up to two values: + the contents of the symbolic link if the call is successful, or + NIL and the Unix error number." + (declare (type unix-pathname path)) + (with-alien ((buf (array char 1024))) + (syscall ("readlink" c-string (* char) int) + (let ((string (make-string result))) + #-unicode + (kernel:copy-from-system-area + (alien-sap buf) 0 + string (* vm:vector-data-offset vm:word-bits) + (* result vm:byte-bits)) + #+unicode + (let ((sap (alien-sap buf))) + (dotimes (k result) + (setf (aref string k) (code-char (sap-ref-8 sap k))))) + (%file->name string)) + (%name->file path) (cast buf (* char)) 1024))) + +;;; Unix-unlink accepts a name and deletes the directory entry for that +;;; name and the file if this is the last link. + +(defun unix-unlink (name) + _N"Unix-unlink removes the directory entry for the named file. + NIL and an error code is returned if the call fails." + (declare (type unix-pathname name)) + (void-syscall ("unlink" c-string) (%name->file name))) + +;;; Unix-rmdir accepts a name and removes the associated directory. + +(defun unix-rmdir (name) + _N"Unix-rmdir attempts to remove the directory name. NIL and + an error number is returned if an error occured." + (declare (type unix-pathname name)) + (void-syscall ("rmdir" c-string) (%name->file name))) + +(defun tcgetpgrp (fd) + _N"Get the tty-process-group for the unix file-descriptor FD." + (alien:with-alien ((alien-pgrp c-call:int)) + (multiple-value-bind (ok err) + (unix-ioctl fd + tiocgpgrp + (alien:alien-sap (alien:addr alien-pgrp))) + (if ok + (values alien-pgrp nil) + (values nil err))))) + +(defun tty-process-group (&optional fd) + _N"Get the tty-process-group for the unix file-descriptor FD. If not supplied, + FD defaults to /dev/tty." + (if fd + (tcgetpgrp fd) + (multiple-value-bind (tty-fd errno) + (unix-open "/dev/tty" o_rdwr 0) + (cond (tty-fd + (multiple-value-prog1 + (tcgetpgrp tty-fd) + (unix-close tty-fd))) + (t + (values nil errno)))))) + +(defun tcsetpgrp (fd pgrp) + _N"Set the tty-process-group for the unix file-descriptor FD to PGRP." + (alien:with-alien ((alien-pgrp c-call:int pgrp)) + (unix-ioctl fd + tiocspgrp + (alien:alien-sap (alien:addr alien-pgrp))))) + +(defun %set-tty-process-group (pgrp &optional fd) + _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not + supplied, FD defaults to /dev/tty." + (let ((old-sigs + (unix-sigblock + (sigmask :sigttou :sigttin :sigtstp :sigchld)))) + (declare (type (unsigned-byte 32) old-sigs)) + (unwind-protect + (if fd + (tcsetpgrp fd pgrp) + (multiple-value-bind (tty-fd errno) + (unix-open "/dev/tty" o_rdwr 0) + (cond (tty-fd + (multiple-value-prog1 + (tcsetpgrp tty-fd pgrp) + (unix-close tty-fd))) + (t + (values nil errno))))) + (unix-sigsetmask old-sigs)))) + +(defsetf tty-process-group (&optional fd) (pgrp) + _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not + supplied, FD defaults to /dev/tty." + `(%set-tty-process-group ,pgrp ,fd)) + +#+(or) +(defun unix-getlogin () + _N"Return the login name of the user." + (let ((result (alien-funcall (extern-alien "getlogin" + (function c-string))))) + (declare (type system-area-pointer result)) + (if (zerop (sap-int result)) + nil + result))) + +(def-alien-type nil + (struct utsname + (sysname (array char 65)) + (nodename (array char 65)) + (release (array char 65)) + (version (array char 65)) + (machine (array char 65)) + (domainname (array char 65)))) + +(defun unix-uname () + _N"Unix-uname returns the name and information about the current kernel. The + values returned upon success are: sysname, nodename, release, version, + machine, and domainname. Upon failure, 'nil and the 'errno are returned." + (with-alien ((utsname (struct utsname))) + (syscall* ("uname" (* (struct utsname))) + (values (cast (slot utsname 'sysname) c-string) + (cast (slot utsname 'nodename) c-string) + (cast (slot utsname 'release) c-string) + (cast (slot utsname 'version) c-string) + (cast (slot utsname 'machine) c-string) + (cast (slot utsname 'domainname) c-string)) + (addr utsname)))) + +(defun unix-gethostname () + _N"Unix-gethostname returns the name of the host machine as a string." + (with-alien ((buf (array char 256))) + (syscall* ("gethostname" (* char) int) + (cast buf c-string) + (cast buf (* char)) 256))) + +#+(or) +(defun unix-sethostname (name len) + (int-syscall ("sethostname" c-string size-t) name len)) + +#+(or) +(defun unix-sethostid (id) + (int-syscall ("sethostid" long) id)) + +#+(or) +(defun unix-getdomainname (name len) + (int-syscall ("getdomainname" c-string size-t) name len)) + +#+(or) +(defun unix-setdomainname (name len) + (int-syscall ("setdomainname" c-string size-t) name len)) + +;;; Unix-fsync writes the core-image of the file described by "fd" to +;;; permanent storage (i.e. disk). + +(defun unix-fsync (fd) + _N"Unix-fsync writes the core image of the file described by + fd to disk." + (declare (type unix-fd fd)) + (void-syscall ("fsync" int) fd)) + + +#+(or) +(defun unix-vhangup () + _N"Revoke access permissions to all processes currently communicating + with the control terminal, and then send a SIGHUP signal to the process + group of the control terminal." + (int-syscall ("vhangup"))) + +#+(or) +(defun unix-revoke (file) + _N"Revoke the access of all descriptors currently open on FILE." + (int-syscall ("revoke" c-string) (%name->file file))) + + +#+(or) +(defun unix-chroot (path) + _N"Make PATH be the root directory (the starting point for absolute paths). + This call is restricted to the super-user." + (int-syscall ("chroot" c-string) (%name->file path))) + +(def-alien-routine ("gethostid" unix-gethostid) unsigned-long + _N"Unix-gethostid returns a 32-bit integer which provides unique + identification for the host machine.") + +;;; Unix-sync writes all information in core memory which has been modified +;;; to permanent storage (i.e. disk). + +(defun unix-sync () + _N"Unix-sync writes all information in core memory which has been + modified to disk. It returns NIL and an error code if an error + occured." + (void-syscall ("sync"))) + +;;; Unix-getpagesize returns the number of bytes in the system page. + +(defun unix-getpagesize () + _N"Unix-getpagesize returns the number of bytes in a system page." + (int-syscall ("getpagesize"))) + +;;; Unix-truncate accepts a file name and a new length. The file is +;;; truncated to the new length. + +(defun unix-truncate (name length) + _N"Unix-truncate truncates the named file to the length (in + bytes) specified by LENGTH. NIL and an error number is returned + if the call is unsuccessful." + (declare (type unix-pathname name) + (type (unsigned-byte 64) length)) + (void-syscall ("truncate64" c-string off-t) (%name->file name) length)) + +(defun unix-ftruncate (fd length) + _N"Unix-ftruncate is similar to unix-truncate except that the first + argument is a file descriptor rather than a file name." + (declare (type unix-fd fd) + (type (unsigned-byte 64) length)) + (void-syscall ("ftruncate64" int off-t) fd length)) + +#+(or) +(defun unix-getdtablesize () + _N"Return the maximum number of file descriptors + the current process could possibly have." + (int-syscall ("getdtablesize"))) + +(defconstant f_ulock 0 _N"Unlock a locked region") +(defconstant f_lock 1 _N"Lock a region for exclusive use") +(defconstant f_tlock 2 _N"Test and lock a region for exclusive use") +(defconstant f_test 3 _N"Test a region for othwer processes locks") + +(defun unix-lockf (fd cmd length) + _N"Unix-locks can lock, unlock and test files according to the cmd + which can be one of the following: + + f_ulock Unlock a locked region + f_lock Lock a region for exclusive use + f_tlock Test and lock a region for exclusive use + f_test Test a region for othwer processes locks + + The lock is for a region from the current location for a length + of length. + + This is a simpler version of the interface provided by unix-fcntl. + " + (declare (type unix-fd fd) + (type (unsigned-byte 64) length) + (type (integer 0 3) cmd)) + (int-syscall ("lockf64" int int off-t) fd cmd length)) + +;;; utime.h + +;; Structure describing file times. + +(def-alien-type nil + (struct utimbuf + (actime time-t) ; Access time. + (modtime time-t))) ; Modification time. + +;;; Unix-utimes changes the accessed and updated times on UNIX +;;; files. The first argument is the filename (a string) and +;;; the second argument is a list of the 4 times- accessed and +;;; updated seconds and microseconds. + +(defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec) + _N"Unix-utimes sets the 'last-accessed' and 'last-updated' + times on a specified file. NIL and an error number is + returned if the call is unsuccessful." + (declare (type unix-pathname file) + (type (alien unsigned-long) + atime-sec atime-usec + mtime-sec mtime-usec)) + (with-alien ((tvp (array (struct timeval) 2))) + (setf (slot (deref tvp 0) 'tv-sec) atime-sec) + (setf (slot (deref tvp 0) 'tv-usec) atime-usec) + (setf (slot (deref tvp 1) 'tv-sec) mtime-sec) + (setf (slot (deref tvp 1) 'tv-usec) mtime-usec) + (void-syscall ("utimes" c-string (* (struct timeval))) + file + (cast tvp (* (struct timeval)))))) +;;; waitflags.h + +;; Bits in the third argument to `waitpid'. + +(defconstant waitpid-wnohang 1 _N"Don't block waiting.") +(defconstant waitpid-wuntranced 2 _N"Report status of stopped children.") + +(defconstant waitpid-wclone #x80000000 _N"Wait for cloned process.") + +;;; sys/ioctl.h + +(defun unix-ioctl (fd cmd arg) + _N"Unix-ioctl performs a variety of operations on open i/o + descriptors. See the UNIX Programmer's Manual for more + information." + (declare (type unix-fd fd) + (type (unsigned-byte 32) cmd)) + (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg)) + + +;;; sys/fsuid.h + +#+(or) +(defun unix-setfsuid (uid) + _N"Change uid used for file access control to UID, without affecting + other priveledges (such as who can send signals at the process)." + (int-syscall ("setfsuid" uid-t) uid)) + +#+(or) +(defun unix-setfsgid (gid) + _N"Change gid used for file access control to GID, without affecting + other priveledges (such as who can send signals at the process)." + (int-syscall ("setfsgid" gid-t) gid)) + +;;; sys/poll.h + +;; Data structure describing a polling request. + +(def-alien-type nil + (struct pollfd + (fd int) ; File descriptor to poll. + (events short) ; Types of events poller cares about. + (revents short))) ; Types of events that actually occurred. + +;; Event types that can be polled for. These bits may be set in `events' +;; to indicate the interesting event types; they will appear in `revents' +;; to indicate the status of the file descriptor. + +(defconstant POLLIN #o1 _N"There is data to read.") +(defconstant POLLPRI #o2 _N"There is urgent data to read.") +(defconstant POLLOUT #o4 _N"Writing now will not block.") + +;; Event types always implicitly polled for. These bits need not be set in +;;`events', but they will appear in `revents' to indicate the status of +;; the file descriptor. */ + + +(defconstant POLLERR #o10 _N"Error condition.") +(defconstant POLLHUP #o20 _N"Hung up.") +(defconstant POLLNVAL #o40 _N"Invalid polling request.") + + +(defconstant +npollfile+ 30 _N"Canonical number of polling requests to read +in at a time in poll.") + +#+(or) +(defun unix-poll (fds nfds timeout) + _N" Poll the file descriptors described by the NFDS structures starting at + FDS. If TIMEOUT is nonzero and not -1, allow TIMEOUT milliseconds for + an event to occur; if TIMEOUT is -1, block until an event occurs. + Returns the number of file descriptors with events, zero if timed out, + or -1 for errors." + (int-syscall ("poll" (* (struct pollfd)) long int) + fds nfds timeout)) + +;;; sys/resource.h + +(defun unix-getrlimit (resource) + _N"Get the soft and hard limits for RESOURCE." + (with-alien ((rlimits (struct rlimit))) + (syscall ("getrlimit" int (* (struct rlimit))) + (values t + (slot rlimits 'rlim-cur) + (slot rlimits 'rlim-max)) + resource (addr rlimits)))) + +(defun unix-setrlimit (resource current maximum) + _N"Set the current soft and hard maximum limits for RESOURCE. + Only the super-user can increase hard limits." + (with-alien ((rlimits (struct rlimit))) + (setf (slot rlimits 'rlim-cur) current) + (setf (slot rlimits 'rlim-max) maximum) + (void-syscall ("setrlimit" int (* (struct rlimit))) + resource (addr rlimits)))) + +(declaim (inline unix-fast-getrusage)) +(defun unix-fast-getrusage (who) + _N"Like call getrusage, but return only the system and user time, and returns + the seconds and microseconds as separate values." + (declare (values (member t) + (unsigned-byte 31) (mod 1000000) + (unsigned-byte 31) (mod 1000000))) + (with-alien ((usage (struct rusage))) + (syscall* ("getrusage" int (* (struct rusage))) + (values t + (slot (slot usage 'ru-utime) 'tv-sec) + (slot (slot usage 'ru-utime) 'tv-usec) + (slot (slot usage 'ru-stime) 'tv-sec) + (slot (slot usage 'ru-stime) 'tv-usec)) + who (addr usage)))) + +(defun unix-getrusage (who) + _N"Unix-getrusage returns information about the resource usage + of the process specified by who. Who can be either the + current process (rusage_self) or all of the terminated + child processes (rusage_children). NIL and an error number + is returned if the call fails." + (with-alien ((usage (struct rusage))) + (syscall ("getrusage" int (* (struct rusage))) + (values t + (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000) + (slot (slot usage 'ru-utime) 'tv-usec)) + (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000) + (slot (slot usage 'ru-stime) 'tv-usec)) + (slot usage 'ru-maxrss) + (slot usage 'ru-ixrss) + (slot usage 'ru-idrss) + (slot usage 'ru-isrss) + (slot usage 'ru-minflt) + (slot usage 'ru-majflt) + (slot usage 'ru-nswap) + (slot usage 'ru-inblock) + (slot usage 'ru-oublock) + (slot usage 'ru-msgsnd) + (slot usage 'ru-msgrcv) + (slot usage 'ru-nsignals) + (slot usage 'ru-nvcsw) + (slot usage 'ru-nivcsw)) + who (addr usage)))) + +#+(or) +(defun unix-ulimit (cmd newlimit) + _N"Function depends on CMD: + 1 = Return the limit on the size of a file, in units of 512 bytes. + 2 = Set the limit on the size of a file to NEWLIMIT. Only the + super-user can increase the limit. + 3 = Return the maximum possible address of the data segment. + 4 = Return the maximum number of files that the calling process can open. + Returns -1 on errors." + (int-syscall ("ulimit" int long) cmd newlimit)) + +#+(or) +(defun unix-getpriority (which who) + _N"Return the highest priority of any process specified by WHICH and WHO + (see above); if WHO is zero, the current process, process group, or user + (as specified by WHO) is used. A lower priority number means higher + priority. Priorities range from PRIO_MIN to PRIO_MAX (above)." + (int-syscall ("getpriority" int int) + which who)) + +#+(or) +(defun unix-setpriority (which who) + _N"Set the priority of all processes specified by WHICH and WHO (see above) + to PRIO. Returns 0 on success, -1 on errors." + (int-syscall ("setpriority" int int) + which who)) + +;;; sys/socket.h + +;;;; Socket support. + +;;; Looks a bit naked. + +(def-alien-routine ("socket" unix-socket) int + (domain int) + (type int) + (protocol int)) + +(def-alien-routine ("connect" unix-connect) int + (socket int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("bind" unix-bind) int + (socket int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("listen" unix-listen) int + (socket int) + (backlog int)) + +(def-alien-routine ("accept" unix-accept) int + (socket int) + (sockaddr (* t)) + (len int :in-out)) + +(def-alien-routine ("recv" unix-recv) int + (fd int) + (buffer c-string) + (length int) + (flags int)) + +(def-alien-routine ("send" unix-send) int + (fd int) + (buffer c-string) + (length int) + (flags int)) + +(def-alien-routine ("getpeername" unix-getpeername) int + (socket int) + (sockaddr (* t)) + (len (* unsigned))) + +(def-alien-routine ("getsockname" unix-getsockname) int + (socket int) + (sockaddr (* t)) + (len (* unsigned))) + +(def-alien-routine ("getsockopt" unix-getsockopt) int + (socket int) + (level int) + (optname int) + (optval (* t)) + (optlen unsigned :in-out)) + +(def-alien-routine ("setsockopt" unix-setsockopt) int + (socket int) + (level int) + (optname int) + (optval (* t)) + (optlen unsigned)) + +;; Datagram support + +(def-alien-routine ("recvfrom" unix-recvfrom) int + (fd int) + (buffer c-string) + (length int) + (flags int) + (sockaddr (* t)) + (len int :in-out)) + +(def-alien-routine ("sendto" unix-sendto) int + (fd int) + (buffer c-string) + (length int) + (flags int) + (sockaddr (* t)) + (len int)) + +(def-alien-routine ("shutdown" unix-shutdown) int + (socket int) + (level int)) + +;;; sys/select.h + +;;; UNIX-FAST-SELECT -- public. +;;; +(defmacro unix-fast-select (num-descriptors + read-fds write-fds exception-fds + timeout-secs &optional (timeout-usecs 0)) + _N"Perform the UNIX select(2) system call." + (declare (type (integer 0 #.FD-SETSIZE) num-descriptors) + (type (or (alien (* (struct fd-set))) null) + read-fds write-fds exception-fds) + (type (or null (unsigned-byte 31)) timeout-secs) + (type (unsigned-byte 31) timeout-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + `(let ((timeout-secs ,timeout-secs)) + (with-alien ((tv (struct timeval))) + (when timeout-secs + (setf (slot tv 'tv-sec) timeout-secs) + (setf (slot tv 'tv-usec) ,timeout-usecs)) + (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + ,num-descriptors ,read-fds ,write-fds ,exception-fds + (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))) + + +;;; Unix-select accepts sets of file descriptors and waits for an event +;;; to happen on one of them or to time out. + +(defmacro num-to-fd-set (fdset num) + `(if (fixnump ,num) + (progn + (setf (deref (slot ,fdset 'fds-bits) 0) ,num) + ,@(loop for index upfrom 1 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0))) + (progn + ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fdset 'fds-bits) ,index) + (ldb (byte nfdbits ,(* index nfdbits)) ,num)))))) + +(defmacro fd-set-to-num (nfds fdset) + `(if (<= ,nfds nfdbits) + (deref (slot ,fdset 'fds-bits) 0) + (+ ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(ash (deref (slot ,fdset 'fds-bits) ,index) + ,(* index nfdbits)))))) + +(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0)) + _N"Unix-select examines the sets of descriptors passed as arguments + to see if they are ready for reading and writing. See the UNIX + Programmers Manual for more information." + (declare (type (integer 0 #.FD-SETSIZE) nfds) + (type unsigned-byte rdfds wrfds xpfds) + (type (or (unsigned-byte 31) null) to-secs) + (type (unsigned-byte 31) to-usecs) + (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + (with-alien ((tv (struct timeval)) + (rdf (struct fd-set)) + (wrf (struct fd-set)) + (xpf (struct fd-set))) + (when to-secs + (setf (slot tv 'tv-sec) to-secs) + (setf (slot tv 'tv-usec) to-usecs)) + (num-to-fd-set rdf rdfds) + (num-to-fd-set wrf wrfds) + (num-to-fd-set xpf xpfds) + (macrolet ((frob (lispvar alienvar) + `(if (zerop ,lispvar) + (int-sap 0) + (alien-sap (addr ,alienvar))))) + (syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + (values result + (fd-set-to-num nfds rdf) + (fd-set-to-num nfds wrf) + (fd-set-to-num nfds xpf)) + nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf) + (if to-secs (alien-sap (addr tv)) (int-sap 0)))))) + +;;; sys/stat.h + +(defmacro extract-stat-results (buf) + `(values T + #+(or alpha amd64) + (slot ,buf 'st-dev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-dev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-ino) + (slot ,buf 'st-mode) + (slot ,buf 'st-nlink) + (slot ,buf 'st-uid) + (slot ,buf 'st-gid) + #+(or alpha amd64) + (slot ,buf 'st-rdev) + #-(or alpha amd64) + (+ (deref (slot ,buf 'st-rdev) 0) + (* (+ +max-u-long+ 1) + (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works.. + (slot ,buf 'st-size) + (slot ,buf 'st-atime) + (slot ,buf 'st-mtime) + (slot ,buf 'st-ctime) + (slot ,buf 'st-blksize) + (slot ,buf 'st-blocks))) + +(defun unix-stat (name) + _N"UNIX-STAT retrieves information about the specified + file returning them in the form of multiple values. + See the UNIX Programmer's Manual for a description + of the values returned. If the call fails, then NIL + and an error number is returned instead." + (declare (type unix-pathname name)) + (when (string= name "") + (setf name ".")) + (with-alien ((buf (struct stat))) + (syscall ("stat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) + +(defun unix-fstat (fd) + _N"UNIX-FSTAT is similar to UNIX-STAT except the file is specified + by the file descriptor FD." + (declare (type unix-fd fd)) + (with-alien ((buf (struct stat))) + (syscall ("fstat64" int (* (struct stat))) + (extract-stat-results buf) + fd (addr buf)))) + +(defun unix-lstat (name) + _N"UNIX-LSTAT is similar to UNIX-STAT except the specified + file must be a symbolic link." + (declare (type unix-pathname name)) + (with-alien ((buf (struct stat))) + (syscall ("lstat64" c-string (* (struct stat))) + (extract-stat-results buf) + (%name->file name) (addr buf)))) + +;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode. + +(defun unix-chmod (path mode) + _N"Given a file path string and a constant mode, unix-chmod changes the + permission mode for that file to the one specified. The new mode + can be created by logically OR'ing the following: + + setuidexec Set user ID on execution. + setgidexec Set group ID on execution. + savetext Save text image after execution. + readown Read by owner. + writeown Write by owner. + execown Execute (search directory) by owner. + readgrp Read by group. + writegrp Write by group. + execgrp Execute (search directory) by group. + readoth Read by others. + writeoth Write by others. + execoth Execute (search directory) by others. + + Thus #o444 and (logior unix:readown unix:readgrp unix:readoth) + are equivalent for 'mode. The octal-base is familar to Unix users. + + It returns T on successfully completion; NIL and an error number + otherwise." + (declare (type unix-pathname path) + (type unix-file-mode mode)) + (void-syscall ("chmod" c-string int) (%name->file path) mode)) + +;;; Unix-fchmod accepts a file descriptor ("fd") and a file protection mode +;;; ("mode") and changes the protection of the file described by "fd" to +;;; "mode". + +(defun unix-fchmod (fd mode) + _N"Given an integer file descriptor and a mode (the same as those + used for unix-chmod), unix-fchmod changes the permission mode + for that file to the one specified. T is returned if the call + was successful." + (declare (type unix-fd fd) + (type unix-file-mode mode)) + (void-syscall ("fchmod" int int) fd mode)) + + +(defun unix-umask (mask) + _N"Set the file creation mask of the current process to MASK, + and return the old creation mask." + (int-syscall ("umask" mode-t) mask)) + +;;; Unix-mkdir accepts a name and a mode and attempts to create the +;;; corresponding directory with mode mode. + +(defun unix-mkdir (name mode) + _N"Unix-mkdir creates a new directory with the specified name and mode. + (Same as those for unix-chmod.) It returns T upon success, otherwise + NIL and an error number." + (declare (type unix-pathname name) + (type unix-file-mode mode)) + (void-syscall ("mkdir" c-string int) (%name->file name) mode)) + +#+(or) +(defun unix-makedev (path mode dev) + _N"Create a device file named PATH, with permission and special bits MODE + and device number DEV (which can be constructed from major and minor + device numbers with the `makedev' macro above)." + (declare (type unix-pathname path) + (type unix-file-mode mode)) + (void-syscall ("makedev" c-string mode-t dev-t) (%name->file name) mode dev)) + + +#+(or) +(defun unix-fifo (name mode) + _N"Create a new FIFO named PATH, with permission bits MODE." + (declare (type unix-pathname name) + (type unix-file-mode mode)) + (void-syscall ("mkfifo" c-string int) (%name->file name) mode)) + +;;; sys/statfs.h + +#+(or) +(defun unix-statfs (file buf) + _N"Return information about the filesystem on which FILE resides." + (int-syscall ("statfs64" c-string (* (struct statfs))) + (%name->file file) buf)) + +;;; sys/swap.h + +#+(or) +(defun unix-swapon (path flags) + _N"Make the block special device PATH available to the system for swapping. + This call is restricted to the super-user." + (int-syscall ("swapon" c-string int) (%name->file path) flags)) + +#+(or) +(defun unix-swapoff (path) + _N"Make the block special device PATH unavailable to the system for swapping. + This call is restricted to the super-user." + (int-syscall ("swapoff" c-string) (%name->file path))) + +;;; sys/sysctl.h + +#+(or) +(defun unix-sysctl (name nlen oldval oldlenp newval newlen) + _N"Read or write system parameters." + (int-syscall ("sysctl" int int (* void) (* void) (* void) size-t) + name nlen oldval oldlenp newval newlen)) + +;;; time.h + +;; POSIX.4 structure for a time value. This is like a `struct timeval' but +;; has nanoseconds instead of microseconds. + +(def-alien-type nil + (struct timespec + (tv-sec long) ;Seconds + (tv-nsec long))) ;Nanoseconds + +;; Used by other time functions. + +(def-alien-type nil + (struct tm + (tm-sec int) ; Seconds. [0-60] (1 leap second) + (tm-min int) ; Minutes. [0-59] + (tm-hour int) ; Hours. [0-23] + (tm-mday int) ; Day. [1-31] + (tm-mon int) ; Month. [0-11] + (tm-year int) ; Year - 1900. + (tm-wday int) ; Day of week. [0-6] + (tm-yday int) ; Days in year.[0-365] + (tm-isdst int) ; DST. [-1/0/1] + (tm-gmtoff long) ; Seconds east of UTC. + (tm-zone c-string))) ; Timezone abbreviation. + +#+(or) +(defun unix-clock () + _N"Time used by the program so far (user time + system time). + The result / CLOCKS_PER_SECOND is program time in seconds." + (int-syscall ("clock"))) + +#+(or) +(defun unix-time (timer) + _N"Return the current time and put it in *TIMER if TIMER is not NULL." + (int-syscall ("time" time-t) timer)) + +;; Requires call to tzset() in main. + +(def-alien-variable ("daylight" unix-daylight) int) +(def-alien-variable ("timezone" unix-timezone) time-t) +;(def-alien-variable ("altzone" unix-altzone) time-t) doesn't exist +(def-alien-variable ("tzname" unix-tzname) (array c-string 2)) + +(def-alien-routine get-timezone c-call:void + (when c-call:long :in) + (minutes-west c-call:int :out) + (daylight-savings-p alien:boolean :out)) + +(defun unix-get-minutes-west (secs) + (multiple-value-bind (ignore minutes dst) (get-timezone secs) + (declare (ignore ignore) (ignore dst)) + (values minutes))) + +(defun unix-get-timezone (secs) + (multiple-value-bind (ignore minutes dst) (get-timezone secs) + (declare (ignore ignore) (ignore minutes)) + (values (deref unix-tzname (if dst 1 0))))) + +;;; sys/time.h + +;; Structure crudely representing a timezone. +;; This is obsolete and should never be used. +(def-alien-type nil + (struct timezone + (tz-minuteswest int) ; minutes west of Greenwich + (tz-dsttime int))) ; type of dst correction + + +(declaim (inline unix-gettimeofday)) +(defun unix-gettimeofday () + _N"If it works, unix-gettimeofday returns 5 values: T, the seconds and + microseconds of the current time of day, the timezone (in minutes west + of Greenwich), and a daylight-savings flag. If it doesn't work, it + returns NIL and the errno." + (with-alien ((tv (struct timeval)) + (tz (struct timezone))) + (syscall* ("gettimeofday" (* (struct timeval)) + (* (struct timezone))) + (values T + (slot tv 'tv-sec) + (slot tv 'tv-usec) + (slot tz 'tz-minuteswest) + (slot tz 'tz-dsttime)) + (addr tv) + (addr tz)))) + + +;/* Set the current time of day and timezone information. +; This call is restricted to the super-user. */ +;extern int __settimeofday __P ((__const struct timeval *__tv, +; __const struct timezone *__tz)); +;extern int settimeofday __P ((__const struct timeval *__tv, +; __const struct timezone *__tz)); + +;/* Adjust the current time of day by the amount in DELTA. +; If OLDDELTA is not NULL, it is filled in with the amount +; of time adjustment remaining to be done from the last `adjtime' call. +; This call is restricted to the super-user. */ +;extern int __adjtime __P ((__const struct timeval *__delta, +; struct timeval *__olddelta)); +;extern int adjtime __P ((__const struct timeval *__delta, +; struct timeval *__olddelta)); + + +;; Type of the second argument to `getitimer' and +;; the second and third arguments `setitimer'. +(def-alien-type nil + (struct itimerval + (it-interval (struct timeval)) ; timer interval + (it-value (struct timeval)))) ; current value + +(defconstant ITIMER-REAL 0) +(defconstant ITIMER-VIRTUAL 1) +(defconstant ITIMER-PROF 2) + +(defun unix-getitimer (which) + _N"Unix-getitimer returns the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). On success, + unix-getitimer returns 5 values, + T, it-interval-secs, it-interval-usec, it-value-secs, it-value-usec." + (declare (type (member :real :virtual :profile) which) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itv (struct itimerval))) + (syscall* ("getitimer" int (* (struct itimerval))) + (values T + (slot (slot itv 'it-interval) 'tv-sec) + (slot (slot itv 'it-interval) 'tv-usec) + (slot (slot itv 'it-value) 'tv-sec) + (slot (slot itv 'it-value) 'tv-usec)) + which (alien-sap (addr itv)))))) + +(defun unix-setitimer (which int-secs int-usec val-secs val-usec) + _N" Unix-setitimer sets the INTERVAL and VALUE slots of one of + three system timers (:real :virtual or :profile). A SIGALRM signal + will be delivered VALUE <seconds+microseconds> from now. INTERVAL, + when non-zero, is <seconds+microseconds> to be loaded each time + the timer expires. Setting INTERVAL and VALUE to zero disables + the timer. See the Unix man page for more details. On success, + unix-setitimer returns the old contents of the INTERVAL and VALUE + slots as in unix-getitimer." + (declare (type (member :real :virtual :profile) which) + (type (unsigned-byte 29) int-secs val-secs) + (type (integer 0 (1000000)) int-usec val-usec) + (values t + (unsigned-byte 29)(mod 1000000) + (unsigned-byte 29)(mod 1000000))) + (let ((which (ecase which + (:real ITIMER-REAL) + (:virtual ITIMER-VIRTUAL) + (:profile ITIMER-PROF)))) + (with-alien ((itvn (struct itimerval)) + (itvo (struct itimerval))) + (setf (slot (slot itvn 'it-interval) 'tv-sec ) int-secs + (slot (slot itvn 'it-interval) 'tv-usec) int-usec + (slot (slot itvn 'it-value ) 'tv-sec ) val-secs + (slot (slot itvn 'it-value ) 'tv-usec) val-usec) + (syscall* ("setitimer" int (* (struct timeval))(* (struct timeval))) + (values T + (slot (slot itvo 'it-interval) 'tv-sec) + (slot (slot itvo 'it-interval) 'tv-usec) + (slot (slot itvo 'it-value) 'tv-sec) + (slot (slot itvo 'it-value) 'tv-usec)) + which (alien-sap (addr itvn))(alien-sap (addr itvo)))))) + +;;; sys/timeb.h + +;; Structure returned by the `ftime' function. + +(def-alien-type nil + (struct timeb + (time time-t) ; Seconds since epoch, as from `time'. + (millitm short) ; Additional milliseconds. + (timezone int) ; Minutes west of GMT. + (dstflag short))) ; Nonzero if Daylight Savings Time used. + +#+(or) +(defun unix-fstime (timebuf) + _N"Fill in TIMEBUF with information about the current time." + (int-syscall ("ftime" (* (struct timeb))) timebuf)) + + +;;; sys/times.h + +;; Structure describing CPU time used by a process and its children. + +(def-alien-type nil + (struct tms + (tms-utime clock-t) ; User CPU time. + (tms-stime clock-t) ; System CPU time. + (tms-cutime clock-t) ; User CPU time of dead children. + (tms-cstime clock-t))) ; System CPU time of dead children. + +#+(or) +(defun unix-times (buffer) + _N"Store the CPU time used by this process and all its + dead children (and their dead children) in BUFFER. + Return the elapsed real time, or (clock_t) -1 for errors. + All times are in CLK_TCKths of a second." + (int-syscall ("times" (* (struct tms))) buffer)) + +;;; sys/wait.h + +#+(or) +(defun unix-wait (status) + _N"Wait for a child to die. When one does, put its status in *STAT_LOC + and return its process ID. For errors, return (pid_t) -1." + (int-syscall ("wait" (* int)) status)) + +#+(or) +(defun unix-waitpid (pid status options) + _N"Wait for a child matching PID to die. + If PID is greater than 0, match any process whose process ID is PID. + If PID is (pid_t) -1, match any process. + If PID is (pid_t) 0, match any process with the + same process group as the current process. + If PID is less than -1, match any process whose + process group is the absolute value of PID. + If the WNOHANG bit is set in OPTIONS, and that child + is not already dead, return (pid_t) 0. If successful, + return PID and store the dead child's status in STAT_LOC. + Return (pid_t) -1 for errors. If the WUNTRACED bit is + set in OPTIONS, return status for stopped children; otherwise don't." + (int-syscall ("waitpit" pid-t (* int) int) + pid status options)) + +;;; asm/errno.h + +(def-unix-error ESUCCESS 0 _N"Successful") +(def-unix-error EPERM 1 _N"Operation not permitted") +(def-unix-error ENOENT 2 _N"No such file or directory") +(def-unix-error ESRCH 3 _N"No such process") +(def-unix-error EINTR 4 _N"Interrupted system call") +(def-unix-error EIO 5 _N"I/O error") +(def-unix-error ENXIO 6 _N"No such device or address") +(def-unix-error E2BIG 7 _N"Arg list too long") +(def-unix-error ENOEXEC 8 _N"Exec format error") +(def-unix-error EBADF 9 _N"Bad file number") +(def-unix-error ECHILD 10 _N"No children") +(def-unix-error EAGAIN 11 _N"Try again") +(def-unix-error ENOMEM 12 _N"Out of memory") +(def-unix-error EACCES 13 _N"Permission denied") +(def-unix-error EFAULT 14 _N"Bad address") +(def-unix-error ENOTBLK 15 _N"Block device required") +(def-unix-error EBUSY 16 _N"Device or resource busy") +(def-unix-error EEXIST 17 _N"File exists") +(def-unix-error EXDEV 18 _N"Cross-device link") +(def-unix-error ENODEV 19 _N"No such device") +(def-unix-error ENOTDIR 20 _N"Not a director") +(def-unix-error EISDIR 21 _N"Is a directory") +(def-unix-error EINVAL 22 _N"Invalid argument") +(def-unix-error ENFILE 23 _N"File table overflow") +(def-unix-error EMFILE 24 _N"Too many open files") +(def-unix-error ENOTTY 25 _N"Not a typewriter") +(def-unix-error ETXTBSY 26 _N"Text file busy") +(def-unix-error EFBIG 27 _N"File too large") +(def-unix-error ENOSPC 28 _N"No space left on device") +(def-unix-error ESPIPE 29 _N"Illegal seek") +(def-unix-error EROFS 30 _N"Read-only file system") +(def-unix-error EMLINK 31 _N"Too many links") +(def-unix-error EPIPE 32 _N"Broken pipe") +;;; +;;; Math +(def-unix-error EDOM 33 _N"Math argument out of domain") +(def-unix-error ERANGE 34 _N"Math result not representable") +;;; +(def-unix-error EDEADLK 35 _N"Resource deadlock would occur") +(def-unix-error ENAMETOOLONG 36 _N"File name too long") +(def-unix-error ENOLCK 37 _N"No record locks available") +(def-unix-error ENOSYS 38 _N"Function not implemented") +(def-unix-error ENOTEMPTY 39 _N"Directory not empty") +(def-unix-error ELOOP 40 _N"Too many symbolic links encountered") +(def-unix-error EWOULDBLOCK 11 _N"Operation would block") +(def-unix-error ENOMSG 42 _N"No message of desired type") +(def-unix-error EIDRM 43 _N"Identifier removed") +(def-unix-error ECHRNG 44 _N"Channel number out of range") +(def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized") +(def-unix-error EL3HLT 46 _N"Level 3 halted") +(def-unix-error EL3RST 47 _N"Level 3 reset") +(def-unix-error ELNRNG 48 _N"Link number out of range") +(def-unix-error EUNATCH 49 _N"Protocol driver not attached") +(def-unix-error ENOCSI 50 _N"No CSI structure available") +(def-unix-error EL2HLT 51 _N"Level 2 halted") +(def-unix-error EBADE 52 _N"Invalid exchange") +(def-unix-error EBADR 53 _N"Invalid request descriptor") +(def-unix-error EXFULL 54 _N"Exchange full") +(def-unix-error ENOANO 55 _N"No anode") +(def-unix-error EBADRQC 56 _N"Invalid request code") +(def-unix-error EBADSLT 57 _N"Invalid slot") +(def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error") +(def-unix-error EBFONT 59 _N"Bad font file format") +(def-unix-error ENOSTR 60 _N"Device not a stream") +(def-unix-error ENODATA 61 _N"No data available") +(def-unix-error ETIME 62 _N"Timer expired") +(def-unix-error ENOSR 63 _N"Out of streams resources") +(def-unix-error ENONET 64 _N"Machine is not on the network") +(def-unix-error ENOPKG 65 _N"Package not installed") +(def-unix-error EREMOTE 66 _N"Object is remote") +(def-unix-error ENOLINK 67 _N"Link has been severed") +(def-unix-error EADV 68 _N"Advertise error") +(def-unix-error ESRMNT 69 _N"Srmount error") +(def-unix-error ECOMM 70 _N"Communication error on send") +(def-unix-error EPROTO 71 _N"Protocol error") +(def-unix-error EMULTIHOP 72 _N"Multihop attempted") +(def-unix-error EDOTDOT 73 _N"RFS specific error") +(def-unix-error EBADMSG 74 _N"Not a data message") +(def-unix-error EOVERFLOW 75 _N"Value too large for defined data type") +(def-unix-error ENOTUNIQ 76 _N"Name not unique on network") +(def-unix-error EBADFD 77 _N"File descriptor in bad state") +(def-unix-error EREMCHG 78 _N"Remote address changed") +(def-unix-error ELIBACC 79 _N"Can not access a needed shared library") +(def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library") +(def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted") +(def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries") +(def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly") +(def-unix-error EILSEQ 84 _N"Illegal byte sequence") +(def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N") +(def-unix-error ESTRPIPE 86 _N"Streams pipe error") +(def-unix-error EUSERS 87 _N"Too many users") +(def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket") +(def-unix-error EDESTADDRREQ 89 _N"Destination address required") +(def-unix-error EMSGSIZE 90 _N"Message too long") +(def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket") +(def-unix-error ENOPROTOOPT 92 _N"Protocol not available") +(def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported") +(def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported") +(def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint") +(def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported") +(def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol") +(def-unix-error EADDRINUSE 98 _N"Address already in use") +(def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address") +(def-unix-error ENETDOWN 100 _N"Network is down") +(def-unix-error ENETUNREACH 101 _N"Network is unreachable") +(def-unix-error ENETRESET 102 _N"Network dropped connection because of reset") +(def-unix-error ECONNABORTED 103 _N"Software caused connection abort") +(def-unix-error ECONNRESET 104 _N"Connection reset by peer") +(def-unix-error ENOBUFS 105 _N"No buffer space available") +(def-unix-error EISCONN 106 _N"Transport endpoint is already connected") +(def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected") +(def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown") +(def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice") +(def-unix-error ETIMEDOUT 110 _N"Connection timed out") +(def-unix-error ECONNREFUSED 111 _N"Connection refused") +(def-unix-error EHOSTDOWN 112 _N"Host is down") +(def-unix-error EHOSTUNREACH 113 _N"No route to host") +(def-unix-error EALREADY 114 _N"Operation already in progress") +(def-unix-error EINPROGRESS 115 _N"Operation now in progress") +(def-unix-error ESTALE 116 _N"Stale NFS file handle") +(def-unix-error EUCLEAN 117 _N"Structure needs cleaning") +(def-unix-error ENOTNAM 118 _N"Not a XENIX named type file") +(def-unix-error ENAVAIL 119 _N"No XENIX semaphores available") +(def-unix-error EISNAM 120 _N"Is a named type file") +(def-unix-error EREMOTEIO 121 _N"Remote I/O error") +(def-unix-error EDQUOT 122 _N"Quota exceeded") + +;;; And now for something completely different ... +(emit-unix-errors) + +;;; the ioctl's. +;;; +;;; I've deleted all the stuff that wasn't in the header files. +;;; This is what survived. + +;; 0x54 is just a magic number to make these relatively unique ('T') + +(eval-when (compile load eval) + +(defconstant iocparm-mask #x3fff) +(defconstant ioc_void #x00000000) +(defconstant ioc_out #x40000000) +(defconstant ioc_in #x80000000) +(defconstant ioc_inout (logior ioc_in ioc_out)) + +(defmacro define-ioctl-command (name dev cmd &optional arg parm-type) + _N"Define an ioctl command. If the optional ARG and PARM-TYPE are given + then ioctl argument size and direction are included as for ioctls defined + by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type + is the characters code, else DEV may be an integer giving the type." + (let* ((type (if (characterp dev) + (char-code dev) + dev)) + (code (logior (ash type 8) cmd))) + (when arg + (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask) + 16) + ,code))) + (when parm-type + (let ((dir (ecase parm-type + (:void ioc_void) + (:in ioc_in) + (:out ioc_out) + (:inout ioc_inout)))) + (setf code `(logior ,dir ,code)))) + `(eval-when (eval load compile) + (defconstant ,name ,code)))) + +) + +;;; TTY ioctl commands. + +(define-ioctl-command TIOCGWINSZ #\T #x13) +(define-ioctl-command TIOCSWINSZ #\T #x14) +(define-ioctl-command TIOCNOTTY #\T #x22) +(define-ioctl-command TIOCSPGRP #\T #x10) +(define-ioctl-command TIOCGPGRP #\T #x0F) + +;;; File ioctl commands. +(define-ioctl-command FIONREAD #\T #x1B) + +;;; asm/sockios.h + +;;; Socket options. + +(define-ioctl-command SIOCSPGRP #x89 #x02) + +(defun siocspgrp (fd pgrp) + _N"Set the socket process-group for the unix file-descriptor FD to PGRP." + (alien:with-alien ((alien-pgrp c-call:int pgrp)) + (unix-ioctl fd + siocspgrp + (alien:alien-sap (alien:addr alien-pgrp))))) + +;;; A few random constants and functions + +(defconstant setuidexec #o4000 _N"Set user ID on execution") +(defconstant setgidexec #o2000 _N"Set group ID on execution") +(defconstant savetext #o1000 _N"Save text image after execution") +(defconstant readown #o400 _N"Read by owner") +(defconstant writeown #o200 _N"Write by owner") +(defconstant execown #o100 _N"Execute (search directory) by owner") +(defconstant readgrp #o40 _N"Read by group") +(defconstant writegrp #o20 _N"Write by group") +(defconstant execgrp #o10 _N"Execute (search directory) by group") +(defconstant readoth #o4 _N"Read by others") +(defconstant writeoth #o2 _N"Write by others") +(defconstant execoth #o1 _N"Execute (search directory) by others") + +(defconstant terminal-speeds + '#(0 50 75 110 134 150 200 300 600 1200 1800 2400 + 4800 9600 19200 38400 57600 115200 230400)) + +;;;; Support routines for dealing with unix pathnames. + +(export '(unix-file-kind unix-maybe-prepend-current-directory + unix-resolve-links unix-simplify-pathname)) + +(defun unix-file-kind (name &optional check-for-links) + _N"Returns either :file, :directory, :link, :special, or NIL." + (declare (simple-string name)) + (multiple-value-bind (res dev ino mode) + (if check-for-links + (unix-lstat name) + (unix-stat name)) + (declare (type (or fixnum null) mode) + (ignore dev ino)) + (when res + (let ((kind (logand mode s-ifmt))) + (cond ((eql kind s-ifdir) :directory) + ((eql kind s-ifreg) :file) + ((eql kind s-iflnk) :link) + (t :special)))))) + +(defun unix-maybe-prepend-current-directory (name) + (declare (simple-string name)) + (if (and (> (length name) 0) (char= (schar name 0) #\/)) + name + (multiple-value-bind (win dir) (unix-current-directory) + (if win + (concatenate 'simple-string dir "/" name) + name)))) + +(defun unix-resolve-links (pathname) + _N"Returns the pathname with all symbolic links resolved." + (declare (simple-string pathname)) + (let ((len (length pathname)) + (pending pathname)) + (declare (fixnum len) (simple-string pending)) + (if (zerop len) + pathname + (let ((result (make-string 100 :initial-element (code-char 0))) + (fill-ptr 0) + (name-start 0)) + (loop + (let* ((name-end (or (position #\/ pending :start name-start) len)) + (new-fill-ptr (+ fill-ptr (- name-end name-start)))) + ;; grow the result string, if necessary. the ">=" (instead of + ;; using ">") allows for the trailing "/" if we find this + ;; component is a directory. + (when (>= new-fill-ptr (length result)) + (let ((longer (make-string (* 3 (length result)) + :initial-element (code-char 0)))) + (replace longer result :end1 fill-ptr) + (setq result longer))) + (replace result pending + :start1 fill-ptr + :end1 new-fill-ptr + :start2 name-start + :end2 name-end) + (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t))) + (unless kind (return nil)) + (cond ((eq kind :link) + (multiple-value-bind (link err) (unix-readlink result) + (unless link + (error (intl:gettext "Error reading link ~S: ~S") + (subseq result 0 fill-ptr) + (get-unix-error-msg err))) + (cond ((or (zerop (length link)) + (char/= (schar link 0) #\/)) + ;; It's a relative link + (fill result (code-char 0) + :start fill-ptr + :end new-fill-ptr)) + ((string= result "/../" :end1 4) + ;; It's across the super-root. + (let ((slash (or (position #\/ result :start 4) + 0))) + (fill result (code-char 0) + :start slash + :end new-fill-ptr) + (setf fill-ptr slash))) + (t + ;; It's absolute. + (and (> (length link) 0) + (char= (schar link 0) #\/)) + (fill result (code-char 0) :end new-fill-ptr) + (setf fill-ptr 0))) + (setf pending + (if (= name-end len) + link + (concatenate 'simple-string + link + (subseq pending name-end)))) + (setf len (length pending)) + (setf name-start 0))) + ((= name-end len) + (when (eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (incf new-fill-ptr)) + (return (subseq result 0 new-fill-ptr))) + ((eq kind :directory) + (setf (schar result new-fill-ptr) #\/) + (setf fill-ptr (1+ new-fill-ptr)) + (setf name-start (1+ name-end))) + (t + (return nil)))))))))) + +(defun unix-simplify-pathname (src) + (declare (simple-string src)) + (let* ((src-len (length src)) + (dst (make-string src-len)) + (dst-len 0) + (dots 0) + (last-slash nil)) + (macrolet ((deposit (char) + `(progn + (setf (schar dst dst-len) ,char) + (incf dst-len)))) + (dotimes (src-index src-len) + (let ((char (schar src src-index))) + (cond ((char= char #\.) + (when dots + (incf dots)) + (deposit char)) + ((char= char #\/) + (case dots + (0 + ;; Either ``/...' or ``...//...' + (unless last-slash + (setf last-slash dst-len) + (deposit char))) + (1 + ;; Either ``./...'' or ``..././...'' + (decf dst-len)) + (2 + ;; We've found .. + (cond + ((and last-slash (not (zerop last-slash))) + ;; There is something before this .. + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (cond ((and (= (+ (or prev-prev-slash 0) 2) + last-slash) + (char= (schar dst (- last-slash 2)) #\.) + (char= (schar dst (1- last-slash)) #\.)) + ;; The something before this .. is another .. + (deposit char) + (setf last-slash dst-len)) + (t + ;; The something is some random dir. + (setf dst-len + (if prev-prev-slash + (1+ prev-prev-slash) + 0)) + (setf last-slash prev-prev-slash))))) + (t + ;; There is nothing before this .., so we need to keep it + (setf last-slash dst-len) + (deposit char)))) + (t + ;; Something other than a dot between slashes. + (setf last-slash dst-len) + (deposit char))) + (setf dots 0)) + (t + (setf dots nil) + (setf (schar dst dst-len) char) + (incf dst-len)))))) + (when (and last-slash (not (zerop last-slash))) + (case dots + (1 + ;; We've got ``foobar/.'' + (decf dst-len)) + (2 + ;; We've got ``foobar/..'' + (unless (and (>= last-slash 2) + (char= (schar dst (1- last-slash)) #\.) + (char= (schar dst (- last-slash 2)) #\.) + (or (= last-slash 2) + (char= (schar dst (- last-slash 3)) #\/))) + (let ((prev-prev-slash + (position #\/ dst :end last-slash :from-end t))) + (if prev-prev-slash + (setf dst-len (1+ prev-prev-slash)) + (return-from unix-simplify-pathname "./"))))))) + (cond ((zerop dst-len) + "./") + ((= dst-len src-len) + dst) + (t + (subseq dst 0 dst-len))))) + +;;; +;;; STRING-LIST-TO-C-STRVEC -- Internal +;;; +;;; STRING-LIST-TO-C-STRVEC is a function which takes a list of +;;; simple-strings and constructs a C-style string vector (strvec) -- +;;; a null-terminated array of pointers to null-terminated strings. +;;; This function returns two values: a sap and a byte count. When the +;;; memory is no longer needed it should be deallocated with +;;; vm_deallocate. +;;; +(defun string-list-to-c-strvec (string-list) + ;; + ;; Make a pass over string-list to calculate the amount of memory + ;; needed to hold the strvec. + (let ((string-bytes 0) + (vec-bytes (* 4 (1+ (length string-list))))) + (declare (fixnum string-bytes vec-bytes)) + (dolist (s string-list) + (check-type s simple-string) + (incf string-bytes (round-bytes-to-words (1+ (length s))))) + ;; + ;; Now allocate the memory and fill it in. + (let* ((total-bytes (+ string-bytes vec-bytes)) + (vec-sap (system:allocate-system-memory total-bytes)) + (string-sap (sap+ vec-sap vec-bytes)) + (i 0)) + (declare (type (and unsigned-byte fixnum) total-bytes i) + (type system:system-area-pointer vec-sap string-sap)) + (dolist (s string-list) + (declare (simple-string s)) + (let ((n (length s))) + ;; + ;; Blast the string into place + #-unicode + (kernel:copy-to-system-area (the simple-string s) + (* vm:vector-data-offset vm:word-bits) + string-sap 0 + (* (1+ n) vm:byte-bits)) + #+unicode + (progn + ;; FIXME: Do we need to apply some kind of transformation + ;; to convert Lisp unicode strings to C strings? Utf-8? + (dotimes (k n) + (setf (sap-ref-8 string-sap k) + (logand #xff (char-code (aref s k))))) + (setf (sap-ref-8 string-sap n) 0)) + ;; + ;; Blast the pointer to the string into place + (setf (sap-ref-sap vec-sap i) string-sap) + (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n)))) + (incf i 4))) + ;; Blast in last null pointer + (setf (sap-ref-sap vec-sap i) (int-sap 0)) + (values vec-sap total-bytes)))) + +;;; Stuff not yet found in the header files... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Abandon all hope who enters here... + + +;; not checked for linux... +(defmacro fd-set (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logior (truly-the (unsigned-byte 32) (ash 1 ,bit)) + (deref (slot ,fd-set 'fds-bits) ,word)))))) + +;; not checked for linux... +(defmacro fd-clr (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (setf (deref (slot ,fd-set 'fds-bits) ,word) + (logand (deref (slot ,fd-set 'fds-bits) ,word) + (32bit-logical-not + (truly-the (unsigned-byte 32) (ash 1 ,bit)))))))) + +;; not checked for linux... +(defmacro fd-isset (offset fd-set) + (let ((word (gensym)) + (bit (gensym))) + `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits) + (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word))))) + +;; not checked for linux... +(defmacro fd-zero (fd-set) + `(progn + ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits) + collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0)))) + + + + +;;;; User and group database access, POSIX Standard 9.2.2 + +(defun unix-getpwnam (login) + _N"Return a USER-INFO structure for the user identified by LOGIN, or NIL if not found." + (declare (type simple-string login)) + (with-alien ((buf (array c-call:char 1024)) + (user-info (struct passwd)) + (result (* (struct passwd)))) + (let ((returned + (alien-funcall + (extern-alien "getpwnam_r" + (function c-call:int + c-call:c-string + (* (struct passwd)) + (* c-call:char) + c-call:unsigned-int + (* (* (struct passwd))))) + login + (addr user-info) + (cast buf (* c-call:char)) + 1024 + (addr result)))) + (when (zerop returned) + (make-user-info + :name (string (cast (slot result 'pw-name) c-call:c-string)) + :password (string (cast (slot result 'pw-passwd) c-call:c-string)) + :uid (slot result 'pw-uid) + :gid (slot result 'pw-gid) + :gecos (string (cast (slot result 'pw-gecos) c-call:c-string)) + :dir (string (cast (slot result 'pw-dir) c-call:c-string)) + :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))) + +(defun unix-getpwuid (uid) + _N"Return a USER-INFO structure for the user identified by UID, or NIL if not found." + (declare (type unix-uid uid)) + (with-alien ((buf (array c-call:char 1024)) + (user-info (struct passwd)) + (result (* (struct passwd)))) + (let ((returned + (alien-funcall + (extern-alien "getpwuid_r" + (function c-call:int + c-call:unsigned-int + (* (struct passwd)) + (* c-call:char) + c-call:unsigned-int + (* (* (struct passwd))))) + uid + (addr user-info) + (cast buf (* c-call:char)) + 1024 + (addr result)))) + (when (zerop returned) + (make-user-info + :name (string (cast (slot result 'pw-name) c-call:c-string)) + :password (string (cast (slot result 'pw-passwd) c-call:c-string)) + :uid (slot result 'pw-uid) + :gid (slot result 'pw-gid) + :gecos (string (cast (slot result 'pw-gecos) c-call:c-string)) + :dir (string (cast (slot result 'pw-dir) c-call:c-string)) + :shell (string (cast (slot result 'pw-shell) c-call:c-string))))))) + +(defun unix-getgrnam (name) + _N"Return a GROUP-INFO structure for the group identified by NAME, or NIL if not found." + (declare (type simple-string name)) + (with-alien ((buf (array c-call:char 2048)) + (group-info (struct group)) + (result (* (struct group)))) + (let ((returned + (alien-funcall + (extern-alien "getgrnam_r" + (function c-call:int + c-call:c-string + (* (struct group)) + (* c-call:char) + c-call:unsigned-int + (* (* (struct group))))) + name + (addr group-info) + (cast buf (* c-call:char)) + 2048 + (addr result)))) + (when (zerop returned) + (make-group-info + :name (string (cast (slot result 'gr-name) c-call:c-string)) + :password (string (cast (slot result 'gr-passwd) c-call:c-string)) + :gid (slot result 'gr-gid) + :members (loop :with members = (slot result 'gr-mem) + :for i :from 0 + :for member = (deref members i) + :until (zerop (sap-int (alien-sap member))) + :collect (string (cast member c-call:c-string)))))))) + +(defun unix-getgrgid (gid) + _N"Return a GROUP-INFO structure for the group identified by GID, or NIL if not found." + (declare (type unix-gid gid)) + (with-alien ((buf (array c-call:char 2048)) + (group-info (struct group)) + (result (* (struct group)))) + (let ((returned + (alien-funcall + (extern-alien "getgrgid_r" + (function c-call:int + c-call:unsigned-int + (* (struct group)) + (* c-call:char) + c-call:unsigned-int + (* (* (struct group))))) + gid + (addr group-info) + (cast buf (* c-call:char)) + 2048 + (addr result)))) + (when (zerop returned) + (make-group-info + :name (string (cast (slot result 'gr-name) c-call:c-string)) + :password (string (cast (slot result 'gr-passwd) c-call:c-string)) + :gid (slot result 'gr-gid) + :members (loop :with members = (slot result 'gr-mem) + :for i :from 0 + :for member = (deref members i) + :until (zerop (sap-int (alien-sap member))) + :collect (string (cast member c-call:c-string)))))))) + + +;; EOF View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/f260121544e4f793509b2bb2…

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs May 2015