/[meta-cvs]/meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0
ViewVC logotype

Contents of /meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11.2.1 - (show annotations)
Sat Aug 24 22:37:32 2002 UTC (11 years, 7 months ago) by kaz
Branch: symlink-branch
CVS Tags: symlink-branch~merged-to-HEAD-0
Changes since 1.11: +13 -5 lines
* code/clisp-unix.lisp (link-error): New slot, kind. Holds
the string "symbolic" or "hard".
(initialize-instance link-error): Use new slot in constructing
message.
(link): Specify "hard" value for :kind slot of condition.
(symlink): New function.

* code/clisp-linux.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 (provide "clisp-linux")
6
7 ;;; Null pointer handling
8
9 #.(when (< (first (system::version)) 20020129)
10 (push :clisp-old *features*)
11 (values))
12
13 #+clisp-old
14 (progn
15 (defvar *null-pointer* (linux:realloc (linux:malloc 1) 0))
16 (defun pointer-null (p) (equalp p *null-pointer*)))
17
18 #-clisp-old
19 (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))
20
21 (declaim (inline pointer-null))
22
23 (defmacro null-to-nil (p)
24 (let ((pointer (gensym)))
25 `(let ((,pointer ,p)) (if (pointer-null ,pointer) nil ,pointer))))
26
27 (defmacro when-not-null (p &body forms)
28 `(if (not (pointer-null ,p)) ,@forms))
29
30 ;;; Base condition
31
32 (define-condition system-error (error) ((message :initarg :message))
33 (:report (lambda (condition stream)
34 (format stream "System error: ~A"
35 (slot-value condition 'message)))))
36
37 ;;; Macro to catch ENOENT errors and turn them into nil
38 ;;; return value.
39
40 (defmacro no-existence-error (&body forms)
41 (let ((block-sym (gensym "BLOCK-")))
42 `(block ,block-sym
43 (handler-bind
44 ((system-error #'(lambda (con)
45 (declare (ignore con))
46 (if (= (linux:__errno_location) linux::ENOENT)
47 (return-from ,block-sym nil)))))
48 ,@forms))))
49
50 ;;; Directory access
51
52 (define-condition open-dir-error (system-error) ((dir :initarg :dir)))
53
54 (defmethod initialize-instance :after ((c open-dir-error) &rest args)
55 (declare (ignore args))
56 (with-slots (dir message) c
57 (setf message (format nil "Unable to open ~A: ~A."
58 dir (linux:strerror (linux:__errno_location))))))
59
60 (define-condition open-error (system-error) ((path :initarg :path)))
61
62 (defmethod initialize-instance :after ((c open-error) &rest args)
63 (declare (ignore args))
64 (with-slots (path message) c
65 (setf message (format nil "Unable to open ~A: ~A."
66 path (linux:strerror (linux:__errno_location))))))
67
68
69 (defun opendir (dir)
70 (cond
71 ((null-to-nil (linux:opendir dir)))
72 (t (error (make-condition 'open-dir-error :dir dir)))))
73
74 (defun closedir (dir-stream)
75 (when-not-null dir-stream (linux:closedir dir-stream)))
76
77 (declaim (inline closedir))
78
79 (defun readdir (dir-stream)
80 (let ((dir-entry (linux:readdir dir-stream)))
81 (if dir-entry
82 (with-slots ((name linux::|d_name|) (ino linux::|d_ino|)) dir-entry
83 (values name ino))
84 nil)))
85
86 (defmacro with-open-dir ((var dir) &body forms)
87 `(let ((,var (opendir ,dir)))
88 (unwind-protect
89 (progn ,@forms)
90 (closedir ,var))))
91
92 (define-condition chdir-error (system-error) ((dir :initarg :dir)))
93
94 (defmethod initialize-instance :after ((c chdir-error) &rest args)
95 (declare (ignore args))
96 (with-slots (dir message) c
97 (setf message (format nil "Unable to change to directory ~A: ~A."
98 dir (linux:strerror (linux:__errno_location))))))
99
100 (defun chdir (dir)
101 (if (= -1 (linux:chdir dir))
102 (error (make-condition 'chdir-error :dir dir)))
103 (values))
104
105 (defun fchdir (descr)
106 (if (= -1 (linux:fchdir descr))
107 (error (make-condition 'chdir-error
108 :dir (format nil "[file descriptor ~a]" descr))))
109 (values))
110
111 (defmacro current-dir-restore (&body forms)
112 (let ((saved-dir (gensym "SAVED-DIR-")))
113 `(let ((,saved-dir (linux:open "." linux:O_RDONLY 0)))
114 (when (= ,saved-dir -1)
115 (error (make-condition 'open-error :path ".")))
116 (unwind-protect (progn ,@forms)
117 (fchdir ,saved-dir)
118 (linux:close ,saved-dir)))))
119
120 ;;; File information
121
122 (define-condition file-info-error (system-error) ((file :initarg :file)))
123
124 (defmethod initialize-instance :after ((c file-info-error) &rest args)
125 (declare (ignore args))
126 (with-slots (file message) c
127 (setf message (format nil "Unable to get status of ~A: ~A."
128 file (linux:strerror (linux:__errno_location))))))
129
130 (defclass file-info ()
131 ((file-name :initarg :file-name :accessor file-name)
132 (mode-flags :initarg :mode-flags :accessor mode-flags)
133 (mod-time :initarg :mod-time :accessor mod-time)
134 (inode :initarg :inode :accessor inode)
135 (num-links :initarg :num-links :accessor num-links)))
136
137 (defgeneric same-file-p (file1 file2))
138 (defgeneric older-p (file1 file2))
139 (defgeneric regular-p (file))
140 (defgeneric directory-p (file))
141 (defgeneric symlink-p (file))
142 (defgeneric is-root-p (file))
143 (defgeneric get-parent (file))
144
145 (defmethod same-file-p ((f1 file-info) (f2 file-info))
146 (= (inode f1) (inode f2)))
147
148 (defmethod same-file-p ((f1 string) (f2 string))
149 (= (stat f1) (stat f2)))
150
151 (defmethod older-p ((f1 file-info) (f2 file-info))
152 (< (mod-time f1) (mod-time f2)))
153
154 (defmethod older-p ((f1 string) (f2 string))
155 (older-p (stat f1) (stat f2)))
156
157 (defmethod regular-p ((file file-info))
158 (linux:S_ISREG (mode-flags file)))
159
160 (defmethod regular-p ((filename string))
161 (regular-p (stat filename)))
162
163 (defmethod regular-p ((x null))
164 nil)
165
166 (defmethod directory-p ((file file-info))
167 (linux:S_ISDIR (mode-flags file)))
168
169 (defmethod directory-p ((filename string))
170 (directory-p (stat filename)))
171
172 (defmethod directory-p ((x null))
173 nil)
174
175 (defmethod symlink-p ((file file-info))
176 (linux:S_ISLNK (mode-flags file)))
177
178 (defmethod symlink-p ((filename string))
179 (symlink-p (stat filename)))
180
181 (defmethod symlink-p ((x null))
182 nil)
183
184 (defmethod is-root-p ((file file-info))
185 (and (directory-p file)
186 (same-file-p file (stat (format nil "~a/.." (file-name file))))))
187
188 (defmethod is-root-p ((filename string))
189 (is-root-p (stat filename)))
190
191 (defmethod get-parent ((file file-info))
192 (stat (format nil "~a/.." (file-name file))))
193
194 (defmethod get-parent ((filename string))
195 (stat (format nil "~a/.." filename)))
196
197 (defun stat (name &key through-link)
198 (if (typep name 'file-info)
199 name
200 (multiple-value-bind (result stat-info)
201 (if through-link
202 (linux::stat name)
203 (linux::lstat name))
204 (when (= result -1)
205 (error (make-condition 'file-info-error :file name)))
206 (with-slots ((mode linux::|st_mode|)
207 (mtime linux::|st_mtime|)
208 (inode linux::|st_ino|)
209 (nlink linux::|st_nlink|)) stat-info
210 (make-instance 'file-info :file-name name
211 :mode-flags mode
212 :mod-time mtime
213 :inode inode
214 :num-links nlink)))))
215
216 (defun exists (name &key through-link)
217 (no-existence-error (stat name :through-link through-link)))
218
219 ;;; Symbolic and hard links
220
221 (define-condition link-error (system-error)
222 ((from-path :initarg :from-path)
223 (to-path :initarg :to-path)
224 (kind :initarg :kind)))
225
226 (defmethod initialize-instance :after ((c link-error) &rest args)
227 (declare (ignore args))
228 (with-slots (message kind from-path to-path) c
229 (setf message (format nil "Unable to make ~A link from ~A to ~A: ~A."
230 kind from-path to-path
231 (linux:strerror (linux:__errno_location))))))
232
233 (defun link (from to)
234 (if (zerop (linux:link from to))
235 (values)
236 (error (make-condition 'link-error :from-path from
237 :to-path to :kind "hard"))))
238
239 (defun symlink (from to)
240 (if (zerop (linux:symlink from to))
241 (values)
242 (error (make-condition 'link-error :from-path from
243 :to-path to :kind "symbolic"))))
244
245 ;;; Directory removal
246
247 (define-condition rm-error (system-error)
248 ((path :initarg :path)))
249
250 (defmethod initialize-instance :after ((c rm-error) &rest args)
251 (declare (ignore args))
252 (with-slots (message path) c
253 (setf message (format nil "Unable to remove ~A: ~A."
254 path (linux:strerror (linux:__errno_location))))))
255
256 (defun rmdir (dir)
257 (if (zerop (linux:rmdir dir))
258 (values)
259 (error (make-condition 'rm-error :path dir))))
260
261 (defun unlink (file)
262 (if (zerop (linux:unlink file))
263 (values)
264 (error (make-condition 'rm-error :path file))))
265
266 ;;; Coprocesses
267
268 (defconstant *argument-limit* (* 64 1024))
269
270 (defun shell-interpreter (command)
271 (case (shell command)
272 ((0) T)
273 (otherwise nil)))
274
275 (defun execute-program (arglist)
276 (case (run-program (first arglist) :arguments (rest arglist))
277 ((0) T)
278 (otherwise nil)))
279
280 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
281 `(let* ((,stream-var (make-pipe-input-stream
282 (arglist-to-command-string ,arg-list))))
283 (declare (dynamic-extent ,stream-var))
284 (when ,stream-var
285 (unwind-protect (progn ,@forms) (close ,stream-var)))))
286
287 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
288 `(let* ((,stream-var (make-pipe-output-stream
289 (arglist-to-command-string ,arg-list))))
290 (declare (dynamic-extent ,stream-var))
291 (when ,stream-var
292 (unwind-protect (progn ,@forms) (close ,stream-var)))))
293
294 ;;; GUID generation
295
296 (defun guid-gen ()
297 (with-open-file (f "/dev/urandom"
298 :direction :input
299 :element-type '(unsigned-byte 128))
300 (read-byte f)))
301
302 ;;; Environment strings
303 (defun env-lookup (name &optional substitute-if-not-found)
304 (let ((value (getenv name)))
305 (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5