/[meta-cvs]/meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp
ViewVC logotype

Contents of /meta-cvs/F-258A1D35AE34AADD34D34F5A328405CC.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Wed Apr 23 05:39:27 2003 UTC (11 years ago) by kaz
Branch: MAIN
Changes since 1.9: +10 -1 lines
Merging from mcvs-1-0-branch.

Improved error handling.  Use of tty for user interaction, plus
new global option for selecting non-interactive bail behavior.

* code/mcvs-main.lisp (*global-options*): add --error-bail option.
(*usage*): Describe new option.
(mcvs-execute): Dynamically bind *interactive-error-io* variable
to a stream formed by opening the controlling tty.
Send error message to *error-output* rather than *standard-output*.

* code/unix-bindings/unix.lisp (unix-funcs:ctermid): New function,
FFI interface to mcvs_ctermid.

* code/unix-bindings/wrap.c (mcvs_ctermid): New function.

* code/chatter.lisp (chatter): Chatter now goes to *error-output*
rather than *standard-output*.

* code/error.lisp (*interactive-error-io*): New special variable,
holds stream open to controlling tty.
(mcvs-terminate): New function.
(mcvs-error-handler): Use *interactive-error-io* to print menu
and obtain user input. Support the :bail value of
*mcvs-error-treatment* Plus some cosmetic changes.

* code/options.lisp (filter-mcvs-options): Support --error-bail option.

* code/filt.lisp (mcvs-filt-loop): Bugfix, (read-line t ...)
should be (read-line *standard-input* ...) because t stands
for *terminal-io* rather than *standard-io*, unlike in the
format function!

* code/rcs-utils.lisp (rcs-read-token): Read from *standard-input*
rather than *terminal-io*.
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 (push :clisp-unix-funcs *features*)
6
7 (defpackage :unix-funcs
8 (:use :common-lisp)
9 (:shadowing-import-from :ffi
10 :def-call-out :def-c-struct :c-array-max :c-pointer :c-ptr :c-string :int
11 :uint :ulong :boolean :character :c-array-ptr)
12 (:shadow
13 :open :close)
14 (:intern
15 :def-c-call-out)
16 (:export
17 :null-pointer-p :errno :strerror :eperm :enoent :esrch :eintr :eio
18 :enxio :e2big :enoexec :ebadf :echild :eagain :enomem :eacces
19 :efault :enotblk :ebusy :eexist :exdev :enodev :enotdir :eisdir
20 :einval :enfile :emfile :enotty :etxtbsy :efbig :enospc :espipe
21 :erofs :emlink :epipe :edom :erange :edeadlk :enametoolong :enolck
22 :enosys :enotempty :eloop :ewouldblock :dirent :opendir :closedir
23 :readdir :ino :name :open :close :chdir :fchdir :link :symlink
24 :readlink :unlink :rmdir :stat :stat :lstat :fstat :chmod
25 :mode :nlink :uid
26 :gid :rdev :blksize :blocks :atime :mtime :ctime :s-ifmt :s-ifdir
27 :s-ifchr :s-ifblk :s-ifreg :s-ififo :s-iflnk :s-ifsock :s-isdir
28 :s-ischr :s-isblk :s-isreg :s-isfifo :s-islnk :s-issock :s-isuid
29 :s-isgid :s-isvtx :s-iread :s-iwrite :s-iexec :s-irusr :s-iwusr
30 :s-ixusr :s-irwxu :s-irgrp :s-iwgrp :s-ixgrp :s-irwxg :s-iroth
31 :s-iwoth :s-ixoth :s-irwxo :accessperms :deffilemode :o-accmode
32 :o-rdonly :o-wronly :o-rdwr :o-creat :o-excl :o-noctty :o-trunc
33 :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd
34 :run-program default-sigchld ctermid))
35
36 (in-package :unix-funcs)
37
38 (defmacro def-c-call-out (sym &body args)
39 `(def-call-out ,sym (:language :stdc) ,@args))
40
41 ;;;
42 ;;; Null pointer test, needed in CLISP 2.27 and older.
43 ;;;
44
45 (def-c-call-out null-pointer-p
46 (:name "mcvs_null_pointer_p")
47 (:arguments (pointer c-pointer))
48 (:return-type boolean))
49
50 ;;;
51 ;;; <errno.h>
52 ;;;
53
54 (def-c-call-out get-errno
55 (:name "mcvs_get_errno")
56 (:arguments)
57 (:return-type int))
58
59 (def-c-call-out set-errno
60 (:name "mcvs_set_errno")
61 (:arguments (value int))
62 (:return-type int))
63
64 (defsetf get-errno set-errno)
65 (define-symbol-macro errno (get-errno))
66
67 (def-c-call-out strerror
68 (:arguments (errnum int))
69 (:return-type c-string :none))
70
71 (defconstant eperm 1)
72 (defconstant enoent 2)
73 (defconstant esrch 3)
74 (defconstant eintr 4)
75 (defconstant eio 5)
76 (defconstant enxio 6)
77 (defconstant e2big 7)
78 (defconstant enoexec 8)
79 (defconstant ebadf 9)
80 (defconstant echild 10)
81 (defconstant eagain 11)
82 (defconstant enomem 12)
83 (defconstant eacces 13)
84 (defconstant efault 14)
85 (defconstant enotblk 15)
86 (defconstant ebusy 16)
87 (defconstant eexist 17)
88 (defconstant exdev 18)
89 (defconstant enodev 19)
90 (defconstant enotdir 20)
91 (defconstant eisdir 21)
92 (defconstant einval 22)
93 (defconstant enfile 23)
94 (defconstant emfile 24)
95 (defconstant enotty 25)
96 (defconstant etxtbsy 26)
97 (defconstant efbig 27)
98 (defconstant enospc 28)
99 (defconstant espipe 29)
100 (defconstant erofs 30)
101 (defconstant emlink 31)
102 (defconstant epipe 32)
103 (defconstant edom 33)
104 (defconstant erange 34)
105 (defconstant edeadlk 35)
106 (defconstant enametoolong 36)
107 (defconstant enolck 37)
108 (defconstant enosys 38)
109 (defconstant enotempty 39)
110 (defconstant eloop 40)
111 (defconstant ewouldblock eagain)
112
113 ;;;
114 ;;; <dirent.h>
115 ;;;
116
117 (def-c-struct dirent
118 (ino ulong)
119 (name (c-array-max character 1024)))
120
121 (def-c-call-out opendir
122 (:arguments (name c-string))
123 (:return-type c-pointer))
124
125 (def-c-call-out closedir
126 (:arguments (dirp c-pointer))
127 (:return-type int))
128
129 (def-c-call-out readdir
130 (:name "mcvs_readdir")
131 (:arguments (dirp c-pointer))
132 (:return-type (c-ptr dirent)))
133
134 ;;;
135 ;;; <unistd.h> -- open, close
136 ;;;
137
138 (def-c-call-out open
139 (:arguments (name c-string)
140 (flags int)
141 (mode uint))
142 (:return-type int))
143
144 (def-c-call-out close
145 (:arguments (fd int))
146 (:return-type int))
147
148 ;;;
149 ;;; <unistd.h> -- chdir, fchdir
150 ;;;
151
152 (def-c-call-out chdir
153 (:arguments (path c-string))
154 (:return-type int))
155
156 (def-c-call-out fchdir
157 (:arguments (fd int))
158 (:return-type int))
159
160 ;;;
161 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
162
163
164 (def-c-call-out link
165 (:arguments (from c-string)
166 (to c-string))
167 (:return-type int))
168
169 (def-c-call-out symlink
170 (:arguments (from c-string)
171 (to c-string))
172 (:return-type int))
173
174 (def-c-call-out readlink
175 (:name "mcvs_readlink")
176 (:arguments (path c-string))
177 (:return-type c-string :malloc-free))
178
179 (def-c-call-out unlink
180 (:arguments (path c-string))
181 (:return-type int))
182
183 (def-c-call-out rmdir
184 (:arguments (path c-string))
185 (:return-type int))
186
187 ;;;
188 ;;; <unistd.h> -- stat, lstat, chmod
189 ;;;
190
191 (def-c-struct stat
192 (dev ulong)
193 (ino ulong)
194 (mode ulong)
195 (nlink uint)
196 (uid uint)
197 (gid uint)
198 (rdev ulong)
199 (blksize ulong)
200 (blocks ulong)
201 (atime ulong)
202 (mtime ulong)
203 (ctime ulong))
204
205 (def-c-call-out stat
206 (:name "mcvs_stat")
207 (:arguments (name c-string)
208 (buf (c-ptr stat) :out))
209 (:return-type int))
210
211 (def-c-call-out lstat
212 (:name "mcvs_lstat")
213 (:arguments (name c-string)
214 (buf (c-ptr stat) :out))
215 (:return-type int))
216
217 (def-c-call-out fstat
218 (:name "mcvs_fstat")
219 (:arguments (fd int)
220 (buf (c-ptr stat) :out))
221 (:return-type int))
222
223 (def-c-call-out chmod
224 (:arguments (name c-string)
225 (mode uint))
226 (:return-type int))
227
228 (defconstant s-ifmt #o170000)
229 (defconstant s-ifdir #o040000)
230 (defconstant s-ifchr #o020000)
231 (defconstant s-ifblk #o060000)
232 (defconstant s-ifreg #o100000)
233 (defconstant s-ififo #o010000)
234 (defconstant s-iflnk #o120000)
235 (defconstant s-ifsock #o140000)
236
237 (defmacro s-isdir (m) `(= (logand ,m s-ifmt) s-ifdir))
238 (defmacro s-ischr (m) `(= (logand ,m s-ifmt) s-ifchr))
239 (defmacro s-isblk (m) `(= (logand ,m s-ifmt) s-ifblk))
240 (defmacro s-isreg (m) `(= (logand ,m s-ifmt) s-ifreg))
241 (defmacro s-isfifo (m) `(= (logand ,m s-ifmt) s-iffifo))
242 (defmacro s-islnk (m) `(= (logand ,m s-ifmt) s-iflnk))
243 (defmacro s-issock (m) `(= (logand ,m s-ifmt) s-ifsock))
244
245 (defconstant s-isuid #o004000)
246 (defconstant s-isgid #o002000)
247 (defconstant s-isvtx #o001000)
248
249 (define-symbol-macro s-iread s-irusr)
250 (define-symbol-macro s-iwrite s-iwusr)
251 (define-symbol-macro s-iexec s-ixusr)
252
253 (defconstant s-irusr #o000400)
254 (defconstant s-iwusr #o000200)
255 (defconstant s-ixusr #o000100)
256 (defconstant s-irwxu (logior s-irusr s-iwusr s-ixusr))
257 (defconstant s-irgrp #o000040)
258 (defconstant s-iwgrp #o000020)
259 (defconstant s-ixgrp #o000010)
260 (defconstant s-irwxg (logior s-irgrp s-iwgrp s-ixgrp))
261 (defconstant s-iroth #o000004)
262 (defconstant s-iwoth #o000002)
263 (defconstant s-ixoth #o000001)
264 (defconstant s-irwxo (logior s-iroth s-iwoth s-ixoth))
265
266 (defconstant accessperms (logior s-irwxu s-irwxg s-irwxo))
267 (defconstant deffilemode (logior s-irusr s-iwusr s-irgrp s-iwgrp s-iroth s-iwoth))
268
269 ;;;
270 ;;; <unistd.h> -- getcwd
271 ;;;
272
273 (def-c-call-out getcwd
274 (:name "mcvs_getcwd")
275 (:arguments)
276 (:return-type c-string :malloc-free))
277
278 ;;;
279 ;;; <unistd.h> -- fork, wait*, exec*
280 ;;;
281
282 (def-c-call-out default-sigchld
283 (:name "mcvs_default_sigchld"))
284
285 (def-c-call-out spawn
286 (:name "mcvs_spawn")
287 (:arguments (name c-string)
288 (argv (c-array-ptr c-string) :in :malloc-free))
289 (:return-type int))
290
291 (defun run-program (name &key arguments)
292 (push name arguments)
293 (spawn name (coerce arguments 'vector)))
294
295 ;;;
296 ;;; Terminal related functions
297 ;;;
298
299 (def-c-call-out ctermid
300 (:name "mcvs_ctermid")
301 (:arguments)
302 (:return-type c-string :malloc-free))
303
304 ;;;
305 ;;; <fcntl.h>
306 ;;;
307
308 (defconstant o-accmode #o00003)
309 (defconstant o-rdonly #o00000)
310 (defconstant o-wronly #o00001)
311 (defconstant o-rdwr #o00002)
312 (defconstant o-creat #o00100)
313 (defconstant o-excl #o00200)
314 (defconstant o-noctty #o00400)
315 (defconstant o-trunc #o01000)
316 (defconstant o-append #o02000)
317 (defconstant o-nonblock #o04000)
318 (defconstant o-sync #o10000)
319 (defconstant o-async #o20000)
320 (defconstant o-ndelay o-nonblock)
321 (defconstant o-fsync o-sync)

  ViewVC Help
Powered by ViewVC 1.1.5