/[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.22 - (show annotations)
Sat Dec 11 07:58:05 2004 UTC (9 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.21: +1 -9 lines
Get rid of CLISP 2.27 support.

* code/unix-bindings/unix.lisp (null-pointer-p): Function removed.

* code/clisp-unix.lisp: The :clisp-old symbol no longer conditionally
pushed onto *features*
(pointer-null): Just version of the macro present; no more
read-time switch.
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 (in-package "META-CVS")
6
7 ;;; Null pointer handling
8
9 (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))
10
11 (defmacro null-to-nil (p)
12 (let ((pointer (gensym)))
13 `(let ((,pointer ,p)) (if (pointer-null ,pointer) nil ,pointer))))
14
15 (defmacro when-not-null (p &body forms)
16 `(if (not (pointer-null ,p)) ,@forms))
17
18 ;;; Base condition
19
20 (define-condition system-error (error) ((message :initarg :message))
21 (:report (lambda (condition stream)
22 (format stream "System error: ~A"
23 (slot-value condition 'message)))))
24
25 ;;; Macro to catch ENOENT errors and turn them into nil
26 ;;; return value.
27
28 (defmacro no-existence-error (&body forms)
29 (let ((block-sym (gensym "BLOCK-")))
30 `(block ,block-sym
31 (handler-bind
32 ((system-error #'(lambda (con)
33 (declare (ignore con))
34 (if (= unix-funcs:errno unix-funcs:enoent)
35 (return-from ,block-sym nil)))))
36 ,@forms))))
37
38 ;;; Directory access
39
40 (define-condition open-dir-error (system-error) ((dir :initarg :dir)))
41
42 (defmethod initialize-instance :after ((c open-dir-error) &rest args)
43 (declare (ignore args))
44 (with-slots (dir message) c
45 (setf message (format nil "Unable to open ~A: ~A."
46 dir (unix-funcs:strerror unix-funcs:errno)))))
47
48 (define-condition open-error (system-error) ((path :initarg :path)))
49
50 (defmethod initialize-instance :after ((c open-error) &rest args)
51 (declare (ignore args))
52 (with-slots (path message) c
53 (setf message (format nil "Unable to open ~A: ~A."
54 path (unix-funcs:strerror unix-funcs:errno)))))
55
56
57 (defun opendir (dir)
58 (cond
59 ((null-to-nil (unix-funcs:opendir dir)))
60 (t (error (make-condition 'open-dir-error :dir dir)))))
61
62 (declaim (inline closedir))
63 (defun closedir (dir-stream)
64 (when-not-null dir-stream (unix-funcs:closedir dir-stream)))
65
66
67 (defun readdir (dir-stream)
68 (let ((dir-entry (unix-funcs:readdir dir-stream)))
69 (if dir-entry
70 (with-slots ((name unix-funcs:name) (ino unix-funcs:ino)) dir-entry
71 (values name ino))
72 nil)))
73
74 (defmacro with-open-dir ((var dir) &body forms)
75 `(let ((,var (opendir ,dir)))
76 (unwind-protect
77 (progn ,@forms)
78 (closedir ,var))))
79
80 (define-condition chdir-error (system-error) ((dir :initarg :dir)))
81
82 (defmethod initialize-instance :after ((c chdir-error) &rest args)
83 (declare (ignore args))
84 (with-slots (dir message) c
85 (setf message (format nil "Unable to change to directory ~A: ~A."
86 dir (unix-funcs:strerror unix-funcs:errno)))))
87
88 (defun chdir (dir)
89 (if (= -1 (unix-funcs:chdir dir))
90 (error (make-condition 'chdir-error :dir dir)))
91 (values))
92
93 (defun fchdir (descr)
94 (if (= -1 (unix-funcs:fchdir descr))
95 (error (make-condition 'chdir-error
96 :dir (format nil "[file descriptor ~a]" descr))))
97 (values))
98
99 (define-condition getcwd-error (system-error) ())
100
101 (defmethod initialize-instance :after ((c getcwd-error) &rest args)
102 (declare (ignore args))
103 (with-slots (message) c
104 (setf message (format nil "Unable to determine current directory: ~A."
105 (unix-funcs:strerror unix-funcs:errno)))))
106
107 (declaim (inline getcwd))
108 (defun getcwd ()
109 (or (unix-funcs:getcwd)
110 (error (make-condition 'getcwd-error))))
111
112 (defmacro current-dir-restore (&body forms)
113 (let ((saved-dir (gensym "SAVED-DIR-")))
114 `(let ((,saved-dir (unix-funcs:open "." unix-funcs:o-rdonly 0)))
115 (when (= ,saved-dir -1)
116 (error (make-condition 'open-error :path ".")))
117 (unwind-protect
118 (macrolet ((in-original-dir (&body inner-forms)
119 (let ((in-saved-dir (gensym "INNER-SAVED-DIR-")))
120 `(let ((,in-saved-dir
121 (unix-funcs:open "."
122 unix-funcs:o-rdonly
123 0)))
124 (when (= ,in-saved-dir -1)
125 (error (make-condition 'open-error :path ".")))
126 (unwind-protect
127 (progn (fchdir ,',saved-dir)
128 (progn ,@inner-forms))
129 (fchdir ,in-saved-dir)
130 (unix-funcs:close ,in-saved-dir))))))
131 ,@forms)
132 (fchdir ,saved-dir)
133 (unix-funcs:close ,saved-dir)))))
134
135 ;;; File information
136
137 (define-condition file-info-error (system-error) ((file :initarg :file)))
138
139 (defmethod initialize-instance :after ((c file-info-error) &rest args)
140 (declare (ignore args))
141 (with-slots (file message) c
142 (setf message (format nil "Unable to get status of ~A: ~A."
143 file (unix-funcs:strerror unix-funcs:errno)))))
144
145 (defclass file-info ()
146 ((file-name :initarg :file-name :accessor file-name)
147 (mode-flags :initarg :mode-flags :accessor mode-flags)
148 (mod-time :initarg :mod-time :accessor mod-time)
149 (inode :initarg :inode :accessor inode)
150 (num-links :initarg :num-links :accessor num-links)))
151
152 (defgeneric same-file-p (file1 file2))
153 (defgeneric older-p (file1 file2))
154 (defgeneric regular-p (file))
155 (defgeneric directory-p (file))
156 (defgeneric symlink-p (file))
157 (defgeneric is-root-p (file))
158 (defgeneric get-parent (file))
159 (defgeneric executable-p (file))
160 (defgeneric make-executable (file))
161 (defgeneric make-non-executable (file))
162
163 (defmethod same-file-p ((f1 file-info) (f2 file-info))
164 (= (inode f1) (inode f2)))
165
166 (defmethod same-file-p ((f1 string) (f2 string))
167 (= (stat f1) (stat f2)))
168
169 (defmethod older-p ((f1 file-info) (f2 file-info))
170 (< (mod-time f1) (mod-time f2)))
171
172 (defmethod older-p ((f1 string) (f2 string))
173 (older-p (stat f1) (stat f2)))
174
175 (defmethod regular-p ((file file-info))
176 (unix-funcs:s-isreg (mode-flags file)))
177
178 (defmethod regular-p ((filename string))
179 (regular-p (stat filename)))
180
181 (defmethod regular-p ((x null))
182 nil)
183
184 (defmethod directory-p ((file file-info))
185 (unix-funcs:s-isdir (mode-flags file)))
186
187 (defmethod directory-p ((filename string))
188 (directory-p (stat filename)))
189
190 (defmethod directory-p ((x null))
191 nil)
192
193 (defmethod symlink-p ((file file-info))
194 (unix-funcs:s-islnk (mode-flags file)))
195
196 (defmethod symlink-p ((filename string))
197 (symlink-p (stat filename)))
198
199 (defmethod symlink-p ((x null))
200 nil)
201
202 (defmethod is-root-p ((file file-info))
203 (and (directory-p file)
204 (same-file-p file (stat (format nil "~a/.." (file-name file))))))
205
206 (defmethod is-root-p ((filename string))
207 (is-root-p (stat filename)))
208
209 (defmethod get-parent ((file file-info))
210 (stat (format nil "~a/.." (file-name file))))
211
212 (defmethod get-parent ((filename string))
213 (stat (format nil "~a/.." filename)))
214
215 (defmethod executable-p ((file file-info))
216 (with-slots ((mode mode-flags)) file
217 (and (not (zerop (logand mode unix-funcs:s-ixusr)))
218 (not (zerop (logand mode unix-funcs:s-ixgrp))))))
219
220 (defmethod executable-p ((filename string))
221 (executable-p (stat filename)))
222
223 (defmethod make-executable ((file file-info))
224 (with-slots ((mode mode-flags) file-name) file
225 (let ((saved-mode mode))
226 (unless (zerop (logand mode unix-funcs:s-irusr))
227 (setf mode (logior mode unix-funcs:s-ixusr)))
228 (unless (zerop (logand mode unix-funcs:s-irgrp))
229 (setf mode (logior mode unix-funcs:s-ixgrp)))
230 (unless (zerop (logand mode unix-funcs:s-iroth))
231 (setf mode (logior mode unix-funcs:s-ixoth)))
232 (unless (= mode saved-mode)
233 (unix-funcs:chmod file-name mode)))))
234
235 (defmethod make-executable ((filename string))
236 (make-executable (stat filename)))
237
238 (defmethod make-non-executable ((file file-info))
239 (with-slots ((mode mode-flags) file-name) file
240 (let ((saved-mode mode))
241 (setf mode (logand mode
242 (lognot (logior unix-funcs:s-ixusr
243 unix-funcs:s-ixgrp
244 unix-funcs:s-ixoth))))
245 (unless (= mode saved-mode)
246 (unix-funcs:chmod file-name mode)))))
247
248 (defmethod make-non-executable ((filename string))
249 (make-non-executable (stat filename)))
250
251 (defun stat (name &key through-link)
252 (if (typep name 'file-info)
253 name
254 (multiple-value-bind (result stat-info)
255 (if through-link
256 (unix-funcs:stat name)
257 (unix-funcs:lstat name))
258 (when (= result -1)
259 (error (make-condition 'file-info-error :file name)))
260 (with-slots ((mode unix-funcs:mode)
261 (mtime unix-funcs:mtime)
262 (inode unix-funcs:ino)
263 (nlink unix-funcs:nlink)) stat-info
264 (make-instance 'file-info :file-name name
265 :mode-flags mode
266 :mod-time mtime
267 :inode inode
268 :num-links nlink)))))
269
270 (defun exists (name &key through-link)
271 (no-existence-error (stat name :through-link through-link)))
272
273 ;;; Symbolic and hard links
274
275 (define-condition link-error (system-error)
276 ((from-path :initarg :from-path)
277 (to-path :initarg :to-path)
278 (kind :initarg :kind)))
279
280 (defmethod initialize-instance :after ((c link-error) &rest args)
281 (declare (ignore args))
282 (with-slots (message kind from-path to-path) c
283 (setf message (format nil "Unable to make ~A link called ~A referencing ~A."
284 kind to-path from-path
285 (unix-funcs:strerror unix-funcs:errno)))))
286
287 (defun link (from to)
288 (if (zerop (unix-funcs:link from to))
289 (values)
290 (error (make-condition 'link-error :from-path from
291 :to-path to :kind "hard"))))
292
293 (defun symlink (from to)
294 (if (zerop (unix-funcs:symlink from to))
295 (values)
296 (error (make-condition 'link-error :from-path from
297 :to-path to :kind "symbolic"))))
298
299 (define-condition readlink-error (system-error)
300 ((path :initarg :path)))
301
302 (defmethod initialize-instance :after ((c readlink-error) &rest args)
303 (declare (ignore args))
304 (with-slots (message path) c
305 (setf message (format nil "Unable to read symbolic link ~A: ~A."
306 path (unix-funcs:strerror unix-funcs:errno)))))
307
308 (defun readlink (path)
309 (let ((data (unix-funcs:readlink path)))
310 (if data
311 data
312 (error (make-condition 'readlink-error :path path)))))
313
314 ;;; Directory removal
315
316 (define-condition rm-error (system-error)
317 ((path :initarg :path)))
318
319 (defmethod initialize-instance :after ((c rm-error) &rest args)
320 (declare (ignore args))
321 (with-slots (message path) c
322 (setf message (format nil "Unable to remove ~A: ~A."
323 path (unix-funcs:strerror unix-funcs:errno)))))
324
325 (defun rmdir (dir)
326 (if (zerop (unix-funcs:rmdir dir))
327 (values)
328 (error (make-condition 'rm-error :path dir))))
329
330 (defun unlink (file)
331 (if (zerop (unix-funcs:unlink file))
332 (values)
333 (error (make-condition 'rm-error :path file))))
334
335 ;;; Coprocesses
336
337 (defun shell-interpreter (command)
338 (case (ext:shell command)
339 ((0) T)
340 (otherwise nil)))
341
342 (defun execute-program (arglist)
343 (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
344 (case (unix-funcs:run-program (first arglist) :arguments (rest arglist))
345 ((0) (chatter-debug "successful termination~%") T)
346 (otherwise (chatter-debug "unsuccessful or abnormal termination~%") nil)))
347
348 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
349 (let ((arg-list-sym (gensym "ARG-LIST-")))
350 `(let ((,arg-list-sym ,arg-list))
351 (chatter-debug "piping from ~s in directory ~s~%" ,arg-list-sym (getcwd))
352 (unix-funcs:default-sigchld)
353 (let* ((,stream-var (ext:make-pipe-input-stream
354 (arglist-to-command-string ,arg-list-sym))))
355 (declare (dynamic-extent ,stream-var))
356 (when ,stream-var
357 (unwind-protect (progn ,@forms) (close ,stream-var)))))))
358
359 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
360 `(progn
361 (unix-funcs:default-sigchld)
362 (let* ((,stream-var (ext:make-pipe-output-stream
363 (arglist-to-command-string ,arg-list))))
364 (declare (dynamic-extent ,stream-var))
365 (when ,stream-var
366 (unwind-protect (progn ,@forms) (close ,stream-var))))))
367
368 ;;; GUID generation
369
370 (defvar *have-dev-random* t)
371 (defvar *mcvs-random-state*)
372
373 (defun guid-gen ()
374 (cond
375 (*have-dev-random*
376 (or (ignore-errors
377 (with-open-file (f "/dev/urandom"
378 :direction :input
379 :element-type '(unsigned-byte 128))
380 (read-byte f)))
381 (progn
382 (setf *have-dev-random* nil)
383 (setf *mcvs-random-state* (make-random-state t))
384 (guid-gen))))
385 (t (random #.(expt 2 128) *mcvs-random-state*))))
386
387 ;;; Environment strings
388 (defun env-lookup (name &optional substitute-if-not-found)
389 (let ((value (ext:getenv name)))
390 (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5