/[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 - (hide 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 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.7 (in-package :meta-cvs)
6 kaz 1.1
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 kaz 1.5 (declaim (inline closedir))
52 kaz 1.1 (defun closedir (dir-stream)
53     (when dir-stream (unix:close-dir dir-stream)))
54    
55 kaz 1.5 (declaim (inline readdir))
56 kaz 1.1 (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