Commit 60d0d7bb authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'rtoy-issue-84-remove-unix-glibc2' into 'master'

Fix #84: Remove code/unix-glibc2.lisp

Closes #84

See merge request cmucl/cmucl!51
parents 974366fb 00679e6b
Pipeline #1778 passed with stage
in 9 minutes and 33 seconds
;;; -*- 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)
(pushnew :unix *features*)
(pushnew :glibc2 *features*)
;; needed for bootstrap
(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))
(defconstant +max-u-long+ 4294967295)
(def-alien-type size-t #-alpha unsigned-int #+alpha long)
(def-alien-type time-t long)
(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 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)
;;;; Common machine independent structures.
;; 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))))))
;;; 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"))
#-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")
(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))
;;; asm/errno.h
(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*)))))
)
(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)
(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
;;;; 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))
;;; 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)))))
;;; 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-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")))
;;; 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)))
;;; 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))))
(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))))
;; 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.")
(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