From 30918f91c144b51c5c204427b2fd70d49b8d1407 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sun, 3 Feb 2008 01:20:43 +0000 Subject: [PATCH] 1.0.14.12: export SB-POSIX:MKSTEMP, add SB-POSIX:MKTEMP and SB-POSIX:MKDTEMP * Remove the alien struct consing from the calls -- just use the SAP directly. * Automagic unsupportedness handling for platforms that miss any of these. * Rudimentary tests. * #-win32 for now. --- NEWS | 2 ++ contrib/sb-posix/interface.lisp | 69 +++++++++++++++++++++++++++------------ contrib/sb-posix/macros.lisp | 3 +- contrib/sb-posix/posix-tests.lisp | 41 +++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 95 insertions(+), 22 deletions(-) diff --git a/NEWS b/NEWS index 54bd73034..bc52ee2e6 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,8 @@ changes in sbcl-1.0.15 relative to sbcl-1.0.14: * enhancement: untracing a whole package using (UNTRACE "FOO") is now supported, and tracing a whole package using (TRACE "FOO") now traces SETF-functions as well. + * enhancement: implement SB-POSIX:MKTEMP and SB-POSIX:MKDTEMP. + * bug fix: export SB-POSIX:MKSTEMP. * bug fix: SORT was not interrupt safe. * bug fix: XREF accounts for the last node of each basic-block as well. diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 541c3c96f..5704d3f26 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -81,6 +81,14 @@ (let ((errno (get-errno))) (error (elt *errno-table* errno) :errno errno))) +(defun unsupported-error (lisp-name c-name) + (error "~S is unsupported by SBCL on this platform due to lack of ~A()." + lisp-name c-name)) + +(defun unsupported-warning (lisp-name c-name) + (warn "~S is unsupported by SBCL on this platform due to lack of ~A()." + lisp-name c-name)) + ;; Note that we inherit from SIMPLE-FILE-ERROR first, to get its ;; error reporting, rather than SYSCALL-ERROR's. (define-condition file-syscall-error @@ -221,26 +229,47 @@ (define-call "sync" void never-fails) (define-call ("truncate" :options :largefile) int minusp (pathname filename) (length off-t)) - ;; FIXME: Windows does have _mktemp, which has a slightlty different - ;; interface - (defun mkstemp (template) - ;; we are emulating sb-alien's charset conversion for strings - ;; here, to accommodate for the call-by-reference nature of - ;; mkstemp's template strings. - (let ((arg (sb-ext:string-to-octets - (filename template) - :external-format sb-alien::*default-c-string-external-format*))) - (sb-sys:with-pinned-objects (arg) - (let ((result (alien-funcall (extern-alien "mkstemp" - (function int c-string)) - (sap-alien (sb-alien::vector-sap arg) - (* char))))) - (when (minusp result) - (syscall-error)) - (values result - (sb-ext:octets-to-string - arg - :external-format sb-alien::*default-c-string-external-format*)))))) + #-win32 + (macrolet ((def-mk*temp (lisp-name c-name result-type errorp dirp values) + (declare (ignore dirp)) + (if (sb-sys:find-foreign-symbol-address c-name) + `(progn + (defun ,lisp-name (template) + (let* ((external-format sb-alien::*default-c-string-external-format*) + (arg (sb-ext:string-to-octets + (filename template) + :external-format external-format))) + (sb-sys:with-pinned-objects (arg) + ;; accommodate for the call-by-reference + ;; nature of mks/dtemp's template strings. + (let ((result (alien-funcall (extern-alien ,c-name + (function ,result-type system-area-pointer)) + (sb-alien::vector-sap arg)))) + (when (,errorp result) + (syscall-error)) + ;; FIXME: We'd rather return pathnames, but other + ;; SB-POSIX functions like this return strings... + (let ((pathname (sb-ext:octets-to-string + arg :external-format external-format))) + ,(if values + '(values result pathname) + 'pathname)))))) + (export ',lisp-name)) + `(progn + (defun ,lisp-name (template) + (declare (ignore template)) + (unsupported-error ',lisp-name ,c-name)) + (define-compiler-macro ,lisp-name (&whole form template) + (declare (ignore template)) + (unsupported-warning ',lisp-name ,c-name) + form) + (export ',lisp-name))))) + (def-mk*temp mktemp "mktemp" (* char) null-alien nil nil) + ;; FIXME: Windows does have _mktemp, which has a slightly different + ;; interface + (def-mk*temp mkstemp "mkstemp" int minusp nil t) + ;; FIXME: What about Windows? + (def-mk*temp mkdtemp "mkdtemp" (* char) null-alien t nil)) (define-call-internally ioctl-without-arg "ioctl" int minusp (fd file-descriptor) (cmd int)) (define-call-internally ioctl-with-int-arg "ioctl" int minusp diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index 018ff62de..2e15e10ef 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -2,7 +2,8 @@ (define-designator filename c-string (pathname - (sb-ext:native-namestring (translate-logical-pathname filename))) + (sb-ext:native-namestring (translate-logical-pathname filename) + :as-file t)) (string filename)) (define-designator file-descriptor (integer 32) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 98687c23c..71f218c74 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -684,3 +684,44 @@ ;; FIXME: something saner, please (equal (sb-unix::posix-getcwd) (sb-posix:getcwd)) t) + +#-win32 +(deftest mkstemp.1 + (multiple-value-bind (fd temp) + (sb-posix:mkstemp (make-pathname + :name "mkstemp-1" + :type "XXX" + :defaults *test-directory*)) + (let ((pathname (sb-ext:parse-native-namestring temp))) + (unwind-protect + (values (integerp fd) (pathname-name pathname)) + (delete-file temp)))) + t "mkstemp-1") + +#-win32 +(deftest mkdtemp.1 + (let ((pathname + (sb-ext:parse-native-namestring + (sb-posix:mkdtemp (make-pathname + :name "mkdtemp-1" + :type "XXX" + :defaults *test-directory*)) + nil + *default-pathname-defaults* + :as-directory t))) + (unwind-protect + (values (let* ((xxx (car (last (pathname-directory pathname)))) + (p (position #\. xxx))) + (and p (subseq xxx 0 p))) + (pathname-name pathname) + (pathname-type pathname)) + (sb-posix:rmdir pathname))) + "mkdtemp-1" nil nil) + +#-win32 +(deftest mktemp.1 + (let ((pathname (sb-ext:parse-native-namestring + (sb-posix:mktemp #p"mktemp.XXX")))) + (values (equal "mktemp" (pathname-name pathname)) + (not (equal "XXX" (pathname-type pathname))))) + t t) diff --git a/version.lisp-expr b/version.lisp-expr index da95f3c42..58cf8a030 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.14.11" +"1.0.14.12" -- 2.11.4.GIT