/[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.21 - (show annotations)
Mon Mar 8 06:11:40 2004 UTC (10 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: mcvs-1-1-0
Changes since 1.20: +0 -5 lines
Revamped loading system. Got rid of require/provide in all
Lisp source files.

* code/mcvs.lisp: New file. Responsible for compiling and loading
everything in the right order.

* code/mcvs-main.lisp: File renamed to main.lisp.

* code/mcvs-package.lisp: File renamed to package.lisp.

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

  ViewVC Help
Powered by ViewVC 1.1.5