/[meta-cvs]/meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0
ViewVC logotype

Contents of /meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Tue Jan 29 06:40:07 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
Changes since 1.4: +9 -0 lines
* move.lisp (move-guts): test the actual filesystem as well
as the map for existence of a directory or file. This makes
the move operation behave better. Files can be moved to an
existing directory that is not known to MCVS, and a file
can properly clobber a target file that is not known to MCVS.

* clisp-linux.lisp (directory-p, regular-p, symlink-p): define
methods for these generic functions for a NIL argument, such
that they return NIL.
1 kaz 1.3 ;;; This source file is part of the MCVS program,
2     ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (provide "clisp-linux")
6    
7     ;;; Null pointer handling
8    
9 kaz 1.4 (defvar *null-pointer* (linux:realloc (linux:malloc 1) 0))
10 kaz 1.1
11     (defun pointer-null (p) (equalp p *null-pointer*))
12    
13     (declaim (inline pointer-null))
14    
15     (defmacro null-to-nil (p)
16     (let ((pointer (gensym)))
17     `(let ((,pointer ,p)) (if (pointer-null ,pointer) nil ,pointer))))
18    
19     (defmacro when-not-null (p &body forms)
20     `(if (not (pointer-null ,p)) ,@forms))
21    
22     ;;; Base condition
23    
24     (define-condition system-error (error) ((message :initarg :message))
25     (:report (lambda (condition stream)
26     (format stream "System error: ~A"
27     (slot-value condition 'message)))))
28    
29     ;;; Macro to catch ENOENT errors and turn them into nil
30     ;;; return value.
31    
32     (defmacro no-existence-error (&body forms)
33     (let ((block-sym (gensym "BLOCK-")))
34     `(block ,block-sym
35     (handler-bind
36     ((system-error #'(lambda (con)
37     (declare (ignore con))
38     (if (= (linux:__errno_location) linux::ENOENT)
39     (return-from ,block-sym nil)))))
40     ,@forms))))
41    
42     ;;; Directory access
43    
44     (define-condition open-dir-error (system-error) ((dir :initarg :dir)))
45    
46     (defmethod initialize-instance :after ((c open-dir-error) &rest args)
47 kaz 1.2 (declare (ignore args))
48 kaz 1.1 (with-slots (dir message) c
49     (setf message (format nil "Unable to open ~A: ~A."
50     dir (linux:strerror (linux:__errno_location))))))
51    
52     (define-condition open-error (system-error) ((path :initarg :path)))
53    
54     (defmethod initialize-instance :after ((c open-error) &rest args)
55 kaz 1.2 (declare (ignore args))
56 kaz 1.1 (with-slots (path message) c
57     (setf message (format nil "Unable to open ~A: ~A."
58     path (linux:strerror (linux:__errno_location))))))
59    
60    
61     (defun opendir (dir)
62     (cond
63     ((null-to-nil (linux:opendir dir)))
64     (t (error (make-condition 'open-dir-error :dir dir)))))
65    
66     (defun closedir (dir-stream)
67     (when-not-null dir-stream (linux:closedir dir-stream)))
68    
69     (declaim (inline closedir))
70    
71     (defun readdir (dir-stream)
72     (let ((dir-entry (linux:readdir dir-stream)))
73     (if dir-entry
74     (with-slots ((name linux::|d_name|) (ino linux::|d_ino|)) dir-entry
75     (values name ino))
76     nil)))
77    
78     (defmacro with-open-dir ((var dir) &body forms)
79     `(let ((,var (opendir ,dir)))
80     (unwind-protect
81     (progn ,@forms)
82     (closedir ,var))))
83    
84     (define-condition chdir-error (system-error) ((dir :initarg :dir)))
85    
86     (defmethod initialize-instance :after ((c chdir-error) &rest args)
87 kaz 1.2 (declare (ignore args))
88 kaz 1.1 (with-slots (dir message) c
89     (setf message (format nil "Unable to change to directory ~A: ~A."
90     dir (linux:strerror (linux:__errno_location))))))
91    
92     (defun chdir (dir)
93     (if (= -1 (linux:chdir dir))
94     (error (make-condition 'chdir-error :dir dir)))
95     (values))
96    
97     (defun fchdir (descr)
98     (if (= -1 (linux:fchdir descr))
99     (error (make-condition 'chdir-error
100     :dir (format nil "[file descriptor ~a]" descr))))
101     (values))
102    
103     (defmacro current-dir-restore (&body forms)
104     (let ((saved-dir (gensym "SAVED-DIR-")))
105     `(let ((,saved-dir (linux:open "." linux:O_RDONLY 0)))
106     (when (= ,saved-dir -1)
107     (error (make-condition 'open-error :path ".")))
108     (unwind-protect (progn ,@forms)
109     (fchdir ,saved-dir)
110     (linux:close ,saved-dir)))))
111    
112     ;;; File information
113    
114     (define-condition file-info-error (system-error) ((file :initarg :file)))
115    
116     (defmethod initialize-instance :after ((c file-info-error) &rest args)
117 kaz 1.2 (declare (ignore args))
118 kaz 1.1 (with-slots (file message) c
119     (setf message (format nil "Unable to get status of ~A: ~A."
120     file (linux:strerror (linux:__errno_location))))))
121    
122     (defclass file-info ()
123     ((file-name :initarg :file-name :accessor file-name)
124     (mode-flags :initarg :mode-flags :accessor mode-flags)
125     (mod-time :initarg :mod-time :accessor mod-time)
126     (inode :initarg :inode :accessor inode)
127     (num-links :initarg :num-links :accessor num-links)))
128    
129     (defgeneric same-file-p (file1 file2))
130     (defgeneric older-p (file1 file2))
131     (defgeneric regular-p (file))
132     (defgeneric directory-p (file))
133     (defgeneric symlink-p (file))
134     (defgeneric is-root-p (file))
135     (defgeneric get-parent (file))
136    
137     (defmethod same-file-p ((f1 file-info) (f2 file-info))
138     (= (inode f1) (inode f2)))
139    
140     (defmethod same-file-p ((f1 string) (f2 string))
141     (= (stat f1) (stat f2)))
142    
143     (defmethod older-p ((f1 file-info) (f2 file-info))
144     (< (mod-time f1) (mod-time f2)))
145    
146     (defmethod older-p ((f1 string) (f2 string))
147     (older-p (stat f1) (stat f2)))
148    
149     (defmethod regular-p ((file file-info))
150     (linux:S_ISREG (mode-flags file)))
151    
152     (defmethod regular-p ((filename string))
153     (regular-p (stat filename)))
154    
155 kaz 1.5 (defmethod regular-p ((x null))
156     nil)
157    
158 kaz 1.1 (defmethod directory-p ((file file-info))
159     (linux:S_ISDIR (mode-flags file)))
160    
161     (defmethod directory-p ((filename string))
162     (directory-p (stat filename)))
163    
164 kaz 1.5 (defmethod directory-p ((x null))
165     nil)
166    
167 kaz 1.1 (defmethod symlink-p ((file file-info))
168     (linux:S_ISLNK (mode-flags file)))
169    
170     (defmethod symlink-p ((filename string))
171     (symlink-p (stat filename)))
172 kaz 1.5
173     (defmethod symlink-p ((x null))
174     nil)
175 kaz 1.1
176     (defmethod is-root-p ((file file-info))
177     (and (directory-p file)
178     (same-file-p file (stat (format nil "~a/.." (file-name file))))))
179    
180     (defmethod is-root-p ((filename string))
181     (is-root-p (stat filename)))
182    
183     (defmethod get-parent ((file file-info))
184     (stat (format nil "~a/.." (file-name file))))
185    
186     (defmethod get-parent ((filename string))
187     (stat (format nil "~a/.." filename)))
188    
189     (defun stat (name &key through-link)
190     (if (typep name 'file-info)
191     name
192     (multiple-value-bind (result stat-info)
193     (if through-link
194     (linux::stat name)
195     (linux::lstat name))
196     (when (= result -1)
197     (error (make-condition 'file-info-error :file name)))
198     (with-slots ((mode linux::|st_mode|)
199     (mtime linux::|st_mtime|)
200     (inode linux::|st_ino|)
201     (nlink linux::|st_nlink|)) stat-info
202     (make-instance 'file-info :file-name name
203     :mode-flags mode
204     :mod-time mtime
205     :inode inode
206     :num-links nlink)))))
207    
208     ;;; Symbolic and hard links
209    
210     (define-condition link-error (system-error)
211     ((from-path :initarg :from-path)
212     (to-path :initarg :to-path)))
213    
214     (defmethod initialize-instance :after ((c link-error) &rest args)
215 kaz 1.2 (declare (ignore args))
216 kaz 1.1 (with-slots (message from-path to-path) c
217     (setf message (format nil "Unable to link ~A to ~A: ~A."
218     from-path to-path
219     (linux:strerror (linux:__errno_location))))))
220    
221     (defun link (from to)
222     (if (zerop (linux:link from to))
223     (values)
224     (error (make-condition 'link-error :from-path from :to-path to))))
225    
226     ;;; Directory removal
227    
228     (define-condition rm-error (system-error)
229     ((path :initarg :path)))
230    
231     (defmethod initialize-instance :after ((c rm-error) &rest args)
232 kaz 1.2 (declare (ignore args))
233 kaz 1.1 (with-slots (message path) c
234     (setf message (format nil "Unable to remove ~A: ~A."
235     path (linux:strerror (linux:__errno_location))))))
236    
237     (defun rmdir (dir)
238     (if (zerop (linux:rmdir dir))
239     (values)
240     (error (make-condition 'rm-error :path dir))))
241    
242     (defun unlink (file)
243     (if (zerop (linux:unlink file))
244     (values)
245     (error (make-condition 'rm-error :path file))))
246    
247     ;;; Coprocesses
248    
249     (defun arglist-to-command-string (arglist)
250     (with-output-to-string (sstream)
251     (dolist (arg arglist)
252     (if (or (find #\space arg)
253     (find #\tab arg))
254     (format sstream "'~a' " arg)
255     (format sstream "~a " arg)))))
256    
257     (defun execute-program (&rest arg-list)
258     (let ((command (if (consp (first arg-list))
259     (arglist-to-command-string (first arg-list))
260     (arglist-to-command-string arg-list))))
261     (case (shell command)
262     ((0) T)
263     (otherwise nil))))
264    
265     (defmacro with-input-from-program ((stream-var arg-list) &body forms)
266     `(let* ((,stream-var (make-pipe-input-stream
267     (arglist-to-command-string ,arg-list))))
268     (declare (dynamic-extent ,stream-var))
269     (when ,stream-var
270     (unwind-protect (progn ,@forms) (close ,stream-var)))))
271    
272     (defmacro with-output-to-program ((stream-var arg-list) &body forms)
273     `(let* ((,stream-var (make-pipe-output-stream
274     (arglist-to-command-string ,arg-list))))
275     (declare (dynamic-extent ,stream-var))
276     (when ,stream-var
277     (unwind-protect (progn ,@forms) (close ,stream-var)))))
278    
279     ;;; GUID generation
280    
281     (defun guid-gen ()
282     (with-open-file (f "/dev/urandom"
283     :direction :input
284     :element-type '(unsigned-byte 128))
285     (read-byte f)))

  ViewVC Help
Powered by ViewVC 1.1.5