#!-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))
\f
;;; from stdio.h
;;;; 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)))))))
;;; 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))
;; comma not inside a backquote. This error has absolutely nothing
;; to do with the actual meaning of the error (and little to do with
;; its location, either).
- #!-(or linux openbsd freebsd netbsd sunos osf1 darwin win32) (,stub,)
- #!+(or linux openbsd freebsd netbsd sunos osf1 darwin win32)
+ #!-(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32) (,stub,)
+ #!+(or linux openbsd freebsd netbsd sunos osf1 darwin hpux win32)
(or (newcharstar-string (alien-funcall (extern-alien "getcwd"
(function (* char)
(* char)
size-t))
nil
#!+(or linux openbsd freebsd netbsd darwin win32) 0
- #!+(or sunos osf1) 1025))
+ #!+(or sunos osf1 hpux) 1025))
(simple-perror "getcwd")))
;;; Return the Unix current directory as a SIMPLE-STRING terminated
(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)
(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))
\f
;;;; time.h
#!-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))))
\f
-
(defconstant micro-seconds-per-internal-time-unit
(/ 1000000 sb!xc:internal-time-units-per-second))