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

Contents of /meta-cvs/F-8B1C05210FE068EABD820A59D92A1FE0

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5