X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Funix.lisp;h=0a25f7b6240ac08200ae3ebe4498119ec5823a60;hb=67f787e86602efc7e4007fb6bbc970a2fcf613f5;hp=f23ea28370e41238065d3e6dcabbe84e207c6534;hpb=3fbcd9b98c58d80858d1e0f9834aaaa83283cbba;p=sbcl.git diff --git a/src/code/unix.lisp b/src/code/unix.lisp index f23ea28..0a25f7b 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -114,7 +114,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-win32 (define-alien-routine ("getenv" posix-getenv) c-string "Return the \"value\" part of the environment string \"name=value\" which - corresponds to NAME, or NIL if there is none." +corresponds to NAME, or NIL if there is none." (name c-string)) ;;; from stdio.h @@ -180,16 +180,22 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;;; stdlib.h ;;; There are good reasons to implement some OPEN options with an -;;; mkstemp(3) followed by a fchmod(2) followed by a rename(2), but we -;;; don't do that yet. Instead, this function is used only to make a -;;; temporary file for RUN-PROGRAM. sb_mkstemp() is a wrapper that -;;; lives in src/runtime/wrap.c. -(defun unix-mkstemp (template-string) - (let ((template-buffer (string-to-octets template-string))) +;;; mkstemp(3)-like routine, but we don't do that yet. Instead, this +;;; function is used only to make a temporary file for RUN-PROGRAM. +;;; sb_mkstemp() is a wrapper that lives in src/runtime/wrap.c. Since +;;; SUSv3 mkstemp() doesn't specify the mode of the created file and +;;; since we have to implement most of this ourselves for Windows +;;; anyway, it seems worthwhile to depart from the mkstemp() +;;; specification by taking a mode to use when creating the new file. +(defun sb-mkstemp (template-string mode) + (declare (type string template-string) + (type unix-file-mode mode)) + (let ((template-buffer (string-to-octets template-string :null-terminate t))) (with-pinned-objects (template-buffer) (let ((fd (alien-funcall (extern-alien "sb_mkstemp" - (function int (* char))) - (vector-sap template-buffer)))) + (function int (* char) int)) + (vector-sap template-buffer) + mode))) (if (minusp fd) (values nil (get-errno)) (values fd (octets-to-string template-buffer))))))) @@ -296,6 +302,10 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; 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. + +#!-sb!fluid +(declaim (maybe-inline unix-read)) + (defun unix-read (fd buf len) (declare (type unix-fd fd) (type (unsigned-byte 32) len)) @@ -463,6 +473,20 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (declare (ignore path)) nil) +(defun unix-realpath (path) + (declare (type unix-pathname path)) + (with-alien ((ptr (* char) + (alien-funcall (extern-alien + "sb_realpath" + (function (* char) c-string)) + path))) + (if (null-alien ptr) + (values nil (get-errno)) + (multiple-value-prog1 + (values (with-alien ((c-string c-string ptr)) c-string) + nil) + (free-alien ptr))))) + ;;; 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) @@ -743,17 +767,6 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (syscall ("fstat_wrapper" int (* (struct wrapped_stat))) (%extract-stat-results (addr buf)) fd (addr buf)))) - -;;; RUN-PROGRAM creates temporary files with mkstemp, but SUSv3 -;;; doesn't specify the mode of a newly created file under mkstemp, -;;; and C libraries may vary, so we fix the mode ourselves. -;;; Eventually some OPEN actions should probably be implemented with -;;; mkstemp(3)/chmod(2)/rename(2) as well. -#!-win32 -(defun unix-chmod (path mode) - (declare (type unix-pathname path) - (type unix-file-mode mode)) - (void-syscall ("chmod" c-string int) path mode)) ;;;; time.h @@ -938,76 +951,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!-win32 ((eql kind s-iflnk) :link) (t :special)))))) - -;;; Is the Unix pathname PATHNAME relative, instead of absolute? (E.g. -;;; "passwd" or "etc/passwd" instead of "/etc/passwd"?) -(defun relative-unix-pathname? (pathname) - (declare (type simple-string pathname)) - (or (zerop (length pathname)) - (char/= (schar pathname 0) #\/))) - -;;; Return PATHNAME with all symbolic links resolved. PATHNAME should -;;; already be a complete absolute Unix pathname, since at least in -;;; sbcl-0.6.12.36 we're called only from TRUENAME, and only after -;;; paths have been converted to absolute paths, so we don't need to -;;; try to handle any more generality than that. -(defun unix-resolve-links (pathname) - (declare (type simple-string pathname)) - ;; KLUDGE: The Win32 platform doesn't have symbolic links, so - ;; short-cut this computation (and the check for being an absolute - ;; unix pathname...) - #!+win32 (return-from unix-resolve-links pathname) - (aver (not (relative-unix-pathname? pathname))) - ;; KLUDGE: readlink and lstat are unreliable if given symlinks - ;; ending in slashes -- fix the issue here instead of waiting for - ;; libc to change... - ;; - ;; but be careful! Must not strip the final slash from "/". (This - ;; adjustment might be a candidate for being transferred into the C - ;; code in a wrap_readlink() function, too.) CSR, 2006-01-18 - (let ((len (length pathname))) - (when (and (> len 1) (eql #\/ (schar pathname (1- len)))) - (setf pathname (subseq pathname 0 (1- len))))) - (/noshow "entering UNIX-RESOLVE-LINKS") - (loop with previous-pathnames = nil do - (/noshow pathname previous-pathnames) - (let ((link (unix-readlink pathname))) - (/noshow link) - ;; Unlike the old CMU CL code, we handle a broken symlink by - ;; returning the link itself. That way, CL:TRUENAME on a - ;; broken link returns the link itself, so that CL:DIRECTORY - ;; can return broken links, so that even without - ;; Unix-specific extensions to do interesting things with - ;; them, at least Lisp programs can see them and, if - ;; necessary, delete them. (This is handy e.g. when your - ;; managed-by-Lisp directories are visited by Emacs, which - ;; creates broken links as notes to itself.) - (if (null link) - (return pathname) - (let ((new-pathname - (simplify-namestring - (if (relative-unix-pathname? link) - (let* ((dir-len (1+ (position #\/ - pathname - :from-end t))) - (dir (subseq pathname 0 dir-len))) - (/noshow dir) - (concatenate 'string dir link)) - link)))) - (if (unix-file-kind new-pathname) - (setf pathname new-pathname) - (return pathname))))) - ;; To generalize the principle that even if portable Lisp code - ;; can't do anything interesting with a broken symlink, at - ;; least it should be able to see and delete it, when we - ;; detect a cyclic link, we return the link itself. (So even - ;; though portable Lisp code can't do anything interesting - ;; with a cyclic link, at least it can see it and delete it.) - (if (member pathname previous-pathnames :test #'string=) - (return pathname) - (push pathname previous-pathnames)))) - (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second))