/[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.17 - (hide annotations)
Fri Feb 21 06:48:43 2003 UTC (11 years, 1 month ago) by kaz
Branch: MAIN
Changes since 1.16: +12 -8 lines
Merging from mcvs-1-0-branch.

Fix remaining occurences of SIG_IGN action for SIGCHLD being
passed to child processes.

* code/unix-bindings/unix.lisp (unix-funcs:default-sigchld): New call
out function.

* code/clisp-unix.lisp (with-input-from-program,
with-output-to-program): Call the new default-sigchild function
to set SIGCHILD signal handler to SIG_DFL just before creating
the pipe.

* code/unix-bindings/wrap.c (mcvs_default_sigchld): New function.
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.12 (require "chatter.lisp")
6 kaz 1.11 (require "unix")
7 kaz 1.13 (require "mcvs-package")
8 kaz 1.11 (provide "clisp-unix")
9 kaz 1.1
10 kaz 1.13 (in-package "META-CVS")
11    
12 kaz 1.1 ;;; Null pointer handling
13    
14     #.(when (< (first (system::version)) 20020129)
15 kaz 1.2 (push :clisp-old *features*)
16     (values))
17 kaz 1.1
18 kaz 1.2 #+clisp-old
19     (defmacro pointer-null (p) `(unix-funcs:null-pointer-p ,p))
20 kaz 1.1
21 kaz 1.2 #-clisp-old
22     (defmacro pointer-null (p) `(ffi:foreign-address-null ,p))
23 kaz 1.1
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 kaz 1.16 (declaim (inline closedir))
76 kaz 1.1 (defun closedir (dir-stream)
77     (when-not-null dir-stream (unix-funcs:closedir dir-stream)))
78    
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 kaz 1.15 (define-condition getcwd-error (system-error) ())
113    
114     (defmethod initialize-instance :after ((c getcwd-error) &rest args)
115     (declare (ignore args))
116     (with-slots (message) c
117     (setf message (format nil "Unable to determine current directory: ~A."
118     (unix-funcs:strerror unix-funcs:errno)))))
119    
120 kaz 1.16 (declaim (inline getcwd))
121 kaz 1.3 (defun getcwd ()
122 kaz 1.15 (or (unix-funcs:getcwd)
123     (error (make-condition 'getcwd-error))))
124 kaz 1.3
125 kaz 1.1 (defmacro current-dir-restore (&body forms)
126     (let ((saved-dir (gensym "SAVED-DIR-")))
127     `(let ((,saved-dir (unix-funcs:open "." unix-funcs:o-rdonly 0)))
128     (when (= ,saved-dir -1)
129     (error (make-condition 'open-error :path ".")))
130     (unwind-protect (progn ,@forms)
131     (fchdir ,saved-dir)
132     (unix-funcs:close ,saved-dir)))))
133    
134     ;;; File information
135    
136     (define-condition file-info-error (system-error) ((file :initarg :file)))
137    
138     (defmethod initialize-instance :after ((c file-info-error) &rest args)
139     (declare (ignore args))
140     (with-slots (file message) c
141     (setf message (format nil "Unable to get status of ~A: ~A."
142     file (unix-funcs:strerror unix-funcs:errno)))))
143    
144     (defclass file-info ()
145     ((file-name :initarg :file-name :accessor file-name)
146     (mode-flags :initarg :mode-flags :accessor mode-flags)
147     (mod-time :initarg :mod-time :accessor mod-time)
148     (inode :initarg :inode :accessor inode)
149     (num-links :initarg :num-links :accessor num-links)))
150    
151     (defgeneric same-file-p (file1 file2))
152     (defgeneric older-p (file1 file2))
153     (defgeneric regular-p (file))
154     (defgeneric directory-p (file))
155     (defgeneric symlink-p (file))
156     (defgeneric is-root-p (file))
157     (defgeneric get-parent (file))
158 kaz 1.6 (defgeneric executable-p (file))
159     (defgeneric make-executable (file))
160     (defgeneric make-non-executable (file))
161 kaz 1.1
162     (defmethod same-file-p ((f1 file-info) (f2 file-info))
163     (= (inode f1) (inode f2)))
164    
165     (defmethod same-file-p ((f1 string) (f2 string))
166     (= (stat f1) (stat f2)))
167    
168     (defmethod older-p ((f1 file-info) (f2 file-info))
169     (< (mod-time f1) (mod-time f2)))
170    
171     (defmethod older-p ((f1 string) (f2 string))
172     (older-p (stat f1) (stat f2)))
173    
174     (defmethod regular-p ((file file-info))
175     (unix-funcs:s-isreg (mode-flags file)))
176    
177     (defmethod regular-p ((filename string))
178     (regular-p (stat filename)))
179    
180     (defmethod regular-p ((x null))
181     nil)
182    
183     (defmethod directory-p ((file file-info))
184     (unix-funcs:s-isdir (mode-flags file)))
185    
186     (defmethod directory-p ((filename string))
187     (directory-p (stat filename)))
188    
189     (defmethod directory-p ((x null))
190     nil)
191    
192     (defmethod symlink-p ((file file-info))
193     (unix-funcs:s-islnk (mode-flags file)))
194    
195     (defmethod symlink-p ((filename string))
196     (symlink-p (stat filename)))
197    
198     (defmethod symlink-p ((x null))
199     nil)
200    
201     (defmethod is-root-p ((file file-info))
202     (and (directory-p file)
203     (same-file-p file (stat (format nil "~a/.." (file-name file))))))
204    
205     (defmethod is-root-p ((filename string))
206     (is-root-p (stat filename)))
207    
208     (defmethod get-parent ((file file-info))
209     (stat (format nil "~a/.." (file-name file))))
210    
211     (defmethod get-parent ((filename string))
212     (stat (format nil "~a/.." filename)))
213 kaz 1.6
214     (defmethod executable-p ((file file-info))
215     (with-slots ((mode mode-flags)) file
216     (and (not (zerop (logand mode unix-funcs:s-ixusr)))
217     (not (zerop (logand mode unix-funcs:s-ixgrp))))))
218    
219 kaz 1.7 (defmethod executable-p ((filename string))
220     (executable-p (stat filename)))
221    
222 kaz 1.6 (defmethod make-executable ((file file-info))
223     (with-slots ((mode mode-flags) file-name) file
224     (let ((saved-mode mode))
225     (unless (zerop (logand mode unix-funcs:s-irusr))
226     (setf mode (logior mode unix-funcs:s-ixusr)))
227     (unless (zerop (logand mode unix-funcs:s-irgrp))
228     (setf mode (logior mode unix-funcs:s-ixgrp)))
229     (unless (zerop (logand mode unix-funcs:s-iroth))
230     (setf mode (logior mode unix-funcs:s-ixoth)))
231     (unless (= mode saved-mode)
232     (unix-funcs:chmod file-name mode)))))
233    
234     (defmethod make-executable ((filename string))
235     (make-executable (stat filename)))
236    
237     (defmethod make-non-executable ((file file-info))
238     (with-slots ((mode mode-flags) file-name) file
239     (let ((saved-mode mode))
240     (setf mode (logand mode
241     (lognot (logior unix-funcs:s-ixusr
242     unix-funcs:s-ixgrp
243     unix-funcs:s-ixoth))))
244     (unless (= mode saved-mode)
245     (unix-funcs:chmod file-name mode)))))
246    
247     (defmethod make-non-executable ((filename string))
248     (make-non-executable (stat filename)))
249 kaz 1.1
250     (defun stat (name &key through-link)
251     (if (typep name 'file-info)
252     name
253     (multiple-value-bind (result stat-info)
254     (if through-link
255     (unix-funcs:stat name)
256     (unix-funcs:lstat name))
257     (when (= result -1)
258     (error (make-condition 'file-info-error :file name)))
259     (with-slots ((mode unix-funcs:mode)
260     (mtime unix-funcs:mtime)
261     (inode unix-funcs:ino)
262     (nlink unix-funcs:nlink)) stat-info
263     (make-instance 'file-info :file-name name
264     :mode-flags mode
265     :mod-time mtime
266     :inode inode
267     :num-links nlink)))))
268    
269     (defun exists (name &key through-link)
270     (no-existence-error (stat name :through-link through-link)))
271    
272     ;;; Symbolic and hard links
273    
274     (define-condition link-error (system-error)
275     ((from-path :initarg :from-path)
276 kaz 1.5 (to-path :initarg :to-path)
277     (kind :initarg :kind)))
278 kaz 1.1
279     (defmethod initialize-instance :after ((c link-error) &rest args)
280     (declare (ignore args))
281 kaz 1.5 (with-slots (message kind from-path to-path) c
282     (setf message (format nil "Unable to make ~A link called ~A referencing ~A."
283     kind to-path from-path
284 kaz 1.1 (unix-funcs:strerror unix-funcs:errno)))))
285    
286     (defun link (from to)
287     (if (zerop (unix-funcs:link from to))
288     (values)
289 kaz 1.5 (error (make-condition 'link-error :from-path from
290     :to-path to :kind "hard"))))
291    
292     (defun symlink (from to)
293     (if (zerop (unix-funcs:symlink from to))
294     (values)
295     (error (make-condition 'link-error :from-path from
296     :to-path to :kind "symbolic"))))
297    
298     (define-condition readlink-error (system-error)
299     ((path :initarg :path)))
300    
301     (defmethod initialize-instance :after ((c readlink-error) &rest args)
302     (declare (ignore args))
303     (with-slots (message path) c
304     (setf message (format nil "Unable to read symbolic link ~A: ~A."
305     path (unix-funcs:strerror unix-funcs:errno)))))
306    
307     (defun readlink (path)
308     (let ((data (unix-funcs:readlink path)))
309     (if data
310     data
311     (error (make-condition 'readlink-error :path path)))))
312 kaz 1.1
313     ;;; Directory removal
314    
315     (define-condition rm-error (system-error)
316     ((path :initarg :path)))
317    
318     (defmethod initialize-instance :after ((c rm-error) &rest args)
319     (declare (ignore args))
320     (with-slots (message path) c
321     (setf message (format nil "Unable to remove ~A: ~A."
322     path (unix-funcs:strerror unix-funcs:errno)))))
323    
324     (defun rmdir (dir)
325     (if (zerop (unix-funcs:rmdir dir))
326     (values)
327     (error (make-condition 'rm-error :path dir))))
328    
329     (defun unlink (file)
330     (if (zerop (unix-funcs:unlink file))
331     (values)
332     (error (make-condition 'rm-error :path file))))
333    
334     ;;; Coprocesses
335    
336     (defun shell-interpreter (command)
337 kaz 1.13 (case (ext:shell command)
338 kaz 1.1 ((0) T)
339     (otherwise nil)))
340    
341 kaz 1.4 (defun execute-program (arglist)
342 kaz 1.12 (chatter-debug "invoking ~s in directory ~s~%" arglist (getcwd))
343 kaz 1.14 (case (unix-funcs:run-program (first arglist) :arguments (rest arglist))
344 kaz 1.12 ((0) (chatter-debug "successful termination~%") T)
345     (otherwise (chatter-debug "unsuccessful or abnormal termination~%") nil)))
346 kaz 1.4
347 kaz 1.1 (defmacro with-input-from-program ((stream-var arg-list) &body forms)
348 kaz 1.17 `(progn
349     (unix-funcs:default-sigchld)
350     (let* ((,stream-var (ext:make-pipe-input-stream
351 kaz 1.1 (arglist-to-command-string ,arg-list))))
352 kaz 1.17 (declare (dynamic-extent ,stream-var))
353     (when ,stream-var
354     (unwind-protect (progn ,@forms) (close ,stream-var))))))
355 kaz 1.1
356     (defmacro with-output-to-program ((stream-var arg-list) &body forms)
357 kaz 1.17 `(progn
358     (unix-funcs:default-sigchld)
359     (let* ((,stream-var (ext:make-pipe-output-stream
360 kaz 1.1 (arglist-to-command-string ,arg-list))))
361 kaz 1.17 (declare (dynamic-extent ,stream-var))
362     (when ,stream-var
363     (unwind-protect (progn ,@forms) (close ,stream-var))))))
364 kaz 1.1
365     ;;; GUID generation
366    
367 kaz 1.8 (defvar *have-dev-random* t)
368     (defvar *mcvs-random-state*)
369    
370 kaz 1.1 (defun guid-gen ()
371 kaz 1.8 (cond
372     (*have-dev-random*
373 kaz 1.9 (or (ignore-errors
374     (with-open-file (f "/dev/urandom"
375     :direction :input
376     :element-type '(unsigned-byte 128))
377     (read-byte f)))
378     (progn
379     (setf *have-dev-random* nil)
380     (setf *mcvs-random-state* (make-random-state t))
381     (guid-gen))))
382 kaz 1.8 (t (random #.(expt 2 128) *mcvs-random-state*))))
383 kaz 1.1
384     ;;; Environment strings
385     (defun env-lookup (name &optional substitute-if-not-found)
386 kaz 1.13 (let ((value (ext:getenv name)))
387 kaz 1.1 (if value value substitute-if-not-found)))

  ViewVC Help
Powered by ViewVC 1.1.5