[osicat-cvs] CVS update: src/ffi.lisp src/osicat-glue.c src/osicat.lisp src/packages.lisp src/test-osicat.lisp src/test-tools.lisp
Julian E. C. Squires
jsquires at common-lisp.net
Tue Jul 5 16:55:49 UTC 2005
Update of /project/osicat/cvsroot/src
In directory common-lisp.net:/tmp/cvs-serv17972
Modified Files:
ffi.lisp osicat-glue.c osicat.lisp packages.lisp
test-osicat.lisp test-tools.lisp
Log Message:
Experimental addition of MAKE-TEMPORARY-FILE, WITH-TEMPORARY-FILE.
Some minor cleanups.
Date: Tue Jul 5 18:55:47 2005
Author: jsquires
Index: src/ffi.lisp
diff -u src/ffi.lisp:1.3 src/ffi.lisp:1.4
--- src/ffi.lisp:1.3 Fri Apr 23 02:01:20 2004
+++ src/ffi.lisp Tue Jul 5 18:55:46 2005
@@ -69,6 +69,10 @@
:module "osicat"
:returning :cstring)
+(def-function "osicat_tmpfile" ()
+ :module "osicat"
+ :returning :int)
+
;;;; PLAIN POSIX
(def-function "opendir" ((name :cstring))
@@ -130,3 +134,7 @@
(def-function "chdir" ((name :cstring))
:module "osicat"
:returning :int)
+
+(def-function "tmpnam" ((template :cstring))
+ :module "osicat"
+ :returning :cstring)
\ No newline at end of file
Index: src/osicat-glue.c
diff -u src/osicat-glue.c:1.8 src/osicat-glue.c:1.9
--- src/osicat-glue.c:1.8 Fri Apr 23 02:01:20 2004
+++ src/osicat-glue.c Tue Jul 5 18:55:46 2005
@@ -25,6 +25,7 @@
#include <sys/stat.h>
#include <pwd.h>
#include <errno.h>
+#include <unistd.h>
extern int
osicat_mode (char * name, int follow_p)
@@ -116,3 +117,16 @@
return pwent->pw_shell;
}
+
+#include <stdio.h>
+#include <stdlib.h>
+
+extern int
+osicat_tmpfile (void)
+{
+ FILE *fp;
+
+ fp = tmpfile ();
+ if (fp == NULL) return -1;
+ return fileno (fp);
+}
Index: src/osicat.lisp
diff -u src/osicat.lisp:1.31 src/osicat.lisp:1.32
--- src/osicat.lisp:1.31 Mon Jul 26 15:25:30 2004
+++ src/osicat.lisp Tue Jul 5 18:55:46 2005
@@ -45,7 +45,7 @@
regular-file symbolic-link pipe socket))
(t (error
'bug :message
- (format nil "Unknown file mode: ~H." mode)))))))))
+ (format nil "Unknown file mode: ~A." mode)))))))))
(def))
(defmacro with-c-file
@@ -129,6 +129,39 @@
(with-cstring (cfile (namestring path))
(c-file-kind cfile nil))))
+;;;; Temporary files
+
+(defun make-temporary-file (&key (element-type 'character))
+ "function MAKE-TEMPORARY-FILE (&key element-type) => stream
+
+Makes a temporary file setup for input and output, and returns a
+stream connected to that file. ELEMENT-TYPE specifies the unit of
+transaction of the stream.
+
+On failure, a FILE-ERROR may be signalled."
+ #+(or cmu sbcl)
+ (let ((fd (osicat-tmpfile)))
+ (unless (>= fd 0) (signal 'file-error))
+ #+cmu(sys:make-fd-stream fd :input t :output t
+ :element-type element-type)
+ #+sbcl(sb-sys:make-fd-stream fd :input t :output t
+ :element-type element-type))
+ ;; XXX Warn about insecurity? Or is any platform too dumb to have
+ ;; fds, also relatively safe from race conditions through obscurity?
+ ;; XXX Another bug with this: the file doesn't get unlinked.
+ #-(or cmu sbcl)
+ (open (tmpnam nil) :direction :io :element-type element-type))
+
+
+(defmacro with-temporary-file ((stream &key element-type) &body body)
+ "macro WITH-TEMPORARY-FILE (stream &key element-type) &body body => stream"
+ `(let ((,stream (make-temporary-file
+ ,@(when element-type
+ `(:element-type ,element-type)))))
+ (unwind-protect
+ (progn , at body)
+ (close ,stream :abort t))))
+
;;;; Directory access
(defmacro with-directory-iterator ((iterator pathspec) &body body)
@@ -346,7 +379,7 @@
(if hard "hard" "symbolic") new old))))
(setf (current-directory) old))))
-;;; File permissions
+;;;; File permissions
(defconstant +permissions+ (if (boundp '+permissions+)
(symbol-value '+permissions+)
Index: src/packages.lisp
diff -u src/packages.lisp:1.12 src/packages.lisp:1.13
--- src/packages.lisp:1.12 Sun Apr 25 16:59:06 2004
+++ src/packages.lisp Tue Jul 5 18:55:46 2005
@@ -57,6 +57,9 @@
#:make-link
;; Permissions
#:file-permissions
+ ;; Temporary files
+ #:make-temporary-file
+ #:with-temporary-file
;; Password entries
#:user-info
;; Version info
Index: src/test-osicat.lisp
diff -u src/test-osicat.lisp:1.10 src/test-osicat.lisp:1.11
--- src/test-osicat.lisp:1.10 Sun Apr 25 17:10:58 2004
+++ src/test-osicat.lisp Tue Jul 5 18:55:47 2005
@@ -49,6 +49,8 @@
(error () :error)))))
t)
+;;; XXX: (user-homedir-pathname) is "home:" under CMUCL, so this test
+;;; will fail.
(deftest environment.1
(namestring (probe-file (cdr (assoc "HOME" (environment)
:test #'equal))))
@@ -312,20 +314,20 @@
;; Does this test still work in the case of su/sudo? It should, I
;; think.
-#+sbcl
(deftest user-info.2
- (let ((user-id (cdr (assoc :user-id (user-info (sb-posix:getuid))))))
- (equal user-id (sb-posix:getuid)))
+ (let* ((uid (our-getuid))
+ (user-info (user-info uid)))
+ (equal (cdr (assoc :user-id user-info)) uid))
t)
;; Just get our home directory, and see if it exists. I don't
;; think this will work 100% of the time, but it should for most
;; people testing the package; given that, would it be even better
;; to compare the value to (user-homedir-pathname)?
-#+sbcl
(deftest user-info.3
- (let ((home (cdr (assoc :home (user-info (sb-posix:getuid))))))
- (file-kind home))
+ (let* ((uid (our-getuid))
+ (user-info (user-info uid)))
+ (file-kind (cdr (assoc :home user-info))))
:directory)
;; We'll go out on a limb and assume that not only does the root
@@ -336,3 +338,11 @@
(file-kind home))
:directory)
+
+(deftest temporary-file.1
+ (with-temporary-file (stream)
+ (let ((pos (file-position stream)))
+ (print 'foo stream)
+ (file-position stream pos)
+ (eql (read stream) 'foo)))
+ t)
Index: src/test-tools.lisp
diff -u src/test-tools.lisp:1.2 src/test-tools.lisp:1.3
--- src/test-tools.lisp:1.2 Mon Mar 1 00:28:22 2004
+++ src/test-tools.lisp Tue Jul 5 18:55:47 2005
@@ -49,6 +49,11 @@
((null kind) (make-link link :target target))
(t (error "File exists and is not a link.")))))
+(defun our-getuid ()
+ #+sbcl (sb-posix:getuid)
+ #+cmu (unix:unix-getuid)
+ #-(or sbcl cmu) 0) ; A sane enough default for testing?
+
;;; Test environment
(defun teardown ()
More information about the Osicat-cvs
mailing list