X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=7f717804284a61415814ee0508ca9e584ef98470;hb=98a76d4426660876dec6649b1e228d2e5b47f579;hp=fbae02174becc25a8cf330cd41bd8bf5fc5e854e;hpb=e33fb894f991b2926d8f3bace9058e4c0b2c3a37;p=sbcl.git

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index fbae021..7f71780 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -47,7 +47,7 @@
 
 ;;;; Lisp types used by syscalls
 
-(deftype unix-pathname () 'simple-string)
+(deftype unix-pathname () 'simple-base-string)
 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
 
 (deftype unix-file-mode () '(unsigned-byte 32))
@@ -204,6 +204,11 @@
 (defconstant l_incr 1) ; to increment the file pointer
 (defconstant l_xtnd 2) ; to extend the file size
 
+;;; Is a stream interactive?
+(defun unix-isatty (fd)
+  (declare (type unix-fd fd))
+  (int-syscall ("isatty" int) fd))
+
 ;;; Accept a file descriptor and move the file pointer ahead
 ;;; a certain offset for that file. WHENCE can be any of the following:
 ;;;  L_SET     Set the file pointer.
@@ -264,6 +269,16 @@
 	   (type unix-file-mode mode))
   (void-syscall ("mkdir" c-string int) name mode))
 
+;;; Given a C char* pointer allocated by malloc(), free it and return a
+;;; corresponding Lisp string (or return NIL if the pointer is a C NULL).
+(defun newcharstar-string (newcharstar)
+  (declare (type (alien (* char)) newcharstar))
+  (if (null-alien newcharstar)
+      nil
+      (prog1
+	  (cast newcharstar c-string)
+	(free-alien newcharstar))))
+
 ;;; Return the Unix current directory as a SIMPLE-STRING, in the
 ;;; style returned by getcwd() (no trailing slash character). 
 (defun posix-getcwd ()
@@ -271,16 +286,24 @@
   ;; behavior, automatically allocating memory when a null buffer
   ;; pointer is used. On a system which doesn't support that
   ;; extension, it'll have to be rewritten somehow.
-  #!-(or linux openbsd freebsd) (,stub,)
-  (let* ((raw-char-ptr (alien-funcall (extern-alien "getcwd"
-						    (function (* char)
-							      (* char) size-t))
-				      nil 0)))
-    (if (null-alien raw-char-ptr)
-	(simple-perror "getcwd")
-	(prog1
-	    (cast raw-char-ptr c-string)
-	  (free-alien raw-char-ptr)))))
+  ;;
+  ;; SunOS and OSF/1 provide almost as useful an extension: if given a null
+  ;; buffer pointer, it will automatically allocate size space. The
+  ;; KLUDGE in this solution arises because we have just read off
+  ;; PATH_MAX+1 from the Solaris header files and stuck it in here as
+  ;; a constant. Going the grovel_headers route doesn't seem to be
+  ;; helpful, either, as Solaris doesn't export PATH_MAX from
+  ;; unistd.h.
+  #!-(or linux openbsd freebsd sunos osf1) (,stub,)
+  #!+(or linux openbsd freebsd sunos osf1)
+  (or (newcharstar-string (alien-funcall (extern-alien "getcwd"
+						       (function (* char)
+								 (* char)
+								 size-t))
+					 nil 
+					 #!+(or linux openbsd freebsd) 0
+					 #!+(or sunos osf1) 1025))
+      (simple-perror "getcwd")))
 
 ;;; Return the Unix current directory as a SIMPLE-STRING terminated
 ;;; by a slash character.
@@ -320,9 +343,24 @@
 ;;; Return the process id of the current process.
 (define-alien-routine ("getpid" unix-getpid) int)
 
-;;; Return the real user-id associated with the current process.
+;;; Return the real user id associated with the current process.
 (define-alien-routine ("getuid" unix-getuid) int)
 
+;;; Translate a user id into a login name.
+(defun uid-username (uid)
+  (or (newcharstar-string (alien-funcall (extern-alien "uid_username"
+						       (function (* char) int))
+					 uid))
+      (error "found no match for Unix uid=~S" uid)))
+
+;;; Return the namestring of the home directory, being careful to
+;;; include a trailing #\/
+(defun uid-homedir (uid)
+  (or (newcharstar-string (alien-funcall (extern-alien "uid_homedir"
+						       (function (* char) int))
+					 uid))
+      (error "failed to resolve home directory for Unix uid=~S" uid)))
+
 ;;; Invoke readlink(2) on the file name specified by PATH. Return
 ;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
 ;;; failure.
@@ -358,6 +396,10 @@
   (declare (type unix-fd fd))
   (void-syscall ("fsync" int) fd))
 
+
+(defun unix-setsid ()
+  (int-syscall ("setsid")))
+
 ;;;; sys/ioctl.h
 
 ;;; UNIX-IOCTL performs a variety of operations on open i/o
@@ -372,8 +414,9 @@
 
 ;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
 ;;;
-;;; Like getrusage(2), but return only the system and user time,
-;;; and return the seconds and microseconds as separate values.
+;;; This is like getrusage(2), except it returns only the system and
+;;; user time, and returns the seconds and microseconds as separate
+;;; values.
 #!-sb-fluid (declaim (inline unix-fast-getrusage))
 (defun unix-fast-getrusage (who)
   (declare (values (member t)
@@ -607,9 +650,9 @@
 	    (tm-gmtoff long) ;  Seconds east of UTC.
 	    (tm-zone c-string))) ; Timezone abbreviation.
 
-(define-alien-routine get-timezone sb!c-call:void
-  (when sb!c-call:long :in)
-  (minutes-west sb!c-call:int :out)
+(define-alien-routine get-timezone sb!alien:void
+  (when sb!alien:long :in)
+  (minutes-west sb!alien:int :out)
   (daylight-savings-p sb!alien:boolean :out))
 
 (defun unix-get-minutes-west (secs)
@@ -651,6 +694,98 @@
 	      (addr tz))))
 
 
+;; Type of the second argument to `getitimer' and
+;; the second and third arguments `setitimer'. 
+(define-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)
+  "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)
+  " 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))))))
+
+(defmacro sb!ext::with-timeout (expires &body body)
+  "Execute the body, interrupting it with a SIGALRM after at least
+EXPIRES seconds have passed.  Uses Unix setitimer(), restoring any
+previous timer after the body has finished executing"
+  (let ((saved-seconds (gensym "SAVED-SECONDS"))
+	(saved-useconds (gensym "SAVED-USECONDS"))
+	(s (gensym "S")) (u (gensym "U")))
+    `(let (- ,saved-seconds ,saved-useconds)
+      (multiple-value-setq (- - - ,saved-seconds ,saved-useconds)
+	(unix-getitimer :real))
+      (multiple-value-bind (,s ,u) (floor ,expires)
+	(setf ,u (floor (* ,u 1000000)))
+	(if (and (> ,expires 0)
+		 (or (and (zerop ,saved-seconds) (zerop ,saved-useconds))
+		     (> ,saved-seconds ,s)
+		     (and (= ,saved-seconds ,s)
+			  (> ,saved-useconds ,u))))
+	    (unwind-protect
+		 (progn
+		   (unix-setitimer :real 0 0 ,s ,u)
+		   ,@body)
+	      (unix-setitimer :real 0 0 ,saved-seconds ,saved-useconds))
+	    ,@body)))))
+
+
+
 (defconstant ENOENT 2) ; Unix error code, "No such file or directory"
 (defconstant EINTR 4) ; Unix error code, "Interrupted system call"
 (defconstant EIO 5) ; Unix error code, "I/O error"
@@ -670,7 +805,7 @@
 (defun unix-file-kind (name &optional check-for-links)
   #!+sb-doc
   "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
-  (declare (simple-string name))
+  (declare (simple-base-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)
@@ -821,6 +956,17 @@
 	  (t
 	   (subseq dst 0 dst-len)))))
 
+;;;; A magic constant for wait3().
+;;;;
+;;;; FIXME: This used to be defined in run-program.lisp as
+;;;; (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced)
+;;;; According to some of the man pages, the #o177 is part of the API
+;;;; for wait3(); that said, under SunOS there is a WSTOPPED thing in
+;;;; the headers that may or may not be the same thing. To be
+;;;; investigated. -- CSR, 2002-03-25
+(defconstant wstopped #o177)
+
+
 ;;;; stuff not yet found in the header files
 ;;;;
 ;;;; Abandon all hope who enters here...