/[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.11 - (hide annotations)
Sat Oct 12 19:37:47 2002 UTC (11 years, 6 months ago) by kaz
Branch: MAIN
Changes since 1.10: +2 -2 lines
Rethink some decisions in the previous change. Reusing the
name posix.lisp for a new file will cause problems for people
using mcvs grab to keep up with Meta-CVS patches.

* code/posix.lisp: Renamed to unix.lisp.

* code/clisp-posix.lisp: Renamed back to clisp-unix.lisp, for
the sake of consistency.

* code/system.lisp: Updated.

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

  ViewVC Help
Powered by ViewVC 1.1.5