/[meta-cvs]/meta-cvs/F-F2161DB7639DA27126B44A9243BD74E8.lisp
ViewVC logotype

Contents of /meta-cvs/F-F2161DB7639DA27126B44A9243BD74E8.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Fri Nov 24 04:53:50 2006 UTC (7 years, 4 months ago) by kaz
Branch: MAIN
CVS Tags: asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, asdf-import-branch~branch-point, HEAD
Branch point for: asdf-import-branch
Changes since 1.6: +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 ;;; 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 ;;; Base condition
8
9 (define-condition system-error (error) ((message :initarg :message :reader message))
10 (:report (lambda (condition stream)
11 (format stream "System error: ~A"
12 (slot-value condition 'message)))))
13
14 ;;; Macro to catch ENOENT errors and turn them into nil
15 ;;; return value.
16
17 (defmacro no-existence-error (&body forms)
18 (let ((block-sym (gensym "BLOCK-")))
19 `(block ,block-sym
20 (handler-bind
21 ((system-error #'(lambda (con)
22 (declare (ignore con))
23 (if (= unix:unix-errno unix:ENOENT)
24 (return-from ,block-sym nil)))))
25 ,@forms))))
26
27 ;;; Directory access
28
29 (define-condition open-dir-error (system-error) ((dir :initarg :dir)))
30
31 (defmethod initialize-instance :after ((c open-dir-error) &rest args)
32 (declare (ignore args))
33 (with-slots (dir message) c
34 (setf message (format nil "Unable to open ~A: ~A."
35 dir (aref unix::*unix-errors* (unix:unix-errno))))))
36
37 (define-condition open-error (system-error) ((path :initarg :path)))
38
39 (defmethod initialize-instance :after ((c open-error) &rest args)
40 (declare (ignore args))
41 (with-slots (path message) c
42 (setf message (format nil "Unable to open ~A: ~A."
43 path (aref unix::*unix-errors* (unix:unix-errno))))))
44
45
46 (defun opendir (dir)
47 (cond
48 ((unix:open-dir dir))
49 (t (error (make-condition 'open-dir-error :dir dir)))))
50
51 (declaim (inline closedir))
52 (defun closedir (dir-stream)
53 (when dir-stream (unix:close-dir dir-stream)))
54
55 (declaim (inline readdir))
56 (defun readdir (dir-stream)
57 (unix:read-dir dir-stream))
58
59
60 (defmacro with-open-dir ((var dir) &body forms)
61 `(let ((,var (opendir ,dir)))
62 (unwind-protect
63 (progn ,@forms)
64 (closedir ,var))))
65
66 (define-condition chdir-error (system-error) ((dir :initarg :dir)))
67
68 (defmethod initialize-instance :after ((c chdir-error) &rest args)
69 (declare (ignore args))
70 (with-slots (dir message) c
71 (setf message (format nil "Unable to change to directory ~A: ~A."
72 dir (aref unix::*unix-errors* (unix:unix-errno))))))
73
74 (defun chdir (dir)
75 (if (not (unix:unix-chdir dir))
76 (error (make-condition 'chdir-error :dir dir)))
77 (values))
78
79 (defmacro current-dir-restore (&body forms)
80 (let ((saved-dir (gensym "SAVED-DIR-"))
81 (getdir-ok (gensym "GETDIR-OK-")))
82 `(multiple-value-bind (,getdir-ok ,saved-dir)
83 (unix:unix-current-directory)
84 (when (not ,getdir-ok)
85 (error "could not determine current working directory"))
86 (unwind-protect (progn ,@forms)
87 (chdir ,saved-dir)))))
88
89 ;;; File information
90
91 (define-condition file-info-error (system-error) ((file :initarg :file)))
92
93 (defmethod initialize-instance :after ((c file-info-error) &rest args)
94 (declare (ignore args))
95 (with-slots (file message) c
96 (setf message (format nil "Unable to get status of ~A: ~A."
97 file (aref unix::*unix-errors* (unix:unix-errno))))))
98
99 (defclass file-info ()
100 ((file-name :initarg :file-name :accessor file-name)
101 (mode-flags :initarg :mode-flags :accessor mode-flags)
102 (mod-time :initarg :mod-time :accessor mod-time)
103 (inode :initarg :inode :accessor inode)
104 (num-links :initarg :num-links :accessor num-links)))
105
106 (defgeneric same-file-p (file1 file2))
107 (defgeneric older-p (file1 file2))
108 (defgeneric regular-p (file))
109 (defgeneric directory-p (file))
110 (defgeneric symlink-p (file))
111 (defgeneric is-root-p (file))
112 (defgeneric get-parent (file))
113
114 (defmethod same-file-p ((f1 file-info) (f2 file-info))
115 (= (inode f1) (inode f2)))
116
117 (defmethod same-file-p ((f1 string) (f2 string))
118 (= (stat f1) (stat f2)))
119
120 (defmethod older-p ((f1 file-info) (f2 file-info))
121 (< (mod-time f1) (mod-time f2)))
122
123 (defmethod older-p ((f1 string) (f2 string))
124 (older-p (stat f1) (stat f2)))
125
126 (defmethod regular-p ((file file-info))
127 (not (zerop (logand unix:s-ifreg (mode-flags file)))))
128
129 (defmethod regular-p ((filename string))
130 (regular-p (stat filename)))
131
132 (defmethod regular-p ((x null))
133 nil)
134
135 (defmethod directory-p ((file file-info))
136 (not (zerop (logand unix:s-ifdir (mode-flags file)))))
137
138 (defmethod directory-p ((filename string))
139 (directory-p (stat filename)))
140
141 (defmethod directory-p ((x null))
142 nil)
143
144 (defmethod symlink-p ((file file-info))
145 (not (zerop (logand unix:s-iflnk (mode-flags file)))))
146
147 (defmethod symlink-p ((filename string))
148 (symlink-p (stat filename)))
149
150 (defmethod symlink-p ((x null))
151 nil)
152
153 (defmethod is-root-p ((file file-info))
154 (and (directory-p file)
155 (same-file-p file (stat (format nil "~a/.." (file-name file))))))
156
157 (defmethod is-root-p ((filename string))
158 (is-root-p (stat filename)))
159
160 (defmethod get-parent ((file file-info))
161 (stat (format nil "~a/.." (file-name file))))
162
163 (defmethod get-parent ((filename string))
164 (stat (format nil "~a/.." filename)))
165
166 (defun stat (name &key through-link)
167 (if (typep name 'file-info)
168 name
169 (multiple-value-bind (okay dev inode mode nlink owner group
170 devnum size atime mtime ctime)
171 (if through-link
172 (unix:unix-stat name)
173 (unix:unix-lstat name))
174 (declare (ignore dev owner
175 group devnum size atime ctime))
176 (when (not okay)
177 (error (make-condition 'file-info-error :file name)))
178 (make-instance 'file-info :file-name name
179 :mode-flags mode
180 :mod-time mtime
181 :inode inode
182 :num-links nlink))))
183
184 (defun exists (name &key through-link)
185 (no-existence-error (stat name :through-link through-link)))
186
187 ;;; Symbolic and hard links
188
189 (define-condition link-error (system-error)
190 ((from-path :initarg :from-path)
191 (to-path :initarg :to-path)))
192
193 (defmethod initialize-instance :after ((c link-error) &rest args)
194 (declare (ignore args))
195 (with-slots (message from-path to-path) c
196 (setf message (format nil "Unable to link ~A to ~A: ~A."
197 from-path to-path
198 (aref unix::*unix-errors* (unix:unix-errno))))))
199
200 (defun link (from to)
201 (if (unix:unix-link from to)
202 (values)
203 (error (make-condition 'link-error :from-path from :to-path to))))
204
205 ;;; Directory removal
206
207 (define-condition rm-error (system-error)
208 ((path :initarg :path)))
209
210 (defmethod initialize-instance :after ((c rm-error) &rest args)
211 (declare (ignore args))
212 (with-slots (message path) c
213 (setf message (format nil "Unable to remove ~A: ~A."
214 path (aref unix::*unix-errors* (unix:unix-errno))))))
215
216 (defun rmdir (dir)
217 (if (unix:unix-rmdir dir)
218 (values)
219 (error (make-condition 'rm-error :path dir))))
220
221 (defun unlink (file)
222 (if (unix:unix-unlink file)
223 (values)
224 (error (make-condition 'rm-error :path file))))
225
226 ;;; Coprocesses
227
228 (defconstant *shell-executable* "/bin/sh")
229
230 (defun shell-interpreter (command)
231 (setf command (coerce command 'simple-string))
232 (let ((pid (unix:unix-fork)))
233 (cond
234 ((< pid 0) ;; error
235 (error "fork failed"))
236 ((zerop pid) ;; child
237 (unix:unix-execve *shell-executable* `(,*shell-executable*
238 "-c" ,command))
239 (unix:unix-exit 1))
240 (t ; parent
241 (multiple-value-bind (pid-out event status)
242 (extensions::wait3)
243 (and (= pid pid-out)
244 (eq event :exited)
245 (eq status 0)))))))
246
247 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
248 `(let* ((,stream-var (make-pipe-input-stream
249 (arglist-to-command-string ,arg-list))))
250 (declare (dynamic-extent ,stream-var))
251 (when ,stream-var
252 (unwind-protect (progn ,@forms) (close ,stream-var)))))
253
254 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
255 `(let* ((,stream-var (make-pipe-output-stream
256 (arglist-to-command-string ,arg-list))))
257 (declare (dynamic-extent ,stream-var))
258 (when ,stream-var
259 (unwind-protect (progn ,@forms) (close ,stream-var)))))
260
261 ;;; GUID generation
262
263 (defun guid-gen ()
264 (with-open-file (f "/dev/urandom"
265 :direction :input
266 :element-type '(unsigned-byte 128))
267 (read-byte f)))

  ViewVC Help
Powered by ViewVC 1.1.5