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

Contents of /meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (hide annotations)
Sat Aug 31 20:53:13 2002 UTC (11 years, 7 months ago) by kaz
Branch: MAIN
CVS Tags: mcvs-0-24, mcvs-1-0-branch~merged-to-HEAD-1, mcvs-1-0-branch~merged-to-HEAD-0, mcvs-0-22, mcvs-0-23, asdf-import-branch~merged-to-HEAD-0, mcvs-1-1-98, mcvs-1-0-branch~branch-point, mcvs-1-0-11, mcvs-1-0-10, mcvs-1-0-13, mcvs-1-0-12, asdf-import-branch~branch-point, mcvs-1-1-0, mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-5, mcvs-1-0-4, mcvs-1-0-7, mcvs-1-0-6, mcvs-1-0-3, mcvs-1-0-2, HEAD
Branch point for: mcvs-1-0-branch, asdf-import-branch
Changes since 1.11: +13 -5 lines
Merging symlink-branch to main trunk.
1 kaz 1.6 ;;; This source file is part of the Meta-CVS program,
2 kaz 1.3 ;;; which is distributed under the GNU license.
3     ;;; Copyright 2002 Kaz Kylheku
4    
5 kaz 1.1 (provide "clisp-linux")
6    
7     ;;; Null pointer handling
8    
9 kaz 1.10 #.(when (< (first (system::version)) 20020129)
10     (push :clisp-old *features*)
11     (values))
12 kaz 1.1
13 kaz 1.10 #+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 kaz 1.1
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 kaz 1.2 (declare (ignore args))
56 kaz 1.1 (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 kaz 1.2 (declare (ignore args))
64 kaz 1.1 (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 kaz 1.2 (declare (ignore args))
96 kaz 1.1 (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 kaz 1.2 (declare (ignore args))
126 kaz 1.1 (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 kaz 1.5 (defmethod regular-p ((x null))
164     nil)
165    
166 kaz 1.1 (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 kaz 1.5 (defmethod directory-p ((x null))
173     nil)
174    
175 kaz 1.1 (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 kaz 1.5
181     (defmethod symlink-p ((x null))
182     nil)
183 kaz 1.1
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 kaz 1.8 (defun exists (name &key through-link)
217     (no-existence-error (stat name :through-link through-link)))
218    
219 kaz 1.1 ;;; Symbolic and hard links
220    
221     (define-condition link-error (system-error)
222     ((from-path :initarg :from-path)
223 kaz 1.12 (to-path :initarg :to-path)
224     (kind :initarg :kind)))
225 kaz 1.1
226     (defmethod initialize-instance :after ((c link-error) &rest args)
227 kaz 1.2 (declare (ignore args))
228 kaz 1.12 (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 kaz 1.1 (linux:strerror (linux:__errno_location))))))
232    
233     (defun link (from to)
234     (if (zerop (linux:link from to))
235     (values)
236 kaz 1.12 (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 kaz 1.1
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 kaz 1.2 (declare (ignore args))
252 kaz 1.1 (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 kaz 1.7 (defconstant *argument-limit* (* 64 1024))
269 kaz 1.1
270 kaz 1.7 (defun shell-interpreter (command)
271     (case (shell command)
272     ((0) T)
273     (otherwise nil)))
274 kaz 1.1
275 kaz 1.11 (defun execute-program (arglist)
276     (case (run-program (first arglist) :arguments (rest arglist))
277     ((0) T)
278     (otherwise nil)))
279    
280 kaz 1.1 (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 kaz 1.9
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