/[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.5.2.5 - (hide annotations)
Wed Apr 23 05:37:35 2003 UTC (10 years, 11 months ago) by kaz
Branch: mcvs-1-0-branch
CVS Tags: mcvs-1-0-9, mcvs-1-0-8, mcvs-1-0-7
Changes since 1.5.2.4: +10 -1 lines
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 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.5.2.1 (push :clisp-unix-funcs *features*)
6    
7 kaz 1.1 (defpackage :unix-funcs
8 kaz 1.5.2.1 (: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 kaz 1.5.2.2 :uint :ulong :boolean :character :c-array-ptr)
12 kaz 1.5.2.1 (: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 kaz 1.5.2.2 :o-append :o-nonblock :o-sync :o-async :o-ndelay :o-fsync :getcwd
34 kaz 1.5.2.5 :run-program default-sigchld ctermid))
35 kaz 1.1
36     (in-package :unix-funcs)
37    
38 kaz 1.5.2.1 (defmacro def-c-call-out (sym &body args)
39     `(def-call-out ,sym (:language :stdc) ,@args))
40 kaz 1.2
41     ;;;
42     ;;; Null pointer test, needed in CLISP 2.27 and older.
43     ;;;
44    
45     (def-c-call-out null-pointer-p
46 kaz 1.5.2.3 (:name "mcvs_null_pointer_p")
47 kaz 1.2 (:arguments (pointer c-pointer))
48     (:return-type boolean))
49 kaz 1.1
50     ;;;
51     ;;; <errno.h>
52     ;;;
53    
54     (def-c-call-out get-errno
55 kaz 1.5.2.3 (:name "mcvs_get_errno")
56 kaz 1.1 (:arguments)
57     (:return-type int))
58    
59     (def-c-call-out set-errno
60 kaz 1.5.2.3 (:name "mcvs_set_errno")
61 kaz 1.1 (: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 kaz 1.5.2.3 (:name "mcvs_readdir")
131 kaz 1.1 (: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 kaz 1.4 ;;; <unistd.h> -- link, symlink, readlink, unlink, rmdir
162 kaz 1.1
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 kaz 1.4
174     (def-c-call-out readlink
175 kaz 1.5.2.3 (:name "mcvs_readlink")
176 kaz 1.4 (:arguments (path c-string))
177     (:return-type c-string :malloc-free))
178 kaz 1.1
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 kaz 1.5 ;;; <unistd.h> -- stat, lstat, chmod
189 kaz 1.1 ;;;
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 kaz 1.5.2.3 (:name "mcvs_stat")
207 kaz 1.1 (:arguments (name c-string)
208     (buf (c-ptr stat) :out))
209     (:return-type int))
210    
211     (def-c-call-out lstat
212 kaz 1.5.2.3 (:name "mcvs_lstat")
213 kaz 1.1 (:arguments (name c-string)
214     (buf (c-ptr stat) :out))
215     (:return-type int))
216    
217     (def-c-call-out fstat
218 kaz 1.5.2.3 (:name "mcvs_fstat")
219 kaz 1.1 (:arguments (fd int)
220     (buf (c-ptr stat) :out))
221     (:return-type int))
222    
223 kaz 1.5 (def-c-call-out chmod
224     (:arguments (name c-string)
225     (mode uint))
226     (:return-type int))
227    
228 kaz 1.1 (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 kaz 1.3
269     ;;;
270     ;;; <unistd.h> -- getcwd
271 kaz 1.5.2.2 ;;;
272 kaz 1.3
273     (def-c-call-out getcwd
274 kaz 1.5.2.3 (:name "mcvs_getcwd")
275 kaz 1.3 (:arguments)
276     (:return-type c-string :malloc-free))
277 kaz 1.5.2.2
278     ;;;
279     ;;; <unistd.h> -- fork, wait*, exec*
280     ;;;
281 kaz 1.5.2.4
282     (def-c-call-out default-sigchld
283     (:name "mcvs_default_sigchld"))
284 kaz 1.5.2.2
285     (def-c-call-out spawn
286 kaz 1.5.2.3 (:name "mcvs_spawn")
287 kaz 1.5.2.2 (: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 kaz 1.5.2.5
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 kaz 1.1
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