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

Contents of /meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Feb 8 06:51:45 2002 UTC (12 years, 2 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-6, mcvs-0-5, latest-patch
Changes since 1.7: +3 -0 lines
* sync.lisp (synchronize-files): Return :dir symbol when either
argument is a directory.
* mapping.lisp (mapping-synchronize): Chatter output messages
are shorter. Handles :dir return value from synchronize-files.
(mapping-update): New sanity checks for moved and added
files, to avoid clobbering local files. Removed redundant
call to ensure-directories-exit in move logic, because
synchronize-files will do it anyway. Chatter messages reordered
to occur before their corresponding action is done.

* mcvs-main.lisp (*mcvs-error-treatment*): Special variable
can have new domain value, namely :decline.
(mcvs-top-error-handler): Print error message when terminating
non-restartable error. Handle new :decline treatment by
simply returning.
(mcvs-debug-shell): Set *mcvs-error-treatment* to :decline
so that errors are caught by debugger.
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-linux")
6
7 ;;; Null pointer handling
8
9 (defvar *null-pointer* (linux:realloc (linux:malloc 1) 0))
10
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 (declare (ignore args))
48 (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 (declare (ignore args))
56 (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 (declare (ignore args))
88 (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 (declare (ignore args))
118 (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 (defmethod regular-p ((x null))
156 nil)
157
158 (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 (defmethod directory-p ((x null))
165 nil)
166
167 (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
173 (defmethod symlink-p ((x null))
174 nil)
175
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 (defun exists (name &key through-link)
209 (no-existence-error (stat name :through-link through-link)))
210
211 ;;; Symbolic and hard links
212
213 (define-condition link-error (system-error)
214 ((from-path :initarg :from-path)
215 (to-path :initarg :to-path)))
216
217 (defmethod initialize-instance :after ((c link-error) &rest args)
218 (declare (ignore args))
219 (with-slots (message from-path to-path) c
220 (setf message (format nil "Unable to link ~A to ~A: ~A."
221 from-path to-path
222 (linux:strerror (linux:__errno_location))))))
223
224 (defun link (from to)
225 (if (zerop (linux:link from to))
226 (values)
227 (error (make-condition 'link-error :from-path from :to-path to))))
228
229 ;;; Directory removal
230
231 (define-condition rm-error (system-error)
232 ((path :initarg :path)))
233
234 (defmethod initialize-instance :after ((c rm-error) &rest args)
235 (declare (ignore args))
236 (with-slots (message path) c
237 (setf message (format nil "Unable to remove ~A: ~A."
238 path (linux:strerror (linux:__errno_location))))))
239
240 (defun rmdir (dir)
241 (if (zerop (linux:rmdir dir))
242 (values)
243 (error (make-condition 'rm-error :path dir))))
244
245 (defun unlink (file)
246 (if (zerop (linux:unlink file))
247 (values)
248 (error (make-condition 'rm-error :path file))))
249
250 ;;; Coprocesses
251
252 (defconstant *argument-limit* (* 64 1024))
253
254 (defun shell-interpreter (command)
255 (case (shell command)
256 ((0) T)
257 (otherwise nil)))
258
259 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
260 `(let* ((,stream-var (make-pipe-input-stream
261 (arglist-to-command-string ,arg-list))))
262 (declare (dynamic-extent ,stream-var))
263 (when ,stream-var
264 (unwind-protect (progn ,@forms) (close ,stream-var)))))
265
266 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
267 `(let* ((,stream-var (make-pipe-output-stream
268 (arglist-to-command-string ,arg-list))))
269 (declare (dynamic-extent ,stream-var))
270 (when ,stream-var
271 (unwind-protect (progn ,@forms) (close ,stream-var)))))
272
273 ;;; GUID generation
274
275 (defun guid-gen ()
276 (with-open-file (f "/dev/urandom"
277 :direction :input
278 :element-type '(unsigned-byte 128))
279 (read-byte f)))

  ViewVC Help
Powered by ViewVC 1.1.5