/[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.23 - (hide annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
Changes since 1.22: +1 -1 lines
Stylistic change.

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

  ViewVC Help
Powered by ViewVC 1.1.5