/[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.9.2.6 - (hide annotations)
Thu Jan 30 11:04:43 2003 UTC (11 years, 2 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-1, mcvs-1-0-2
Changes since 1.9.2.5: +2 -2 lines
* code/posix.lisp: Move some (declaim inline) to the correct
location, before the function to be inlined.

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

  ViewVC Help
Powered by ViewVC 1.1.5