/[meta-cvs]/meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp
ViewVC logotype

Contents of /meta-cvs/F-6BD7679FED76D6E5A7D36DC36C205FC1.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sun Aug 4 18:15:18 2002 UTC (11 years, 8 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-21
Changes since 1.1: +6 -3 lines
Working back support for CLISP 2.27.

* code/install.sh: Bogus *null-pointer* hack is no longer added
to the generated mcvs script, since we have our own FFI functions for
doing the test.

* code/unix-bindings/unix.lisp (unix-funcs:null-pointer-p): New
function, tests a C pointer for null, returns T or NIL.
* code/unix-bindings/impl.c (impl_null_pointer_p): New function,
C implementation of unix-funcs:null-pointer-p.

* code/clisp-unix.lisp (pointer-null): New macro, uses
ffi:foreign-address-null under CLISP 2.28 or greater, or
unix-funcs:null-pointer-p, under an older CLISP.
1 ;;; This source file is part of the Meta-CVS program,
2 ;;; which is distributed under the GNU license.
3 ;;; Copyright 2002 Kaz Kylheku
4
5 (provide "clisp-unix")
6
7 ;;; Null pointer handling
8
9 #.(when (< (first (system::version)) 20020129)
10 (push :clisp-old *features*)
11 (values))
12
13 #+clisp-old
14 (defmacro pointer-null (p) `(unix-funcs:null-pointer-p ,p))
15
16 #-clisp-old
17 (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))
18
19 (defmacro null-to-nil (p)
20 (let ((pointer (gensym)))
21 `(let ((,pointer ,p)) (if (pointer-null ,pointer) nil ,pointer))))
22
23 (defmacro when-not-null (p &body forms)
24 `(if (not (pointer-null ,p)) ,@forms))
25
26 ;;; Base condition
27
28 (define-condition system-error (error) ((message :initarg :message))
29 (:report (lambda (condition stream)
30 (format stream "System error: ~A"
31 (slot-value condition 'message)))))
32
33 ;;; Macro to catch ENOENT errors and turn them into nil
34 ;;; return value.
35
36 (defmacro no-existence-error (&body forms)
37 (let ((block-sym (gensym "BLOCK-")))
38 `(block ,block-sym
39 (handler-bind
40 ((system-error #'(lambda (con)
41 (declare (ignore con))
42 (if (= unix-funcs:errno unix-funcs:enoent)
43 (return-from ,block-sym nil)))))
44 ,@forms))))
45
46 ;;; Directory access
47
48 (define-condition open-dir-error (system-error) ((dir :initarg :dir)))
49
50 (defmethod initialize-instance :after ((c open-dir-error) &rest args)
51 (declare (ignore args))
52 (with-slots (dir message) c
53 (setf message (format nil "Unable to open ~A: ~A."
54 dir (unix-funcs:strerror unix-funcs:errno)))))
55
56 (define-condition open-error (system-error) ((path :initarg :path)))
57
58 (defmethod initialize-instance :after ((c open-error) &rest args)
59 (declare (ignore args))
60 (with-slots (path message) c
61 (setf message (format nil "Unable to open ~A: ~A."
62 path (unix-funcs:strerror unix-funcs:errno)))))
63
64
65 (defun opendir (dir)
66 (cond
67 ((null-to-nil (unix-funcs:opendir dir)))
68 (t (error (make-condition 'open-dir-error :dir dir)))))
69
70 (defun closedir (dir-stream)
71 (when-not-null dir-stream (unix-funcs:closedir dir-stream)))
72
73 (declaim (inline closedir))
74
75 (defun readdir (dir-stream)
76 (let ((dir-entry (unix-funcs:readdir dir-stream)))
77 (if dir-entry
78 (with-slots ((name unix-funcs:name) (ino unix-funcs:ino)) dir-entry
79 (values name ino))
80 nil)))
81
82 (defmacro with-open-dir ((var dir) &body forms)
83 `(let ((,var (opendir ,dir)))
84 (unwind-protect
85 (progn ,@forms)
86 (closedir ,var))))
87
88 (define-condition chdir-error (system-error) ((dir :initarg :dir)))
89
90 (defmethod initialize-instance :after ((c chdir-error) &rest args)
91 (declare (ignore args))
92 (with-slots (dir message) c
93 (setf message (format nil "Unable to change to directory ~A: ~A."
94 dir (unix-funcs:strerror unix-funcs:errno)))))
95
96 (defun chdir (dir)
97 (if (= -1 (unix-funcs:chdir dir))
98 (error (make-condition 'chdir-error :dir dir)))
99 (values))
100
101 (defun fchdir (descr)
102 (if (= -1 (unix-funcs:fchdir descr))
103 (error (make-condition 'chdir-error
104 :dir (format nil "[file descriptor ~a]" descr))))
105 (values))
106
107 (defmacro current-dir-restore (&body forms)
108 (let ((saved-dir (gensym "SAVED-DIR-")))
109 `(let ((,saved-dir (unix-funcs:open "." unix-funcs:o-rdonly 0)))
110 (when (= ,saved-dir -1)
111 (error (make-condition 'open-error :path ".")))
112 (unwind-protect (progn ,@forms)
113 (fchdir ,saved-dir)
114 (unix-funcs:close ,saved-dir)))))
115
116 ;;; File information
117
118 (define-condition file-info-error (system-error) ((file :initarg :file)))
119
120 (defmethod initialize-instance :after ((c file-info-error) &rest args)
121 (declare (ignore args))
122 (with-slots (file message) c
123 (setf message (format nil "Unable to get status of ~A: ~A."
124 file (unix-funcs:strerror unix-funcs:errno)))))
125
126 (defclass file-info ()
127 ((file-name :initarg :file-name :accessor file-name)
128 (mode-flags :initarg :mode-flags :accessor mode-flags)
129 (mod-time :initarg :mod-time :accessor mod-time)
130 (inode :initarg :inode :accessor inode)
131 (num-links :initarg :num-links :accessor num-links)))
132
133 (defgeneric same-file-p (file1 file2))
134 (defgeneric older-p (file1 file2))
135 (defgeneric regular-p (file))
136 (defgeneric directory-p (file))
137 (defgeneric symlink-p (file))
138 (defgeneric is-root-p (file))
139 (defgeneric get-parent (file))
140
141 (defmethod same-file-p ((f1 file-info) (f2 file-info))
142 (= (inode f1) (inode f2)))
143
144 (defmethod same-file-p ((f1 string) (f2 string))
145 (= (stat f1) (stat f2)))
146
147 (defmethod older-p ((f1 file-info) (f2 file-info))
148 (< (mod-time f1) (mod-time f2)))
149
150 (defmethod older-p ((f1 string) (f2 string))
151 (older-p (stat f1) (stat f2)))
152
153 (defmethod regular-p ((file file-info))
154 (unix-funcs:s-isreg (mode-flags file)))
155
156 (defmethod regular-p ((filename string))
157 (regular-p (stat filename)))
158
159 (defmethod regular-p ((x null))
160 nil)
161
162 (defmethod directory-p ((file file-info))
163 (unix-funcs:s-isdir (mode-flags file)))
164
165 (defmethod directory-p ((filename string))
166 (directory-p (stat filename)))
167
168 (defmethod directory-p ((x null))
169 nil)
170
171 (defmethod symlink-p ((file file-info))
172 (unix-funcs:s-islnk (mode-flags file)))
173
174 (defmethod symlink-p ((filename string))
175 (symlink-p (stat filename)))
176
177 (defmethod symlink-p ((x null))
178 nil)
179
180 (defmethod is-root-p ((file file-info))
181 (and (directory-p file)
182 (same-file-p file (stat (format nil "~a/.." (file-name file))))))
183
184 (defmethod is-root-p ((filename string))
185 (is-root-p (stat filename)))
186
187 (defmethod get-parent ((file file-info))
188 (stat (format nil "~a/.." (file-name file))))
189
190 (defmethod get-parent ((filename string))
191 (stat (format nil "~a/.." filename)))
192
193 (defun stat (name &key through-link)
194 (if (typep name 'file-info)
195 name
196 (multiple-value-bind (result stat-info)
197 (if through-link
198 (unix-funcs:stat name)
199 (unix-funcs:lstat name))
200 (when (= result -1)
201 (error (make-condition 'file-info-error :file name)))
202 (with-slots ((mode unix-funcs:mode)
203 (mtime unix-funcs:mtime)
204 (inode unix-funcs:ino)
205 (nlink unix-funcs:nlink)) stat-info
206 (make-instance 'file-info :file-name name
207 :mode-flags mode
208 :mod-time mtime
209 :inode inode
210 :num-links nlink)))))
211
212 (defun exists (name &key through-link)
213 (no-existence-error (stat name :through-link through-link)))
214
215 ;;; Symbolic and hard links
216
217 (define-condition link-error (system-error)
218 ((from-path :initarg :from-path)
219 (to-path :initarg :to-path)))
220
221 (defmethod initialize-instance :after ((c link-error) &rest args)
222 (declare (ignore args))
223 (with-slots (message from-path to-path) c
224 (setf message (format nil "Unable to link ~A to ~A: ~A."
225 from-path to-path
226 (unix-funcs:strerror unix-funcs:errno)))))
227
228 (defun link (from to)
229 (if (zerop (unix-funcs:link from to))
230 (values)
231 (error (make-condition 'link-error :from-path from :to-path to))))
232
233 ;;; Directory removal
234
235 (define-condition rm-error (system-error)
236 ((path :initarg :path)))
237
238 (defmethod initialize-instance :after ((c rm-error) &rest args)
239 (declare (ignore args))
240 (with-slots (message path) c
241 (setf message (format nil "Unable to remove ~A: ~A."
242 path (unix-funcs:strerror unix-funcs:errno)))))
243
244 (defun rmdir (dir)
245 (if (zerop (unix-funcs:rmdir dir))
246 (values)
247 (error (make-condition 'rm-error :path dir))))
248
249 (defun unlink (file)
250 (if (zerop (unix-funcs:unlink file))
251 (values)
252 (error (make-condition 'rm-error :path file))))
253
254 ;;; Coprocesses
255
256 (defconstant *argument-limit* (* 64 1024))
257
258 (defun shell-interpreter (command)
259 (case (shell command)
260 ((0) T)
261 (otherwise nil)))
262
263 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
264 `(let* ((,stream-var (make-pipe-input-stream
265 (arglist-to-command-string ,arg-list))))
266 (declare (dynamic-extent ,stream-var))
267 (when ,stream-var
268 (unwind-protect (progn ,@forms) (close ,stream-var)))))
269
270 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
271 `(let* ((,stream-var (make-pipe-output-stream
272 (arglist-to-command-string ,arg-list))))
273 (declare (dynamic-extent ,stream-var))
274 (when ,stream-var
275 (unwind-protect (progn ,@forms) (close ,stream-var)))))
276
277 ;;; GUID generation
278
279 (defun guid-gen ()
280 (with-open-file (f "/dev/urandom"
281 :direction :input
282 :element-type '(unsigned-byte 128))
283 (read-byte f)))
284
285 ;;; Environment strings
286 (defun env-lookup (name &optional substitute-if-not-found)
287 (let ((value (getenv name)))
288 (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5