/[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.13 - (show annotations)
Thu Oct 31 04:06:01 2002 UTC (11 years, 5 months ago) by kaz
Branch: MAIN
Changes since 1.12: +8 -5 lines
* code/mcvs-package.lisp: New file, defines META-CVS package.

* code/purge.lisp: Put all symbols in new package.
* code/restore.lisp: Likewise.
* code/paths.lisp: Likewise.
* code/install.sh: Likewise.
* code/restart.lisp: Likewise.
* code/update.lisp: Likewise.
* code/move.lisp: Likewise.
* code/grab.lisp: Likewise.
* code/unix.lisp: Likewise.
* code/slot-refs.lisp: Likewise.
* code/prop.lisp: Likewise.
* code/multi-hash.lisp: Likewise.
* code/rcs-utils.lisp: Likewise.
* code/branch.lisp: Likewise.
* code/find-bind.lisp: Likewise.
* code/execute.lisp: Likewise.
* code/link.lisp: Likewise.
* code/split.lisp: Likewise.
* code/watch.lisp: Likewise.
* code/clisp-unix.lisp: Likewise.
* code/add.lisp: Likewise.
* code/chatter.lisp: Likewise.
* code/print.lisp: Likewise.
* code/types.lisp: Likewise.
* code/remove.lisp: Likewise.
* code/convert.lisp: Likewise.
* code/error.lisp: Likewise.
* code/options.lisp: Likewise.
* code/dirwalk.lisp: Likewise.
* code/checkout.lisp: Likewise.
* code/generic.lisp: Likewise.
* code/sync.lisp: Likewise.
* code/create.lisp: Likewise.
* code/memoize.lisp: Likewise.
* code/seqfuncs.lisp: Likewise.
* code/cmucl-unix.lisp: Likewise.
* code/remap.lisp: Likewise.

* code/mapping.lisp: Put symbols in new package. Replace use
of CLISP specific substring function with subseq.
* code/filt.lisp: Likewise.

* code/mcvs-main.lisp: Put symbols in new package. The mcvs
function is renamed to main.

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

  ViewVC Help
Powered by ViewVC 1.1.5