Newer
Older
(defun unix-cfsetispeed (termios speed)
"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-cfsetispeed (termios speed)
"Set terminal input speed."
(void-syscall ("cfsetispeed" (* (struct termios)) int) termios speed))
(defun unix-tcsendbreak (fd duration)
"Send break"
(declare (type unix-fd fd))
(void-syscall ("tcsendbreak" int int) fd duration))
(defun unix-tcdrain (fd)
"Wait for output for finish"
(declare (type unix-fd fd))
(void-syscall ("tcdrain" int) fd))
(defun unix-tcflush (fd selector)
"See tcflush(3)"
(declare (type unix-fd fd))
(void-syscall ("tcflush" int int) fd selector))
(defun unix-tcflow (fd action)
"Flow control"
(declare (type unix-fd fd))
(void-syscall ("tcflow" int int) fd action)))
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
(defun tcsetpgrp (fd pgrp)
"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 tcgetpgrp (fd)
"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)
"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 %set-tty-process-group (pgrp &optional fd)
"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)
"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))
;;; Socket options.
#+(or hpux bsd)
(define-ioctl-command SIOCSPGRP #\s 8 int :in)
#+linux
(define-ioctl-command SIOCSPGRP #\s #x8904 int :in)
#+(or hpux bsd linux)
(defun siocspgrp (fd pgrp)
"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)))))
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
;;; Unix-exit terminates a program.
(defun unix-exit (&optional (code 0))
"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))
;;; STAT and friends.
(defmacro extract-stat-results (buf)
`(values T
(slot ,buf 'st-dev)
(slot ,buf 'st-ino)
(slot ,buf 'st-mode)
(slot ,buf 'st-nlink)
(slot ,buf 'st-uid)
(slot ,buf 'st-gid)
(slot ,buf 'st-rdev)
(slot ,buf 'st-size)
#-(or svr4 BSD) (slot ,buf 'st-atime)
#+BSD (slot (slot ,buf 'st-atime) 'ts-sec)
#-(or svr4 BSD)(slot ,buf 'st-mtime)
#+BSD(slot (slot ,buf 'st-mtime) 'ts-sec)
#-(or svr4 BSD) (slot ,buf 'st-ctime)
#+BSD(slot (slot ,buf 'st-ctime) 'ts-sec)
#-solaris
(progn
(defun unix-stat (name)
"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))
(with-alien ((buf (struct stat)))
(syscall ("stat" c-string (* (struct stat)))
(extract-stat-results buf)
(defun unix-lstat (name)
"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 ("lstat" c-string (* (struct stat)))
(extract-stat-results buf)
(defun unix-fstat (fd)
"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 ("fstat" int (* (struct stat)))
(extract-stat-results buf)
fd (addr buf))))
)
;;; 64-bit versions of stat and friends
#+solaris
(progn
(defun unix-stat (name)
"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 stat64)))
(syscall ("stat64" c-string (* (struct stat64)))
(extract-stat-results buf)
(defun unix-lstat (name)
"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 stat64)))
(syscall ("lstat64" c-string (* (struct stat64)))
(extract-stat-results buf)
(defun unix-fstat (fd)
"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 stat64)))
(syscall ("fstat64" int (* (struct stat64)))
(extract-stat-results buf)
fd (addr buf))))
)
(defconstant rusage_self 0 "The calling process.")
(defconstant rusage_children -1 "Terminated child processes.")
(declaim (inline unix-fast-getrusage))
(defun unix-fast-getrusage (who)
"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)
"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)))
(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))))
;;; Getrusage is not provided in the C library on Solaris 2.4, and is
;;; rather slow on later versions so the "times" system call is
;;; provided.
#+(and sparc svr4)
(progn
(def-alien-type nil
(struct tms
(tms-utime #-alpha long #+alpha int) ; user time used
(tms-stime #-alpha long #+alpha int) ; system time used.
(tms-cutime #-alpha long #+alpha int) ; user time, children
(tms-cstime #-alpha long #+alpha int))) ; system time, children
(declaim (inline unix-times))
(defun unix-times ()
"Unix-times returns information about the cpu time usage of the process
and its children."
(with-alien ((usage (struct tms)))
(alien-funcall (extern-alien "times" (function int (* (struct tms))))
(addr usage))
(values t
(slot usage 'tms-utime)
(slot usage 'tms-stime)
(slot usage 'tms-cutime)
(slot usage 'tms-cstime))))
) ; end progn
;; Requires call to tzset() in main.
;; Don't use this now: we
(progn
(def-alien-variable ("daylight" unix-daylight) int)
(def-alien-variable ("timezone" unix-timezone) time-t)
(def-alien-variable ("altzone" unix-altzone) time-t)
#-irix (def-alien-variable ("tzname" unix-tzname) (array c-string 2))
#+irix (defvar unix-tzname-addr nil)
#+irix (pushnew #'(lambda () (setq unix-tzname-addr nil))
ext:*after-save-initializations*)
#+irix (declaim (notinline fakeout-compiler))
#+irix (defun fakeout-compiler (name dst)
(unless unix-tzname-addr
(setf unix-tzname-addr (system:foreign-symbol-address
name
:flavor :data)))
(deref (sap-alien unix-tzname-addr (array c-string 2)) dst))
(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 #-irix (deref unix-tzname (if dst 1 0))
#+irix (fakeout-compiler "tzname" (if dst 1 0)))
(declaim (inline unix-gettimeofday))
(defun unix-gettimeofday ()
"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))
#-svr4 (tz (struct timezone)))
(syscall* ("gettimeofday" (* (struct timeval)) #-svr4 (* (struct timezone)))
(values T
(slot tv 'tv-sec)
(slot tv 'tv-usec)
#-svr4 (slot tz 'tz-minuteswest)
#+svr4 (unix-get-minutes-west (slot tv 'tv-sec))
#-svr4 (slot tz 'tz-dsttime)
#+svr4 (unix-get-timezone (slot tv 'tv-sec))
)
(addr tv)
;;; 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.
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
(defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec)
"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))))))
;;; 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)
"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))
;;; 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)
"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))
(def-alien-routine ("getpid" unix-getpid) int
"Unix-getpid returns the process-id of the current process.")
(def-alien-routine ("getppid" unix-getppid) int
"Unix-getppid returns the process-id of the parent of the current process.")
(def-alien-routine ("getgid" unix-getgid) int
"Unix-getgid returns the real group-id of the current process.")
(def-alien-routine ("getegid" unix-getegid) int
"Unix-getegid returns the effective group-id of the current process.")
;;; Unix-getpgrp returns the group-id associated with the
;;; current process.
(defun unix-getpgrp ()
"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)
"Unix-setpgrp sets the process group on the process pid to
pgrp. NIL and an error number are returned upon failure."
(void-syscall (#-svr4 "setpgrp" #+svr4 "setpgid" int int) pid pgrp))
(defun unix-setpgid (pid pgrp)
"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))
(def-alien-routine ("getuid" unix-getuid) int
"Unix-getuid returns the real user-id associated with the
current process.")
;;; Unix-getpagesize returns the number of bytes in the system page.
(defun unix-getpagesize ()
"Unix-getpagesize returns the number of bytes in a system page."
(int-syscall ("getpagesize")))
(defun unix-gethostname ()
"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)))
(def-alien-routine ("gethostid" unix-gethostid) unsigned-long
"Unix-gethostid returns a 32-bit integer which provides unique
identification for the host machine.")
(defun unix-fork ()
"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")))
(def-alien-routine ("getenv" unix-getenv) c-call:c-string
(name c-call:c-string)
"Get the value of the environment variable named Name. If no such
variable exists, Nil is returned.")
;; This doesn't exist in Solaris 8 but does exist in Solaris 10.
(def-alien-routine ("setenv" unix-setenv) c-call:int
(overwrite c-call:int)
"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-value c-call:c-string)
"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.")
;; This doesn't exist in Solaris 8 but does exist in Solaris 10.
(def-alien-routine ("unsetenv" unix-unsetenv) c-call:int
(name c-call:c-string)
"Removes the variable Name from the environment")
;;; Operations on Unix Directories.
(export '(open-dir read-dir close-dir))
(defstruct (%directory
(:conc-name directory-)
(:constructor make-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))
(let ((kind (unix-file-kind pathname)))
(case kind
(:directory
(let ((dir-struct
(alien-funcall (extern-alien "opendir"
(function system-area-pointer
c-string))
(values nil (unix-errno))
(make-directory :name pathname :dir-struct dir-struct))))
((nil)
(values nil enoent))
(t
(values nil enotdir)))))
#-(and bsd (not solaris))
(declare (type %directory dir))
(let ((daddr (alien-funcall (extern-alien "readdir"
(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 ((direct (* (struct direct)) daddr))
(let ((nlen (slot direct 'd-namlen))
(ino (slot direct 'd-ino)))
(declare (type (unsigned-byte 16) nlen))
(let ((string (make-string nlen)))
(kernel:copy-from-system-area
(alien-sap (addr (slot direct 'd-name))) 0
string (* vm:vector-data-offset vm:word-bits)
(* nlen vm:byte-bits))
#+unicode
(let ((sap (alien-sap (addr (slot direct 'd-name)))))
(dotimes (k nlen)
(setf (aref string k)
(code-char (sap-ref-8 sap k)))))
(values (%file->name string) ino)))
(values (%file->name (cast (slot direct 'd-name) c-string))
;;; 64-bit readdir for Solaris
#+solaris
(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 ((direct (* (struct dirent64)) daddr))
#-(or linux svr4)
(let ((nlen (slot direct 'd-namlen))
(ino (slot direct 'd-ino)))
(declare (type (unsigned-byte 16) nlen))
(let ((string (make-string nlen)))
(kernel:copy-from-system-area
(alien-sap (addr (slot direct 'd-name))) 0
string (* vm:vector-data-offset vm:word-bits)
(* nlen vm:byte-bits))
#+unicode
(let ((sap (alien-sap (addr (slot direct 'd-name)))))
(dotimes (k nlen)
(setf (aref string k)
(code-char (sap-ref-8 sap k)))))
(values (%file->name string) ino)))
#+(or linux svr4)
(values (%file->name (cast (slot direct 'd-name) c-string))
(slot direct 'd-ino))))))
#+(and bsd (not solaris))
(declare (type %directory dir))
(let ((daddr (alien-funcall (extern-alien "readdir"
(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 ((direct (* (struct direct)) daddr))
(let ((nlen (slot direct 'd-namlen))
(fino (slot direct 'd-fileno)))
(declare (type (unsigned-byte 8) nlen)
(type (unsigned-byte 32) fino))
(let ((string (make-string nlen)))
(kernel:copy-from-system-area
(alien-sap (addr (slot direct 'd-name))) 0
string (* vm:vector-data-offset vm:word-bits)
(* nlen vm:byte-bits))
#+unicode
(let ((sap (alien-sap (addr (slot direct 'd-name)))))
(dotimes (k nlen)
(setf (aref string k)
(code-char (sap-ref-8 sap k)))))
(values (%file->name string) fino)))))))
(declare (type %directory dir))
(alien-funcall (extern-alien "closedir"
(function void system-area-pointer))
(directory-dir-struct dir))
nil)
;; Use getcwd instead of getwd. But what should we do if the path
;; won't fit? Try again with a larger size? We don't do that right
;; now.
;; 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))))))
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
;;;; 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)
"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)
"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)))
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
(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 "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))
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
(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)))))
;;;; Other random routines.
(def-alien-routine ("isatty" unix-isatty) boolean
"Accepts a Unix file descriptor and returns T if the device
associated with it is a terminal."
(fd int))
(def-alien-routine ("ttyname" unix-ttyname) c-string
(fd int))
(def-alien-routine ("openpty" unix-openpty) int
(amaster int :out)
(aslave int :out)
(name c-string)
(termp (* (struct termios)))
(winp (* (struct winsize))))
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
;;;; UNIX-EXECVE
(defun unix-execve (program &optional arg-list
(environment *environment-list*))
"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)))
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
(defmacro round-bytes-to-words (n)
`(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
;;;
;;; 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
(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))))
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
;; Blast in last null pointer
(setf (sap-ref-sap vec-sap i) (int-sap 0))
(values vec-sap total-bytes))))
(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)))
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
;;
;; Deallocate memory
(when argv
(system:deallocate-system-memory argv argv-bytes))
(when envp
(system:deallocate-system-memory envp envp-bytes)))
(values result error-code)))
;;;; Socket support.
(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)