/[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.24 - (hide annotations)
Fri Nov 24 05:04:27 2006 UTC (7 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.23: +3 -15 lines
Get rid of the ffi-pointer-null stuff, since c-pointer foreign types
are automatically converted to null now.

* code/clisp-ffi.lisp (null-pointer-p): Function removed.

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

  ViewVC Help
Powered by ViewVC 1.1.5