/[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.26 - (show annotations)
Sat Mar 8 07:22:00 2008 UTC (6 years, 1 month ago) by kaz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.25: +3 -2 lines
* code/clisp-unix.lisp (executable-p (file-info)): A file is considered
executable if at least one of the three execute permissions---owner,
group, or others---is set. Previous broken logic is that a file
is executable if it has owner and group execute permissions.
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))
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-funcs:errno unix-funcs: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 (unix-funcs:strerror unix-funcs: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 (unix-funcs:strerror unix-funcs:errno)))))
44
45
46 (defun opendir (dir)
47 (or (unix-funcs:opendir dir)
48 (error (make-condition 'open-dir-error :dir dir))))
49
50 (declaim (inline closedir))
51 (defun closedir (dir-stream)
52 (when dir-stream (unix-funcs:closedir dir-stream)))
53
54
55 (defun readdir (dir-stream)
56 (let ((dir-entry (unix-funcs:readdir dir-stream)))
57 (if dir-entry
58 (with-slots ((name unix-funcs:name) (ino unix-funcs:ino)) dir-entry
59 (values name ino))
60 nil)))
61
62 (defmacro with-open-dir ((var dir) &body forms)
63 `(let ((,var (opendir ,dir)))
64 (unwind-protect
65 (progn ,@forms)
66 (closedir ,var))))
67
68 (define-condition chdir-error (system-error) ((dir :initarg :dir)))
69
70 (defmethod initialize-instance :after ((c chdir-error) &rest args)
71 (declare (ignore args))
72 (with-slots (dir message) c
73 (setf message (format nil "Unable to change to directory ~A: ~A."
74 dir (unix-funcs:strerror unix-funcs:errno)))))
75
76 (defun chdir (dir)
77 (if (= -1 (unix-funcs:chdir dir))
78 (error (make-condition 'chdir-error :dir dir)))
79 (values))
80
81 (defun fchdir (descr)
82 (if (= -1 (unix-funcs:fchdir descr))
83 (error (make-condition 'chdir-error
84 :dir (format nil "[file descriptor ~a]" descr))))
85 (values))
86
87 (define-condition getcwd-error (system-error) ())
88
89 (defmethod initialize-instance :after ((c getcwd-error) &rest args)
90 (declare (ignore args))
91 (with-slots (message) c
92 (setf message (format nil "Unable to determine current directory: ~A."
93 (unix-funcs:strerror unix-funcs:errno)))))
94
95 (declaim (inline getcwd))
96 (defun getcwd ()
97 (or (unix-funcs:getcwd)
98 (error (make-condition 'getcwd-error))))
99
100 (defmacro current-dir-restore (&body forms)
101 (let ((saved-dir (gensym "SAVED-DIR-")))
102 `(let ((,saved-dir (unix-funcs:open "." unix-funcs:o-rdonly 0)))
103 (when (= ,saved-dir -1)
104 (error (make-condition 'open-error :path ".")))
105 (unwind-protect
106 (macrolet ((in-original-dir (&body inner-forms)
107 (let ((in-saved-dir (gensym "INNER-SAVED-DIR-")))
108 `(let ((,in-saved-dir
109 (unix-funcs:open "."
110 unix-funcs:o-rdonly
111 0)))
112 (when (= ,in-saved-dir -1)
113 (error (make-condition 'open-error :path ".")))
114 (unwind-protect
115 (progn (fchdir ,',saved-dir)
116 (progn ,@inner-forms))
117 (fchdir ,in-saved-dir)
118 (unix-funcs:close ,in-saved-dir))))))
119 ,@forms)
120 (fchdir ,saved-dir)
121 (unix-funcs:close ,saved-dir)))))
122
123 ;;; File information
124
125 (define-condition file-info-error (system-error) ((file :initarg :file)))
126
127 (defmethod initialize-instance :after ((c file-info-error) &rest args)
128 (declare (ignore args))
129 (with-slots (file message) c
130 (setf message (format nil "Unable to get status of ~A: ~A."
131 file (unix-funcs:strerror unix-funcs:errno)))))
132
133 (defclass file-info ()
134 ((file-name :initarg :file-name :accessor file-name)
135 (mode-flags :initarg :mode-flags :accessor mode-flags)
136 (mod-time :initarg :mod-time :accessor mod-time)
137 (inode :initarg :inode :accessor inode)
138 (num-links :initarg :num-links :accessor num-links)))
139
140 (defgeneric same-file-p (file1 file2))
141 (defgeneric older-p (file1 file2))
142 (defgeneric regular-p (file))
143 (defgeneric directory-p (file))
144 (defgeneric symlink-p (file))
145 (defgeneric is-root-p (file))
146 (defgeneric get-parent (file))
147 (defgeneric executable-p (file))
148 (defgeneric make-executable (file))
149 (defgeneric make-non-executable (file))
150
151 (defmethod same-file-p ((f1 file-info) (f2 file-info))
152 (= (inode f1) (inode f2)))
153
154 (defmethod same-file-p ((f1 string) (f2 string))
155 (= (stat f1) (stat f2)))
156
157 (defmethod older-p ((f1 file-info) (f2 file-info))
158 (< (mod-time f1) (mod-time f2)))
159
160 (defmethod older-p ((f1 string) (f2 string))
161 (older-p (stat f1) (stat f2)))
162
163 (defmethod regular-p ((file file-info))
164 (unix-funcs:s-isreg (mode-flags file)))
165
166 (defmethod regular-p ((filename string))
167 (regular-p (stat filename)))
168
169 (defmethod regular-p ((x null))
170 nil)
171
172 (defmethod directory-p ((file file-info))
173 (unix-funcs:s-isdir (mode-flags file)))
174
175 (defmethod directory-p ((filename string))
176 (directory-p (stat filename)))
177
178 (defmethod directory-p ((x null))
179 nil)
180
181 (defmethod symlink-p ((file file-info))
182 (unix-funcs:s-islnk (mode-flags file)))
183
184 (defmethod symlink-p ((filename string))
185 (symlink-p (stat filename)))
186
187 (defmethod symlink-p ((x null))
188 nil)
189
190 (defmethod is-root-p ((file file-info))
191 (and (directory-p file)
192 (same-file-p file (stat (format nil "~a/.." (file-name file))))))
193
194 (defmethod is-root-p ((filename string))
195 (is-root-p (stat filename)))
196
197 (defmethod get-parent ((file file-info))
198 (stat (format nil "~a/.." (file-name file))))
199
200 (defmethod get-parent ((filename string))
201 (stat (format nil "~a/.." filename)))
202
203 (defmethod executable-p ((file file-info))
204 (with-slots ((mode mode-flags)) file
205 (not (and (zerop (logand mode unix-funcs:s-ixusr))
206 (zerop (logand mode unix-funcs:s-ixgrp))
207 (zerop (logand mode unix-funcs:s-ixoth))))))
208
209 (defmethod executable-p ((filename string))
210 (executable-p (stat filename)))
211
212 (defmethod make-executable ((file file-info))
213 (with-slots ((mode mode-flags) file-name) file
214 (let ((saved-mode mode))
215 (unless (zerop (logand mode unix-funcs:s-irusr))
216 (setf mode (logior mode unix-funcs:s-ixusr)))
217 (unless (zerop (logand mode unix-funcs:s-irgrp))
218 (setf mode (logior mode unix-funcs:s-ixgrp)))
219 (unless (zerop (logand mode unix-funcs:s-iroth))
220 (setf mode (logior mode unix-funcs:s-ixoth)))
221 (unless (= mode saved-mode)
222 (unix-funcs:chmod file-name mode)))))
223
224 (defmethod make-executable ((filename string))
225 (make-executable (stat filename)))
226
227 (defmethod make-non-executable ((file file-info))
228 (with-slots ((mode mode-flags) file-name) file
229 (let ((saved-mode mode))
230 (setf mode (logand mode
231 (lognot (logior unix-funcs:s-ixusr
232 unix-funcs:s-ixgrp
233 unix-funcs:s-ixoth))))
234 (unless (= mode saved-mode)
235 (unix-funcs:chmod file-name mode)))))
236
237 (defmethod make-non-executable ((filename string))
238 (make-non-executable (stat filename)))
239
240 (defun stat (name &key through-link)
241 (if (typep name 'file-info)
242 name
243 (multiple-value-bind (result stat-info)
244 (if through-link
245 (unix-funcs:stat name)
246 (unix-funcs:lstat name))
247 (when (= result -1)
248 (error (make-condition 'file-info-error :file name)))
249 (with-slots ((mode unix-funcs:mode)
250 (mtime unix-funcs:mtime)
251 (inode unix-funcs:ino)
252 (nlink unix-funcs:nlink)) stat-info
253 (make-instance 'file-info :file-name name
254 :mode-flags mode
255 :mod-time mtime
256 :inode inode
257 :num-links nlink)))))
258
259 (defun exists (name &key through-link)
260 (no-existence-error (stat name :through-link through-link)))
261
262 ;;; Symbolic and hard links
263
264 (define-condition link-error (system-error)
265 ((from-path :initarg :from-path)
266 (to-path :initarg :to-path)
267 (kind :initarg :kind)))
268
269 (defmethod initialize-instance :after ((c link-error) &rest args)
270 (declare (ignore args))
271 (with-slots (message kind from-path to-path) c
272 (setf message (format nil "Unable to make ~A link called ~A referencing ~A."
273 kind to-path from-path
274 (unix-funcs:strerror unix-funcs:errno)))))
275
276 (defun link (from to)
277 (if (zerop (unix-funcs:link from to))
278 (values)
279 (error (make-condition 'link-error :from-path from
280 :to-path to :kind "hard"))))
281
282 (defun symlink (from to)
283 (if (zerop (unix-funcs:symlink from to))
284 (values)
285 (error (make-condition 'link-error :from-path from
286 :to-path to :kind "symbolic"))))
287
288 (define-condition readlink-error (system-error)
289 ((path :initarg :path)))
290
291 (defmethod initialize-instance :after ((c readlink-error) &rest args)
292 (declare (ignore args))
293 (with-slots (message path) c
294 (setf message (format nil "Unable to read symbolic link ~A: ~A."
295 path (unix-funcs:strerror unix-funcs:errno)))))
296
297 (defun readlink (path)
298 (let ((data (unix-funcs:readlink path)))
299 (if data
300 data
301 (error (make-condition 'readlink-error :path path)))))
302
303 ;;; Directory removal
304
305 (define-condition rm-error (system-error)
306 ((path :initarg :path)))
307
308 (defmethod initialize-instance :after ((c rm-error) &rest args)
309 (declare (ignore args))
310 (with-slots (message path) c
311 (setf message (format nil "Unable to remove ~A: ~A."
312 path (unix-funcs:strerror unix-funcs:errno)))))
313
314 (defun rmdir (dir)
315 (if (zerop (unix-funcs:rmdir dir))
316 (values)
317 (error (make-condition 'rm-error :path dir))))
318
319 (defun unlink (file)
320 (if (zerop (unix-funcs:unlink file))
321 (values)
322 (error (make-condition 'rm-error :path file))))
323
324 ;;; pipes
325
326 ;;; A process pipe consists of a CLISP stream (input or output), and a child
327 ;;; process ID. Additionally, the direction records the stream's direction,
328 ;;; the fd records its file descriptor.
329
330 (defstruct process-pipe
331 (stream)
332 (child-pid)
333 (direction)
334 (fd))
335
336 (defun create-process-pipe (func direction)
337 (multiple-value-bind (result fd) (unix-funcs:pipe)
338 (when (< 0 result)
339 (error "failed to create pipe: ~A"
340 (unix-funcs:strerror unix-funcs:errno)))
341 (let ((child (unix-funcs:fork)))
342 (cond
343 ((< child 0)
344 (map nil #'unix-funcs:close fd)
345 (error "fork failed: ~A."
346 (unix-funcs:strerror unix-funcs:errno)))
347 ((zerop child)
348 (case direction
349 (:output
350 (ext:duplicate-handle (aref fd 0) 0)
351 (setf *standard-input* (ext:make-stream
352 (aref fd 0)
353 :direction :input
354 :element-type 'character)))
355 (:input
356 (ext:duplicate-handle (aref fd 1) 1)
357 (setf *standard-output* (ext:make-stream
358 (aref fd 1)
359 :direction :output
360 :element-type 'character))))
361 (map nil #'unix-funcs:close fd)
362 (funcall func)
363 (force-output *standard-output*)
364 (unix-funcs:_exit 1))
365 (t
366 (unwind-protect
367 (case direction
368 (:output
369 (make-process-pipe
370 :stream (ext:make-stream (aref fd 1)
371 :direction direction
372 :element-type 'character)
373 :direction direction
374 :fd (ext:duplicate-handle (aref fd 1))
375 :child-pid child))
376 (:input
377 (make-process-pipe
378 :stream (ext:make-stream (aref fd 0)
379 :direction direction
380 :element-type 'character)
381 :direction direction
382 :fd (ext:duplicate-handle (aref fd 0))
383 :child-pid child)))
384 (map nil #'unix-funcs:close fd)))))))
385
386 (defun close-process-pipe (pipe)
387 (unix-funcs:default-sigchld)
388 (close (slot-value pipe 'stream))
389 (unix-funcs:close (slot-value pipe 'fd))
390 (setf (slot-value pipe 'stream) nil)
391 (setf (slot-value pipe 'fd) nil)
392 (loop for result = (unix-funcs:waitpid (slot-value pipe 'child-pid) 0)
393 do (when (and (< result 0) (/= unix-funcs:errno unix-funcs:eintr))
394 (error "waitpid failed: ~A"
395 (unix-funcs:strerror unix-funcs:errno)))
396 until (>= result 0))
397 (setf (slot-value pipe 'child-pid) nil)
398 (values))
399
400 ;;; Coprocesses
401
402 (defun shell-interpreter (command)
403 (case (ext:shell command)
404 ((0) T)
405 (otherwise nil)))
406
407 (defvar *default-execute-filter* nil)
408
409 (defun execute-program (arglist)
410 (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
411 (let ((result nil))
412 (let ((pipe nil)
413 (saved-handle)
414 (saved-handle-which)
415 (*standard-output* *standard-output*)
416 (*standard-input* *standard-input*))
417 (unwind-protect
418 (progn
419 (when *default-execute-filter*
420 (setf pipe (funcall *default-execute-filter*))
421 (case (slot-value pipe 'direction)
422 (:output
423 (setf *standard-output* (slot-value pipe 'stream))
424 (setf saved-handle (ext:duplicate-handle 1))
425 (setf saved-handle-which 1)
426 (ext:duplicate-handle (slot-value pipe 'fd) 1))
427 (:input
428 (setf *standard-input* (slot-value pipe 'stream))
429 (setf saved-handle (ext:duplicate-handle 0))
430 (setf saved-handle-which 0)
431 (ext:duplicate-handle (slot-value pipe 'fd) 0))))
432 (setf result (unix-funcs:run-program (first arglist)
433 :arguments (rest arglist))))
434 (when saved-handle
435 (ext:duplicate-handle saved-handle saved-handle-which))
436 (when pipe
437 (close-process-pipe pipe))))
438 (case result
439 ((0)
440 (chatter-debug "successful termination~%") T)
441 (otherwise
442 (chatter-debug "unsuccessful or abnormal termination~%") nil))))
443
444 (defmacro with-filtered-execute-program ((enabled-expr func-expr direction)
445 &body body)
446 `(let* ((*default-execute-filter*
447 (if ,enabled-expr
448 (lambda () (create-process-pipe ,func-expr ,direction))
449 *default-execute-filter*)))
450 ,@body))
451
452 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
453 (let ((arg-list-sym (gensym "ARG-LIST-")))
454 `(let ((,arg-list-sym ,arg-list))
455 (chatter-debug "piping from ~s in directory ~s~%" ,arg-list-sym (getcwd))
456 (unix-funcs:default-sigchld)
457 (let* ((,stream-var (ext:make-pipe-input-stream
458 (arglist-to-command-string ,arg-list-sym))))
459 (declare (dynamic-extent ,stream-var))
460 (when ,stream-var
461 (unwind-protect (progn ,@forms) (close ,stream-var)))))))
462
463 (defmacro with-output-to-program ((stream-var arg-list) &body forms)
464 `(progn
465 (unix-funcs:default-sigchld)
466 (let* ((,stream-var (ext:make-pipe-output-stream
467 (arglist-to-command-string ,arg-list))))
468 (declare (dynamic-extent ,stream-var))
469 (when ,stream-var
470 (unwind-protect (progn ,@forms) (close ,stream-var))))))
471
472 ;;; GUID generation
473
474 (defvar *have-dev-random* t)
475 (defvar *mcvs-random-state*)
476
477 (defun guid-gen ()
478 (cond
479 (*have-dev-random*
480 (or (ignore-errors
481 (with-open-file (f "/dev/urandom"
482 :direction :input
483 :element-type '(unsigned-byte 128))
484 (read-byte f)))
485 (progn
486 (setf *have-dev-random* nil)
487 (setf *mcvs-random-state* (make-random-state t))
488 (guid-gen))))
489 (t (random #.(expt 2 128) *mcvs-random-state*))))
490
491 ;;; Environment strings
492 (defun env-lookup (name &optional substitute-if-not-found)
493 (let ((value (ext:getenv name)))
494 (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5