/[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.7 - (hide annotations)
Thu Sep 19 01:50:04 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-96
Changes since 1.6: +3 -0 lines
* code/restore.lisp (mcvs-restore): Was still generating old-style
mapping entries.

* code/clisp-unix.lisp (executable-p (string)): New method for
executable-p generic function that takes a filename.
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     (provide "clisp-unix")
6    
7     ;;; Null pointer handling
8    
9     #.(when (< (first (system::version)) 20020129)
10 kaz 1.2 (push :clisp-old *features*)
11     (values))
12 kaz 1.1
13 kaz 1.2 #+clisp-old
14     (defmacro pointer-null (p) `(unix-funcs:null-pointer-p ,p))
15 kaz 1.1
16 kaz 1.2 #-clisp-old
17     (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))
18 kaz 1.1
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 kaz 1.3 (defun getcwd ()
108     (unix-funcs:getcwd))
109     (declaim (inline getcwd))
110    
111 kaz 1.1 (defmacro current-dir-restore (&body forms)
112     (let ((saved-dir (gensym "SAVED-DIR-")))
113     `(let ((,saved-dir (unix-funcs:open "." unix-funcs:o-rdonly 0)))
114     (when (= ,saved-dir -1)
115     (error (make-condition 'open-error :path ".")))
116     (unwind-protect (progn ,@forms)
117     (fchdir ,saved-dir)
118     (unix-funcs:close ,saved-dir)))))
119    
120     ;;; File information
121    
122     (define-condition file-info-error (system-error) ((file :initarg :file)))
123    
124     (defmethod initialize-instance :after ((c file-info-error) &rest args)
125     (declare (ignore args))
126     (with-slots (file message) c
127     (setf message (format nil "Unable to get status of ~A: ~A."
128     file (unix-funcs:strerror unix-funcs:errno)))))
129    
130     (defclass file-info ()
131     ((file-name :initarg :file-name :accessor file-name)
132     (mode-flags :initarg :mode-flags :accessor mode-flags)
133     (mod-time :initarg :mod-time :accessor mod-time)
134     (inode :initarg :inode :accessor inode)
135     (num-links :initarg :num-links :accessor num-links)))
136    
137     (defgeneric same-file-p (file1 file2))
138     (defgeneric older-p (file1 file2))
139     (defgeneric regular-p (file))
140     (defgeneric directory-p (file))
141     (defgeneric symlink-p (file))
142     (defgeneric is-root-p (file))
143     (defgeneric get-parent (file))
144 kaz 1.6 (defgeneric executable-p (file))
145     (defgeneric make-executable (file))
146     (defgeneric make-non-executable (file))
147 kaz 1.1
148     (defmethod same-file-p ((f1 file-info) (f2 file-info))
149     (= (inode f1) (inode f2)))
150    
151     (defmethod same-file-p ((f1 string) (f2 string))
152     (= (stat f1) (stat f2)))
153    
154     (defmethod older-p ((f1 file-info) (f2 file-info))
155     (< (mod-time f1) (mod-time f2)))
156    
157     (defmethod older-p ((f1 string) (f2 string))
158     (older-p (stat f1) (stat f2)))
159    
160     (defmethod regular-p ((file file-info))
161     (unix-funcs:s-isreg (mode-flags file)))
162    
163     (defmethod regular-p ((filename string))
164     (regular-p (stat filename)))
165    
166     (defmethod regular-p ((x null))
167     nil)
168    
169     (defmethod directory-p ((file file-info))
170     (unix-funcs:s-isdir (mode-flags file)))
171    
172     (defmethod directory-p ((filename string))
173     (directory-p (stat filename)))
174    
175     (defmethod directory-p ((x null))
176     nil)
177    
178     (defmethod symlink-p ((file file-info))
179     (unix-funcs:s-islnk (mode-flags file)))
180    
181     (defmethod symlink-p ((filename string))
182     (symlink-p (stat filename)))
183    
184     (defmethod symlink-p ((x null))
185     nil)
186    
187     (defmethod is-root-p ((file file-info))
188     (and (directory-p file)
189     (same-file-p file (stat (format nil "~a/.." (file-name file))))))
190    
191     (defmethod is-root-p ((filename string))
192     (is-root-p (stat filename)))
193    
194     (defmethod get-parent ((file file-info))
195     (stat (format nil "~a/.." (file-name file))))
196    
197     (defmethod get-parent ((filename string))
198     (stat (format nil "~a/.." filename)))
199 kaz 1.6
200     (defmethod executable-p ((file file-info))
201     (with-slots ((mode mode-flags)) file
202     (and (not (zerop (logand mode unix-funcs:s-ixusr)))
203     (not (zerop (logand mode unix-funcs:s-ixgrp))))))
204    
205 kaz 1.7 (defmethod executable-p ((filename string))
206     (executable-p (stat filename)))
207    
208 kaz 1.6 (defmethod make-executable ((file file-info))
209     (with-slots ((mode mode-flags) file-name) file
210     (let ((saved-mode mode))
211     (unless (zerop (logand mode unix-funcs:s-irusr))
212     (setf mode (logior mode unix-funcs:s-ixusr)))
213     (unless (zerop (logand mode unix-funcs:s-irgrp))
214     (setf mode (logior mode unix-funcs:s-ixgrp)))
215     (unless (zerop (logand mode unix-funcs:s-iroth))
216     (setf mode (logior mode unix-funcs:s-ixoth)))
217     (unless (= mode saved-mode)
218     (unix-funcs:chmod file-name mode)))))
219    
220     (defmethod make-executable ((filename string))
221     (make-executable (stat filename)))
222    
223     (defmethod make-non-executable ((file file-info))
224     (with-slots ((mode mode-flags) file-name) file
225     (let ((saved-mode mode))
226     (setf mode (logand mode
227     (lognot (logior unix-funcs:s-ixusr
228     unix-funcs:s-ixgrp
229     unix-funcs:s-ixoth))))
230     (unless (= mode saved-mode)
231     (unix-funcs:chmod file-name mode)))))
232    
233     (defmethod make-non-executable ((filename string))
234     (make-non-executable (stat filename)))
235 kaz 1.1
236     (defun stat (name &key through-link)
237     (if (typep name 'file-info)
238     name
239     (multiple-value-bind (result stat-info)
240     (if through-link
241     (unix-funcs:stat name)
242     (unix-funcs:lstat name))
243     (when (= result -1)
244     (error (make-condition 'file-info-error :file name)))
245     (with-slots ((mode unix-funcs:mode)
246     (mtime unix-funcs:mtime)
247     (inode unix-funcs:ino)
248     (nlink unix-funcs:nlink)) stat-info
249     (make-instance 'file-info :file-name name
250     :mode-flags mode
251     :mod-time mtime
252     :inode inode
253     :num-links nlink)))))
254    
255     (defun exists (name &key through-link)
256     (no-existence-error (stat name :through-link through-link)))
257    
258     ;;; Symbolic and hard links
259    
260     (define-condition link-error (system-error)
261     ((from-path :initarg :from-path)
262 kaz 1.5 (to-path :initarg :to-path)
263     (kind :initarg :kind)))
264 kaz 1.1
265     (defmethod initialize-instance :after ((c link-error) &rest args)
266     (declare (ignore args))
267 kaz 1.5 (with-slots (message kind from-path to-path) c
268     (setf message (format nil "Unable to make ~A link called ~A referencing ~A."
269     kind to-path from-path
270 kaz 1.1 (unix-funcs:strerror unix-funcs:errno)))))
271    
272     (defun link (from to)
273     (if (zerop (unix-funcs:link from to))
274     (values)
275 kaz 1.5 (error (make-condition 'link-error :from-path from
276     :to-path to :kind "hard"))))
277    
278     (defun symlink (from to)
279     (if (zerop (unix-funcs:symlink from to))
280     (values)
281     (error (make-condition 'link-error :from-path from
282     :to-path to :kind "symbolic"))))
283    
284     (define-condition readlink-error (system-error)
285     ((path :initarg :path)))
286    
287     (defmethod initialize-instance :after ((c readlink-error) &rest args)
288     (declare (ignore args))
289     (with-slots (message path) c
290     (setf message (format nil "Unable to read symbolic link ~A: ~A."
291     path (unix-funcs:strerror unix-funcs:errno)))))
292    
293     (defun readlink (path)
294     (let ((data (unix-funcs:readlink path)))
295     (if data
296     data
297     (error (make-condition 'readlink-error :path path)))))
298 kaz 1.1
299     ;;; Directory removal
300    
301     (define-condition rm-error (system-error)
302     ((path :initarg :path)))
303    
304     (defmethod initialize-instance :after ((c rm-error) &rest args)
305     (declare (ignore args))
306     (with-slots (message path) c
307     (setf message (format nil "Unable to remove ~A: ~A."
308     path (unix-funcs:strerror unix-funcs:errno)))))
309    
310     (defun rmdir (dir)
311     (if (zerop (unix-funcs:rmdir dir))
312     (values)
313     (error (make-condition 'rm-error :path dir))))
314    
315     (defun unlink (file)
316     (if (zerop (unix-funcs:unlink file))
317     (values)
318     (error (make-condition 'rm-error :path file))))
319    
320     ;;; Coprocesses
321    
322     (defconstant *argument-limit* (* 64 1024))
323    
324     (defun shell-interpreter (command)
325     (case (shell command)
326     ((0) T)
327     (otherwise nil)))
328    
329 kaz 1.4 (defun execute-program (arglist)
330     (case (run-program (first arglist) :arguments (rest arglist))
331     ((0) T)
332     (otherwise nil)))
333    
334 kaz 1.1 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
335     `(let* ((,stream-var (make-pipe-input-stream
336     (arglist-to-command-string ,arg-list))))
337     (declare (dynamic-extent ,stream-var))
338     (when ,stream-var
339     (unwind-protect (progn ,@forms) (close ,stream-var)))))
340    
341     (defmacro with-output-to-program ((stream-var arg-list) &body forms)
342     `(let* ((,stream-var (make-pipe-output-stream
343     (arglist-to-command-string ,arg-list))))
344     (declare (dynamic-extent ,stream-var))
345     (when ,stream-var
346     (unwind-protect (progn ,@forms) (close ,stream-var)))))
347    
348     ;;; GUID generation
349    
350     (defun guid-gen ()
351     (with-open-file (f "/dev/urandom"
352     :direction :input
353     :element-type '(unsigned-byte 128))
354     (read-byte f)))
355    
356     ;;; Environment strings
357     (defun env-lookup (name &optional substitute-if-not-found)
358     (let ((value (getenv name)))
359     (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5