Initial commit of fastrandom library
[mmondor.git] / mmsoftware / cl / test / ecl-unix.lisp
1 ;;;; $Id: ecl-unix.lisp,v 1.9 2011/01/21 00:00:16 mmondor Exp $
2 ;;
3 ;; Copyright (c) 2010, Matthew Mondor.
4 ;; All rights reserved.
5 ;;
6 ;; Redistribution and use in source and binary forms, with or without
7 ;; modification, are permitted provided that the following conditions
8 ;; are met:
9 ;; 1. Redistributions of source code must retain the above copyright
10 ;; notice, this list of conditions and the following disclaimer.
11 ;; 2. Redistributions in binary form must reproduce the above copyright
12 ;; notice, this list of conditions and the following disclaimer in the
13 ;; documentation and/or other materials provided with the distribution.
14 ;;
15 ;; THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
16 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
17 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
18 ;; IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
19 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
20 ;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
21 ;; USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
24 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25 ;;
26 ;;;;
27 ;;;; Unix syscalls frontend for ECL
28 ;;;;
29 ;;;; Parts of this code are highly imperative and redundant, but I find
30 ;;;; this acceptable in the case of such FFI stubs.
31 ;;;; This code is also both NetBSD/i386 and ECL-specific, although it
32 ;;;; should easily be able to work on other unices with minor modifications.
33 ;;;;
34 ;;;; XXX TODO XXX
35 ;;;; There are several things to consider or think about:
36 ;;;; - Now that WITH-C-CONSTANTS is implemented, consider which code should
37 ;;;; now use it.
38 ;;;; - Separate into files and use ASDF, decide which symbols to export.
39 ;;;; - Perhaps prefix the functions by fd for a theoretic fd class, etc?
40 ;;;; or prefix all UNIX package symbols by UNIX?
41 ;;;; - getitimer/setitimer(2)
42 ;;;; maybe timer_create(3) and friends?
43 ;;;; Or actually, since I now have kqueue(2), they're no longer needed.
44 ;;;; But non-BSD operating systems don't have kqueue(2).
45 ;;;; However, using it and checking for timer events in the main thread
46 ;;;; is better than having to install signal handlers...
47 ;;;; libevent(3) does support timers, however.
48 ;;;; - crypt(3) (unfortunately not thread safe, and may run a while!)
49 ;;;; Implementing a custom reentrant equivalent might be worth it...
50 ;;;; - select/poll/libevent, C recvq/sendq?
51 ;;;; - eventually add ioctl(2) support on the kqueue(2) descriptor
52 ;;;; - aio?
53 ;;;; - signal handling functions, wait, waitsig, sigprocmask, sigaction, etc.
54 ;;;; - termios
55 ;;;; - We should try to implement mmap(2) and company, along with madvise(2)
56 ;;;; - Should we also support readv(2)/writev(2)?
57 ;;;; - Be alert as to which syscalls might likely be used in tight loops
58 ;;;; where performance matters enough to provide a NO-SIGNAL option.
59 ;;;; - Consider weither we should be as lisp-friendly as to provide setf/getf
60 ;;;; around many suitable syscalls i.e. getsockopt/setsockopt, getuid/setuid
61 ;;;; etc.
62 ;;;; - Consider using keyword options where appropriate instead of having
63 ;;;; to logior flags? And could compiler-macros perform the conversion
64 ;;;; to not affect runtime performance?
65 ;;;; - See what to do about finalizers, if we want any. It appears that
66 ;;;; even foreign object pointer objects may be GCed, in which case it
67 ;;;; would be best to also free automatically the associated memory by
68 ;;;; using a custom finalizer, which may be defined using
69 ;;;; (ext:set-finalizer obj #'finalize-foreign-object) and such.
70 ;;;; So we could do this for allocated memory, and even FILE handles,
71 ;;;; but how about file descriptors, which are only tracked by integer?
72 ;;;; Perhaps that providing WITH-* macros would be enough...
73 ;;;; - It might be nice to be able to enable automatic syslog messages to
74 ;;;; be issued by UNIX-ERROR and GAI-ERROR condition objects, perhaps...
75 ;;;;
76 ;;;; Outside the scope of unix only:
77 ;;;; - Eventually, stdio FILE
78 ;;;; - Eventually, PostgreSQL
79 ;;;; - Eventually, GD and/or Cairo+Pango and/or epeg+imlib2
80 ;;;; - Perhaps even curses
81 ;;;; - SDL, SDL_gfx
82
83 (declaim (optimize (speed 3) (safety 1) (debug 1)))
84
85 (defpackage :unix
86 (:use :cl))
87
88 (in-package :unix)
89
90
91
92 ;;; FFI helpers
93
94 ;;; Must be available at compile time.
95 ;;; Holds the DEFINE-C-CONSTANTS definitions for WITH-C-CONSTANTS.
96 (eval-when (:execute :load-toplevel :compile-toplevel)
97 (defvar *c-headers* (make-hash-table :test 'eq)))
98
99 ;;; XXX Using FIXNUM here might prove problematic for some rare constants,
100 ;;; we should use a type of grovelling.
101 (defmacro define-c-constants (header-name c-header-name &rest constants)
102 "Permits to export C constants to CL for later use with WITH-C-CONSTANTS.
103 HEADER-NAME should be a keyword symbol for later reference, C-HEADER-NAME
104 a string of the C header file name and CONSTANTS pairs of the format
105 SYMBOL \"C-SYMBOL\" where SYMBOL is the CL symbol to associate to C-SYMBOL."
106 (check-type header-name keyword)
107 `(progn
108 (eval-when (:execute :load-toplevel :compile-toplevel)
109 (setf (gethash ',header-name *c-headers*)
110 '(,header-name ,c-header-name ,@constants)))
111 (let ()
112 (ffi:clines ,(format nil "#include <~A>" c-header-name))
113 ,@(mapcar #'(lambda (c)
114 (let ((s (intern (format nil "*~A*" (first c)))))
115 `(progn
116 (defconstant ,s
117 (ffi:c-inline () () :fixnum ,(second c)
118 :one-liner t
119 :side-effects nil))
120 (declaim (type fixnum ,s))
121 (export ',s))))
122 constants))))
123
124 ;;; XXX Using :fixnum instead of :int at ffi:c-inline enhances performance
125 ;;; by not needing an ecl_make_integer() function call. However, this could
126 ;;; be problematic for some values. I should find a way to evaluate the
127 ;;; size of the C litteral to then use :fixnum, :int or :long/:integer
128 ;;; as required, as well as match the declarations with it.
129 ;;; Using :fixnum all the way here may cause problems with some values.
130 ;;; The other disadvantage of using this method is that user code needing
131 ;;; to use these C constants also needs to be compiled. Perhaps that we
132 ;;; should offer both choices: global constant symbols and optional more
133 ;;; efficient local symbols using WITH-C-CONSTANTS?
134 (defmacro with-c-constants (headers &body body)
135 "Allows to import C constants as CL symbols. HEADERS should be a list
136 of keyword symbols corresponding to C headers previously exported using
137 DEFINE-C-CONSTANTS. The header files will be included in the specified
138 order and the exported C symbols will be imported in the current lexical
139 context."
140 (let* ((header-entries (mapcar #'(lambda (s)
141 (check-type s keyword)
142 (gethash s *c-headers*))
143 headers))
144 (all-constants (apply
145 #'append
146 (mapcar #'(lambda (h)
147 (destructuring-bind
148 (h-name c-h-name &rest constants) h
149 (declare (ignore h-name c-h-name))
150 constants))
151 header-entries))))
152 `(progn
153 (ffi:clines ,(with-output-to-string (s)
154 (terpri s)
155 (mapcar #'(lambda (h)
156 (destructuring-bind
157 (h-name c-h-name &rest constants) h
158 (declare (ignore h-name constants))
159 (format s "#include <~A>~%" c-h-name)))
160 header-entries)))
161 (symbol-macrolet
162 ,(mapcar #'(lambda (c)
163 (destructuring-bind (symbol constant) c
164 `(,symbol
165 (ffi:c-inline () () :fixnum ,constant
166 :one-liner t
167 :side-effects nil))))
168 all-constants)
169 (declare (type fixnum ,@(mapcar #'first all-constants)))
170 ,@body))))
171
172 ;;; Serves to easily map system-specific types to native ones at a central
173 ;;; location.
174 ;;; Must already be available in the environmnet prior to compilation,
175 ;;; or in C-INLINE2 macro definition an error obviously occurs.
176 (eval-when (:execute :load-toplevel :compile-toplevel)
177 (defun native-type<-system-type (type)
178 (case type
179 (:off-t :int64-t)
180 (:size-t :unsigned-int)
181 (:ssize-t :int)
182 (:mode-t :uint16-t)
183 (:pid-t :int32-t)
184 ((:uid-t :gid-t) :uint32-t)
185 (:dev-t :int32-t)
186 (:ino-t :uint32-t)
187 (:nlink-t :uint16-t)
188 (:time-t :int64-t)
189 (:blkcnt-t :int64-t)
190 (:blksize-t :uint32-t)
191 (:rlim-t :int64-t)
192 (:id-t :uint32-t)
193 (:intptr-t :int) ; i386
194 (:uintptr-t :unsigned-int) ; i386
195 (otherwise type)))
196
197 (defun c-type<-native-type (type)
198 ;;; XXX Fill missing types
199 (case type
200 (:int "int")
201 (:unsigned-int "unsigned int")
202 (:long "long")
203 (:unsigned-long "unsigned long")
204 (:int8-t "int8_t")
205 (:uint8-t "uint8_t")
206 (:int16-t "int16_t")
207 (:uint16-t "uint16_t")
208 (:int32-t "int32_t")
209 (:uint32-t "uint32_t")
210 (:int64-t "int64_t")
211 (:uint64-t "uint64_t")
212 (:cstring "char *")))
213
214 (defun c-type<-system-type (type)
215 (c-type<-native-type (native-type<-system-type type)))
216
217 ;;; To use when defining CL structures to help optimize better
218 (defun cl-type<-c-type (type)
219 ;;; XXX Fill missing types
220 (case type
221 (:short 'fixnum)
222 (:unsigned-short 'fixnum)
223 (:int 'integer)
224 (:unsigned-int 'integer)
225 (:long 'integer)
226 (:unsigned-long 'integer)
227 (:int8-t 'fixnum)
228 (:uint8-t 'fixnum)
229 (:int16-t 'fixnum)
230 (:uint16-t 'fixnum)
231 (:int32-t 'integer)
232 (:uint32-t 'integer)
233 (:int64-t 'integer)
234 (:uint64-t 'integer)
235 (otherwise nil)))
236
237 (defun cl-type<-system-type (type)
238 (cl-type<-c-type (native-type<-system-type type))))
239
240
241 (defmacro c-inline2 (vars vars-types return-types &rest body)
242 "Like FFI:C-INLINE but maps system-specific types to native ones using
243 the NATIVE-TYPE<-SYSTEM-TYPE function."
244 `(ffi:c-inline ,vars
245 ,(mapcar #'native-type<-system-type vars-types)
246 ,(if (listp return-types)
247 (mapcar #'native-type<-system-type return-types)
248 (native-type<-system-type return-types))
249 ,@body))
250
251 (defmacro c-inline-format (vars vars-types return-types fmt &rest body)
252 "Wrapper around C-INLINE2 which allows FORMAT-style string generation
253 for the C body. Note that the arguments corresponding to the FMT functions
254 should be enclosed with #. for now."
255 `(c-inline2 ,vars ,vars-types ,return-types
256 ,(apply #'format nil fmt body)
257 :one-liner nil))
258
259 ;;; Must be available at compile time. Holds the structure definitions
260 ;;; created via DEFINE-C-STRUCTURE to prevent redundance when performing
261 ;;; various operations on a structure.
262 (eval-when (:execute :load-toplevel :compile-toplevel)
263 (defvar *c-structures* (make-hash-table :test 'eq)))
264
265 (defmacro define-c-structure (struct-name c-struct-name &rest fields)
266 "Permits to define a C structure for use from CL.
267 STRUCT-NAME is the CL structure name (i.e. SDL-RECT),
268 C-STRUCT-NAME the C structure name (i.e. \"struct SDL_Rect\"),
269 and every field must be a list holding three elements:
270 FIELD-NAME is the CL field name (i.e. X).
271 FFI-TYPE is the CL-side C-FFI type (i,e, :int16-t).
272 C-FIELD-NAME is the C-side field name (i.e. \"x\")."
273 ;; Must be available at compile time
274 (check-type struct-name symbol)
275 (check-type c-struct-name string)
276 `(eval-when (:execute :load-toplevel :compile-toplevel)
277 (setf (gethash ',struct-name *c-structures*)
278 '(,struct-name ,c-struct-name ,@fields))))
279
280 (defmacro define-c-cl-structure (struct)
281 "Generates a CL DEFSTRUCT form from a C structure previously defined
282 using DEFINE-C-STRUCTURE."
283 (check-type struct symbol)
284 (destructuring-bind
285 (struct-name c-struct-name &rest fields)
286 (gethash struct *c-structures*)
287 (declare (ignore c-struct-name))
288 `(defstruct ,struct-name
289 ,@(mapcar
290 #'(lambda (field)
291 (destructuring-bind
292 (field-name ffi-type c-field-name) field
293 (declare (ignore c-field-name))
294 (let ((cl-type (cl-type<-system-type ffi-type)))
295 (if cl-type
296 `(,field-name 0 :type ,cl-type)
297 `,field-name))))
298 fields))))
299
300 (defmacro define-global-setf-expander (accessor)
301 (let ((getter-macro (intern
302 (format nil "~A-SETF-GETTER-MACRO" accessor)))
303 (setter-macro (intern
304 (format nil "~A-SETF-SETTER-MACRO" accessor))))
305 `(progn
306 (defmacro ,setter-macro (val obj)
307 `(funcall #'(setf ,',accessor) ,val ,obj))
308 (defmacro ,getter-macro (obj)
309 `(,',accessor ,obj))
310 (define-setf-expander ,accessor (obj)
311 (let ((temp (gensym))
312 (store (gensym)))
313 (values (list temp)
314 (list obj)
315 (list store)
316 (list ',setter-macro store temp)
317 (list ',getter-macro temp)))))))
318
319 ;;; XXX Instead of declaring value types to be INTEGER, declare them to
320 ;;; be the smallest possible CL type which can hold the value as per the
321 ;;; C type.
322 (defmacro define-c-structure-accessors (struct)
323 "Generates a set of GETF/SETF accessor functions for a previously defined
324 C structure using DEFINE-C-STRUCTURE. Note that to use these, it is expected
325 that a CL DEFSTRUCT form is also created by the user code, holding at least
326 one field: POINTER, which should hold the foreign :POINTER-VOID data pointer.
327 We do not create this structure automatically because user code might want
328 to also provide additional custom fields (notably for pointers to other
329 objects)."
330 (check-type struct symbol)
331 (destructuring-bind
332 (struct-name c-struct-name &rest fields)
333 (gethash struct *c-structures*)
334 `(progn
335 ,@(mapcar
336 #'(lambda (field)
337 (destructuring-bind
338 (field-name ffi-type c-field-name) field
339 (let ((accessor (intern (format nil "~A-~A"
340 (symbol-name struct-name)
341 (symbol-name field-name))))
342 (pointer (intern (format nil "~A-POINTER"
343 (symbol-name struct-name)))))
344 `(progn
345 (declaim
346 (optimize (speed 3) (safety 0) (debug 0))
347 (inline ,accessor)
348 (ftype (function (,struct-name) integer) ,accessor))
349 (defun ,accessor (object)
350 (declare (type ,struct-name object))
351 (c-inline2 ((,pointer object))
352 (:pointer-void)
353 ,ffi-type
354 ,(format nil "(((~A *)#0)->~A)"
355 c-struct-name c-field-name)
356 :one-liner t :side-effects nil))
357 (declaim
358 (optimize (speed 3) (safety 0) (debug 0))
359 (inline (setf ,accessor))
360 (ftype (function (integer ,struct-name) integer)
361 (setf ,accessor)))
362 (defun (setf ,accessor) (value object)
363 (declare (type integer value)
364 (type ,struct-name object))
365 (c-inline2 (value (,pointer object))
366 (,ffi-type :pointer-void)
367 ,ffi-type
368 ,(format nil "(((~A *)#1)->~A = #0)"
369 c-struct-name c-field-name)
370 :one-liner t :side-effects t))
371 (define-global-setf-expander ,accessor)))))
372 fields))))
373
374 ;;; XXX Add corresponding #include to allow C-c C-c
375 (defmacro with-c-structure-accessors (struct &body body)
376 "Provide access to inline C structure accessors for compiled code.
377 This is done by overriding a struct-slot specific global macros previously
378 defined by DEFINE-C-STRUCTURE-ACCESSORS via MACROLET, which are used
379 along with a custom SETF-expander. Cannot be used in interpreted code."
380 (check-type struct symbol)
381 (destructuring-bind
382 (struct-name c-struct-name &rest fields)
383 (gethash struct *c-structures*)
384 `(macrolet
385 (,@(mapcan
386 #'(lambda (field)
387 (destructuring-bind
388 (field-name ffi-type c-field-name) field
389 (let* ((accessor (intern
390 (format nil "~A-~A"
391 (symbol-name struct-name)
392 (symbol-name field-name))))
393 (getter-macro (intern
394 (format nil "~A-SETF-GETTER-MACRO"
395 accessor)))
396 (setter-macro (intern
397 (format nil "~A-SETF-SETTER-MACRO"
398 accessor))))
399 `((,setter-macro (val obj)
400 `(c-inline2 (,val ,obj)
401 (,',ffi-type :object)
402 ,',ffi-type
403 ,(format nil
404 "(((~A *)ecl_to_pointer(SLOT(#1, 0)))->~A = #0)"
405 ,c-struct-name ,c-field-name)
406 :one-liner t :side-effects t))
407 (,getter-macro (obj)
408 `(c-inline2 (,obj)
409 (:object)
410 ,',ffi-type
411 ,(format nil
412 "(((~A *)ecl_to_pointer(SLOT(#0, 0)))->~A)"
413 ,c-struct-name ,c-field-name)
414 :one-liner t :side-effects nil))
415 (,accessor (obj)
416 `(c-inline2 (,obj)
417 (:object)
418 ,',ffi-type
419 ,(format nil
420 "(((~A *)ecl_to_pointer(SLOT(#0, 0)))->~A)"
421 ,c-struct-name ,c-field-name)
422 :one-liner t :side-effects nil))))))
423 fields))
424 ,@body)))
425
426
427 (eval-when (:execute :load-toplevel :compile-toplevel)
428 (defun c-function<-c-type (type field)
429 ;; XXX Fill missing types
430 (format nil
431 (case type
432 (:int8-t "ecl_make_int8_t(~A)")
433 (:uint8-t "ecl_make_uint8_t(~A)")
434 (:int16-t "ecl_make_int16_t(~A)")
435 (:uint16-t "ecl_make_uint16_t(~A)")
436 (:int32-t "ecl_make_int32_t(~A)")
437 (:uint32-t "ecl_make_uint32_t(~A)")
438 (:int64-t "ecl_make_int64_t(~A)")
439 (:uint64-t "ecl_make_uint64_t(~A)")
440 (:int "ecl_make_int(~A)")
441 (:unsigned-int "ecl_make_unsigned_integer(~A)")
442 (:long "ecl_make_long(~A)")
443 (:cstring "ecl_cstring_to_base_string_or_nil(~A)")
444 (:timeval "fill_timeval_structure(&~A)")
445 (:timeval* "fill_timeval_structure(~A)")
446 (otherwise
447 (error "c-function<-c-type: unknown native type ~A"
448 type)))
449 field)))
450
451
452 (ffi:clines "
453 static char *
454 ecl_to_cstring(cl_object str)
455 {
456
457 return ecl_base_string_pointer_safe(
458 si_copy_to_simple_base_string(str));
459 }
460 ")
461
462 ;;; Serves to easily map native C-FFI types to the C function to access them.
463 ;;; Used for cases such as SETGROUPS and DEFINE-C-STRUCTURE-SERIALIZER.
464 (eval-when (:execute :load-toplevel :compile-toplevel)
465 (defun to-c-function<-native-type (type)
466 ;; XXX Fill missing native types
467 (case type
468 (:int8-t "ecl_to_int8_t")
469 (:uint8-t "ecl_to_uint8_t")
470 (:int16-t "ecl_to_int16_t")
471 (:uint16-t "ecl_to_uint16_t")
472 (:int32-t "ecl_to_int32_t")
473 (:uint32-t "ecl_to_uint32_t")
474 (:int64-t "ecl_to_int64_t")
475 (:uint64-t "ecl_to_uint64_t")
476 (:int "ecl_to_int")
477 (:unsigned-int "ecl_to_unsigned_integer")
478 (:long "ecl_to_long")
479 (:cstring "ecl_to_cstring")
480 (otherwise
481 (error "to-c-function<-native-type: unknown native type ~A"
482 type))))
483
484 (defun c-function<-system-type (type field)
485 (c-function<-c-type (native-type<-system-type type) field))
486 (defun to-c-function<-system-type (type)
487 (to-c-function<-native-type (native-type<-system-type type))))
488
489 (defmacro define-c-structure-serializer (struct)
490 "Generates the inline fill_<struct>_structure() and
491 fill_<struct>_c_structure() C functions to efficiently
492 serialize a foreign C structure to a user CL one, or vice-versa.
493 STRUCT must have previously been defined using DEFINE-C-STRUCTURE."
494 (check-type struct symbol)
495 (destructuring-bind
496 (struct-name c-struct-name &rest fields)
497 (gethash struct *c-structures*)
498 `(ffi:clines
499 ,(format nil "
500 static cl_object
501 fill_~A_structure(~A *cs)
502 {
503 cl_object s = funcall(1, @make-~A);
504
505 ~A
506 return s;
507 }
508 "
509 (string-downcase struct-name)
510 c-struct-name
511 (string-downcase struct-name)
512 (with-output-to-string (s)
513 (loop
514 for i from 0
515 for field in fields
516 do
517 (destructuring-bind (field-name ffi-type c-field-name)
518 field
519 (declare (ignore field-name))
520 (format s
521 " SLOT(s, ~A) = ~A;~%"
522 i
523 (c-function<-system-type
524 ffi-type
525 (format nil
526 "cs->~A"
527 c-field-name))))))))))
528
529 (defmacro define-to-c-structure-serializer (struct)
530 (check-type struct symbol)
531 (destructuring-bind
532 (struct-name c-struct-name &rest fields)
533 (gethash struct *c-structures*)
534 `(ffi:clines
535 ,(format nil "
536 static void
537 fill_~A_c_structure(~A *cs, cl_object s)
538 {
539
540 ~A}
541 "
542 (string-downcase struct-name) c-struct-name
543 (with-output-to-string (s)
544 (loop
545 for i from 0
546 for field in fields
547 do
548 (destructuring-bind (field-name
549 ffi-type
550 c-field-name) field
551 (declare (ignore field-name))
552 (format s
553 " cs->~A = ~A((SLOT(s, ~A)));~%"
554 c-field-name
555 (to-c-function<-system-type ffi-type)
556 i))))))))
557
558 (defmacro check-type* (&rest tests)
559 (check-type tests list)
560 `(progn
561 ,@(mapcar #'(lambda (e)
562 (destructuring-bind (var test) e
563 `(check-type ,var ,test)))
564 tests)))
565
566 ;;; Macro for frequentl use case of invoking a syscall which reutrns -1
567 ;;; on error, and for which we want to return T on success or signal a
568 ;;; condition of type UNIX-ERROR on error.
569 ;;; For syscalls for which we want to optionally return NIL with ERRNO
570 ;;; as two values instead of signaling an error, :NO-SIGNAL may be added
571 ;;; for the optional NSIGNAL argument.
572 (defmacro defsyscall0 ((fsymbol cfunction &optional nsignal)
573 (&rest cargtypes) documentation)
574 (check-type* (fsymbol symbol)
575 (cfunction string)
576 (nsignal (or null keyword))
577 (cargtypes list)
578 (documentation string))
579 (let* ((nargs (length cargtypes))
580 (args (loop
581 repeat nargs
582 collect (gensym "ARG")))
583 (cargs (if (> nargs 0)
584 (let ((s (with-output-to-string (s)
585 (loop
586 for i from 0 below nargs
587 do (format s "#~D, " i)))))
588 (subseq s 0 (- (length s) 2)))
589 "")))
590 `(defun ,fsymbol ,(if nsignal
591 `(,@args &optional no-signal)
592 `,args)
593 ,(concatenate 'string
594 documentation "
595 Returns T on success or signals a condition of type UNIX-ERROR."
596 (if nsignal
597 "
598 Unless NO-SIGNAL, where two values are returned: NIL and ERRNO."
599 nil))
600 (ffi:clines "#include <errno.h>")
601 (let ((err (c-inline2 ,(copy-list args) ; XXX FFI:C-INLINE destroys list
602 ,cargtypes
603 :int
604 ,(format nil "
605 {
606 int err = 0;
607
608 if (~A(~A) == -1)
609 err = errno;
610
611 @(return) = err;
612 }"
613 cfunction
614 cargs)
615 :one-liner nil)))
616 ,(if nsignal
617 `(if (= 0 err)
618 t
619 (if no-signal
620 (values nil err)
621 (unix-error ,cfunction err (list ,@args))))
622 `(if (= 0 err)
623 t
624 (unix-error ,cfunction err (list ,@args))))))))
625
626 ;;; Macro for frequent use case where a syscall returns -1 or NULL on error
627 ;;; or a useful value which we want to return on success, or signal a
628 ;;; condition of type UNIX-ERROR.
629 ;;; For syscalls for which we want to optionally return NIL/-1 with ERRNO
630 ;;; as two values instead of signaling an error, :NO-SIGNAL may be added
631 ;;; for the optional NSIGNAL argument.
632 (defmacro defsyscall1 ((rtype fsymbol cfunction &optional nsignal)
633 (&rest cargtypes) documentation)
634 (check-type* (rtype keyword)
635 (fsymbol symbol)
636 (cfunction string)
637 (nsignal (or null keyword))
638 (cargtypes list)
639 (documentation string))
640 (let* ((nargs (length cargtypes))
641 (args (loop
642 repeat nargs
643 collect (gensym "ARG")))
644 (cargs (if (> nargs 0)
645 (let ((s (with-output-to-string (s)
646 (loop
647 for i from 0 below nargs
648 do (format s "#~D, " i)))))
649 (subseq s 0 (- (length s) 2)))
650 ""))
651 (ccmpagainst (if (eq rtype :cstring) "NULL" "-1"))
652 (cmpagainst (if (eq rtype :cstring) 'NIL '-1))
653 (cmpop (if (eq rtype :cstring) 'eql '=))
654 (errret (if (eq rtype :cstring) nil -1)))
655 `(defun ,fsymbol ,(if nsignal
656 `(,@args &optional no-signal)
657 `,args)
658 ,(concatenate 'string
659 documentation
660 "
661 On error, signals a condition of type UNIX-ERROR."
662 (if nsignal
663 (format nil "
664 Unless NO-SIGNAL, where two values are returned on error: ~A and ERRNO."
665 errret)
666 nil))
667 (ffi:clines "#include <errno.h>")
668 (multiple-value-bind (ret err)
669 (c-inline2 ,(copy-list args) ; XXX FFI:C-INLINE destroys list
670 ,cargtypes
671 (values ,rtype :int)
672 ,(format nil "
673 {
674 ~A ret;
675 int err = 0;
676
677 if ((ret = ~A(~A)) == ~A)
678 err = errno;
679
680 @(return 0) = ret;
681 @(return 1) = err;
682 }"
683 (c-type<-system-type rtype)
684 cfunction
685 cargs
686 ccmpagainst)
687 :one-liner nil)
688 ,(if nsignal
689 `(if (,cmpop ,cmpagainst ret)
690 (if no-signal
691 (values ,errret err)
692 (unix-error ,cfunction err (list ,@args)))
693 ret)
694 `(if (,cmpop ,cmpagainst ret)
695 (unix-error ,cfunction err (list ,@args))
696 ret))))))
697
698
699 (define-c-constants :errno "errno.h"
700 (eperm "EPERM")
701 (enoent "ENOENT")
702 (esrch "ESRCH")
703 (eintr "EINTR")
704 (eio "EIO")
705 (enxio "ENXIO")
706 (ebadf "EBADF")
707 (eacces "EACCES")
708 (enotblk "ENOTBLK")
709 (ebusy "EBUSY")
710 (eexist "EEXIST")
711 (exdev "EXDEV")
712 (enodev "ENODEV")
713 (enotdir "ENOTDIR")
714 (eisdir "EISDIR")
715 (einval "EINVAL")
716 (enfile "ENFILE")
717 (emfile "EMFILE")
718 (enotty "ENOTTY")
719 (etxtbsy "ETXTBSY")
720 (efbig "EFBIG")
721 (enospc "ENOSPC")
722 (espipe "ESPIPE")
723 (erofs "EROFS")
724 (emlink "EMLINK")
725 (epipe "EPIPE")
726 (eagain "EAGAIN")
727 (einprogress "EINPROGRESS")
728 (ealready "EALREADY")
729 (enotsock "ENOTSOCK")
730 (edestaddrreq "EDESTADDRREQ")
731 (emsgsize "EMSGSIZE")
732 (eprototype "EPROTOTYPE")
733 (eprotonosupport "EPROTONOSUPPORT")
734 (eopnotsupp "EOPNOTSUPP")
735 (epfnosupport "EPFNOSUPPORT")
736 (eafnosupport "EAFNOSUPPORT")
737 (esocktnosupport "ESOCKTNOSUPPORT")
738 (eaddrinuse "EADDRINUSE")
739 (eaddrnotavail "EADDRNOTAVAIL")
740 (enetdown "ENETDOWN")
741 (enetunreach "ENETUNREACH")
742 (enetreset "ENETRESET")
743 (econnaborted "ECONNABORTED")
744 (econnreset "ECONNRESET")
745 (enobufs "ENOBUFS")
746 (eisconn "EISCONN")
747 (enotconn "ENOTCONN")
748 (eshutdown "ESHUTDOWN")
749 (etimedout "ETIMEDOUT")
750 (econnrefused "ECONNREFUSED")
751 (eloop "ELOOP")
752 (enametoolong "ENAMETOOLONG")
753 (ehostdown "EHOSTDOWN")
754 (ehostunreach "EHOSTUNREACH")
755 (enotempty "ENOTEMPTY")
756 (edquot "EDQUOT")
757 (estale "ESTALE")
758 (enolck "ENOLCK")
759 (enosys "ENOSYS")
760 (eftype "EFTYPE")
761 (enomsg "ENOMSG")
762 (enotsup "ENOTSUP")
763 (ecanceled "ECANCELED")
764 (ebadmsg "EBADMSG")
765 (enodata "ENODATA")
766 (etime "ETIME"))
767
768 (defun errno ()
769 (ffi:c-inline () () :int "errno" :one-liner t))
770
771 (defun strerror (errno)
772 (ffi:c-inline (errno)
773 (:int)
774 :cstring
775 "
776 {
777 char errbuf[256];
778
779 (void)strerror_r(#0, errbuf, 255);
780 @(return) = errbuf;
781 }" :one-liner nil))
782
783 (define-condition unix-error
784 ()
785 ((function :initarg :function
786 :initform nil
787 :type (or null string)
788 :reader unix-error-function)
789 (errno :initarg :errno
790 :initform nil
791 :type (or null fixnum)
792 :reader unix-error-errno)
793 (objects :initarg :objects
794 :initform '()
795 :type list
796 :reader unix-error-objects))
797 (:report (lambda (condition stream)
798 (format stream "Unix error: ~A() - [~A]: \"~A\"~%On: ~S~%"
799 (unix-error-function condition)
800 (unix-error-errno condition)
801 (strerror (unix-error-errno condition))
802 (unix-error-objects condition)))))
803
804 (defun unix-error (function errno &optional (objects '()))
805 (error (make-condition 'unix-error
806 :function function
807 :errno errno
808 :objects objects)))
809
810 (defun gai-strerror (errno)
811 (ffi:c-inline (errno)
812 (:int)
813 :cstring
814 "gai_strerror(#0)" :one-liner t))
815
816 (define-condition gai-error
817 (unix-error)
818 ()
819 (:report (lambda (condition stream)
820 (format stream "Resolve error: ~A() - [~A]: \"~A\"~%On: ~S~%"
821 (unix-error-function condition)
822 (unix-error-errno condition)
823 (gai-strerror (unix-error-errno condition))
824 (unix-error-objects condition)))))
825
826 (defun gai-error (function errno &optional (objects '()))
827 (error (make-condition 'gai-error
828 :function function
829 :errno errno
830 :objects objects)))
831
832
833 (ffi:clines "
834 #include <fcntl.h>
835 #include <grp.h>
836 #include <limits.h>
837 #include <pwd.h>
838 #include <stdlib.h>
839 #include <unistd.h>
840 #include <sys/param.h>
841 #include <sys/stat.h>")
842
843 (define-c-constants :sys-stat "sys/stat.h"
844 (s-ifmt "S_IFMT")
845 (s-ififo "S_IFIFO")
846 (s-ifchr "S_IFCHR")
847 (s-ifdir "S_IFDIR")
848 (s-ifblk "S_IFBLK")
849 (s-ifreg "S_IFREG")
850 (s-iflnk "S_IFLNK")
851 (s-ifsock "S_IFSOCK")
852 (s-ifwht "S_IFWHT")
853 (s-isuid "S_ISUID")
854 (s-isgid "S_ISGID")
855 (s-isvtx "S_ISVTX")
856 (s-irisr "S_IRUSR")
857 (s-iwusr "S_IWUSR")
858 (s-ixusr "S_IXUSR")
859 (s-irgrp "S_IRGRP")
860 (s-iwgrp "S_IWGRP")
861 (s-ixgrp "S_IXGRP")
862 (s-iroth "S_IROTH")
863 (s-iwoth "S_IWOTH")
864 (s-ixoth "S_IXOTH")
865 (uf-nodump "UF_NODUMP")
866 (uf-immutable "UF_IMMUTABLE")
867 (uf-append "UF_APPEND")
868 (uf-opaque "UF_OPAQUE")
869 (sf-archived "SF_ARCHIVED")
870 (sf-immutable "SF_IMMUTABLE")
871 (sf-append "SF_APPEND"))
872
873 (define-c-constants :limits "limits.h"
874 (posix-ngroups-max "_POSIX_NGROUPS_MAX"))
875
876 (define-c-constants :unistd "unistd.h"
877 (fdatasync "FDATASYNC")
878 (ffilesync "FFILESYNC")
879 (seek-set "SEEK_SET")
880 (seek-cur "SEEK_CUR")
881 (seek-end "SEEK_END"))
882
883
884 (define-c-structure stat "struct stat"
885 (dev :dev-t "st_dev")
886 (ino :ino-t "st_ino")
887 (mode :mode-t "st_mode")
888 (nlink :nlink-t "st_nlink")
889 (uid :uid-t "st_uid")
890 (gid :gid-t "st_gid")
891 (rdev :dev-t "st_rdev")
892 (atime :time-t "st_atime")
893 (atimensec :long "st_atimensec")
894 (mtime :time-t "st_mtime")
895 (mtimensec :long "st_mtimensec")
896 (ctime :time-t "st_ctime")
897 (ctimensec :long "st_ctimensec")
898 (size :off-t "st_size")
899 (blocks :blkcnt-t "st_blocks")
900 (blksize :blksize-t "st_blksize")
901 (flags :uint32-t "st_flags")
902 (gen :uint32-t "st_gen")
903 (birthtime :time-t "st_birthtime")
904 (birthtimensec :long "st_birthtimensec"))
905 (define-c-cl-structure stat)
906 (define-c-structure-serializer stat)
907
908 (defun fstat (fd &optional no-signal)
909 "Invokes the fstat(2) syscall on FD.
910 Returns a STAT structure on success.
911 On error a UNIX-ERROR condition is signaled, unless NO-SIGNAL, in which
912 case two values are returned: NIL and and errno integer."
913 (multiple-value-bind (stat err)
914 (c-inline2 (fd)
915 (:int)
916 (values :object :int)
917 "
918 {
919 struct stat st;
920 cl_object cl_st = Cnil;
921 int err = 0;
922
923 if (fstat(#0, &st) == 0)
924 cl_st = fill_stat_structure(&st);
925 else
926 err = errno;
927
928 @(return 0) = cl_st;
929 @(return 1) = err;
930 }" :one-liner nil)
931 (if stat
932 stat
933 (if no-signal
934 (values nil err)
935 (unix-error "fstat" err `(,fd))))))
936
937 (defun stat (path &optional no-signal)
938 "Invokes the stat(2) syscall on PATH.
939 Returns a STAT structure on success.
940 On error, a UNIX-ERROR condition is signaled, unless NO-SIGNAL, in which
941 case NIL is returned as first value and errno as second.."
942 (multiple-value-bind (stat err)
943 (c-inline2 (path)
944 (:cstring)
945 (values :object :int)
946 "
947 {
948 struct stat st;
949 cl_object cl_st = Cnil;
950 int err = 0;
951
952 if (stat(#0, &st) == 0)
953 cl_st = fill_stat_structure(&st);
954 else
955 err = errno;
956
957 @(return 0) = cl_st;
958 @(return 1) = err;
959 }" :one-liner nil)
960 (if stat
961 stat
962 (if no-signal
963 (values nil err)
964 (unix-error "stat" err `(,path))))))
965
966 (defun lstat (path &optional no-signal)
967 "Invokes the lstat(2) syscall on PATH.
968 Returns a STAT structure on success.
969 On error, a UNIX-ERROR condition is signaled, unless NO-SIGNAL, in which
970 case NIL is returned as first value and errno integer as second value."
971 (multiple-value-bind (stat err)
972 (c-inline2 (path)
973 (:cstring)
974 (values :object :int)
975 "
976 {
977 struct stat st;
978 cl_object cl_st = Cnil;
979 int err = 0;
980
981 if (lstat(#0, &st) == 0)
982 cl_st = fill_stat_structure(&st);
983 else
984 err = errno;
985
986 @(return 0) = cl_st;
987 @(return 1) = err;
988 }" :one-liner nil)
989 (if stat
990 stat
991 (if no-signal
992 (values nil err)
993 (unix-error "lstat" err `(,path))))))
994
995 (defsyscall0 (chdir "chdir") (:cstring)
996 "Invokes chdir(2) on PATH.")
997
998 (defsyscall0 (fchdir "fchdir") (:int)
999 "Invokes fchdir(2) on FD.")
1000
1001 (defun getcwd ()
1002 "Invokes getcwd(3) and returns the string of the CWD path.
1003 On error, signals a condition of type UNIX-ERROR."
1004 (multiple-value-bind (path err)
1005 (ffi:c-inline ()
1006 ()
1007 (values :cstring :int)
1008 "
1009 {
1010 char buf[MAXPATHLEN];
1011 int err = 0;
1012
1013 if (getcwd(buf, MAXPATHLEN - 1) == NULL)
1014 err = errno;
1015
1016 @(return 0) = buf;
1017 @(return 1) = err;
1018 }" :one-liner nil)
1019 (if (= 0 err)
1020 path
1021 (unix-error "getcwd" err))))
1022
1023 (defsyscall0 (mkdir "mkdir") (:cstring :mode-t)
1024 "Invokes mkdir(2) with PATH and MODE.")
1025
1026 (defsyscall0 (rmdir "rmdir") (:cstring)
1027 "Invokes rmdir(2) on PATH.")
1028
1029 (defsyscall0 (chown "chown") (:cstring :uid-t :gid-t)
1030 "Invokes chown(2) on PATH with OWNER and GROUP.")
1031
1032 (defsyscall0 (lchown "lchown") (:cstring :uid-t :gid-t)
1033 "Invokes lchown(2) on PATH with OWNER and GROUP.")
1034
1035 (defsyscall0 (fchown "fchown") (:int :uid-t :gid-t)
1036 "Invokes fchown(2) on FD with OWNER and GROUP.")
1037
1038 (defsyscall0 (chmod "chmod") (:cstring :mode-t)
1039 "Invokes chmod(2) on PATH with MODE.")
1040
1041 (defsyscall0 (lchmod "lchmod") (:cstring :mode-t)
1042 "Invokes lchmod(2) with PATH and MODE.")
1043
1044 (defsyscall0 (fchmod "fchmod") (:int :mode-t)
1045 "Invokes fchmod(2) with FD and MODE.")
1046
1047 (defun umask (numask)
1048 "Invokes umask(2) with NUMASK.
1049 This function always returns the previous umask."
1050 (c-inline2 (numask) (:mode-t) :mode-t "umask(#0)" :one-liner t))
1051
1052 (defsyscall0 (rename "rename") (:cstring :cstring)
1053 "Invokes rename(2) with FROM and TO.")
1054
1055 (defsyscall0 (unlink "unlink") (:cstring)
1056 "Invokes unlink(2) on PATH.")
1057
1058 (defsyscall0 (truncate-file "truncate") (:cstring :off-t)
1059 "Invokes truncate(2) on PATH with LENGTH.")
1060
1061 (defsyscall0 (ftruncate-fd "ftruncate") (:int :off-t)
1062 "Invokes ftruncate(2) on FD with LENGTH.")
1063
1064 (defsyscall0 (mknod "mknod") (:cstring :mode-t :dev-t)
1065 "Invokes mknod(2) with PATH MODE and DEV.")
1066
1067 (defsyscall0 (mkfifo "mkfifo") (:cstring :mode-t)
1068 "Invokes mkfifo(2) with PATH and MODE.")
1069
1070 (defsyscall0 (symlink "symlink") (:cstring :cstring)
1071 "Invokes symlink(2) creating LINK-PATH pointing to DESTINATION-PATH.")
1072
1073 (defsyscall0 (link "link") (:cstring :cstring)
1074 "Invokes link(2) creating LINK-PATH pointing to DESTINATION-PATH.")
1075
1076 (defun readlink (link-path)
1077 "Invokes readlink(2) on LINK-PATH.
1078 Returns the destination path string, or signals a condition of type
1079 UNIX-ERROR."
1080 (multiple-value-bind (path err)
1081 (ffi:c-inline (link-path)
1082 (:cstring)
1083 (values :cstring :int)
1084 "
1085 {
1086 char buf[PATH_MAX];
1087 ssize_t len = 0;
1088
1089 if ((len = readlink(#0, buf, PATH_MAX - 1)) == -1) {
1090 len = 0;
1091 @(return 1) = errno;
1092 } else
1093 @(return 1) = 0;
1094
1095 buf[len] = '\0';
1096 @(return 0) = buf;
1097 }" :one-liner nil)
1098 (if (= 0 err)
1099 path
1100 (unix-error "readlink" err `(,link-path)))))
1101
1102 (defun sync ()
1103 "Invokes sync(2). Returns T."
1104 (ffi:c-inline () () :void "sync()" :one-liner t)
1105 t)
1106
1107 (defsyscall0 (fsync "fsync" :no-signal) (:int)
1108 "Invokes fsync(2) on FD.")
1109
1110 (defsyscall0 (fsync-range "fsync_range" :no-signal) (:int :int :off-t :off-t)
1111 "Invokes fsync_range(2) on FD with HOW, START and LENGTH.")
1112
1113 (defsyscall0 (fdatasync "fdatasync" :no-signal) (:int)
1114 "Invokes fdatasync(2) on FD.")
1115
1116 (defun uid<-user (name)
1117 "Converts supplied user NAME to a numeric UID. If an integer UID is
1118 provided instead of a string for NAME, the same integer is returned without
1119 checking for actual existence of that user.
1120 Returns an integer UID on success or signals a condition of type UNIX-ERROR."
1121 (multiple-value-bind (uid err)
1122 (if (typep name 'integer)
1123 (values name 0)
1124 (c-inline2 (name)
1125 (:cstring)
1126 (values :uid-t :int)
1127 "
1128 {
1129 struct passwd pw, *result;
1130 char buf[256];
1131 uint32_t uid = -1;
1132 int err = 0;
1133
1134 if (getpwnam_r(#0, &pw, buf, 255, &result) != 0)
1135 err = errno;
1136 else if (result == NULL)
1137 err = ENOENT;
1138 else
1139 uid = pw.pw_uid;
1140
1141 @(return 0) = uid;
1142 @(return 1) = err;
1143 }" :one-liner nil))
1144 (if (= 0 err)
1145 uid
1146 (unix-error "getpwnam_r" err `(,name)))))
1147
1148 (defun gid<-group (name)
1149 "Converts supplied group NAME to a numeric GID. If an integer GID is
1150 provided instead of a sting for NAME, the same integer is returned without
1151 checking for actual existence of that group.
1152 Returns an integer GID on success or signals a condition of type UNIX-ERROR."
1153 (multiple-value-bind (gid err)
1154 (if (typep name 'integer)
1155 (values name 0)
1156 (c-inline2 (name)
1157 (:cstring)
1158 (values :gid-t :int)
1159 "
1160 {
1161 struct group gr, *result;
1162 char buf[256];
1163 uint32_t gid = -1;
1164 int err = 0;
1165
1166 if (getgrnam_r(#0, &gr, buf, 255, &result) != 0)
1167 err = errno;
1168 else if (result == NULL)
1169 err = ENOENT;
1170 else
1171 gid = gr.gr_gid;
1172
1173 @(return 0) = gid;
1174 @(return 1) = err;
1175 }" :one-liner nil))
1176 (if (= 0 err)
1177 gid
1178 (unix-error "getgrnam_r" err `(,name)))))
1179
1180 (defun user<-uid (uid)
1181 "Converts supplied integer UID to a user name string.
1182 Returns a user name string on success or signals an error of type UNIX-ERROR."
1183 (multiple-value-bind (user err)
1184 (c-inline2 (uid)
1185 (:uid-t)
1186 (values :cstring :int)
1187 "
1188 {
1189 struct passwd pw, *result;
1190 char buf[256], *user = NULL;
1191 int err = 0;
1192
1193 if (getpwuid_r(#0, &pw, buf, 255, &result) != 0)
1194 err = errno;
1195 else if (result == NULL)
1196 err = ENOENT;
1197 else
1198 user = pw.pw_name;
1199
1200 @(return 0) = user;
1201 @(return 1) = err;
1202 }" :one-liner nil)
1203 (if (= 0 err)
1204 user
1205 (unix-error "getpwuid_r" err `(,uid)))))
1206
1207 (defun group<-gid (gid)
1208 "Converts supplied integer GID to a group name string.
1209 Returns a group name string on success (and NIL if group doesn't exist) or
1210 signals an error of type UNIX-ERROR."
1211 (multiple-value-bind (group err)
1212 (c-inline2 (gid)
1213 (:gid-t)
1214 (values :cstring :int)
1215 "
1216 {
1217 struct group gr, *result;
1218 char buf[256], *group = NULL;
1219 int err = 0;
1220
1221 if (getgrgid_r(#0, &gr, buf, 255, &result) != 0)
1222 err = errno;
1223 else if (result == NULL)
1224 err = ENOENT;
1225 else
1226 group = gr.gr_name;
1227
1228 @(return 0) = group;
1229 @(return 1) = err;
1230 }" :one-liner nil)
1231 (if (= 0 err)
1232 group
1233 (unix-error "getgrgid_r" err `(,gid)))))
1234
1235 (defun getuid ()
1236 "Invokes getuid(2) and returns the integer UID."
1237 (c-inline2 () () :uid-t "getuid()" :one-liner t))
1238
1239 (defun geteuid ()
1240 "Invokes geteuid(2) and returns the integer effective UID."
1241 (c-inline2 () () :uid-t "geteuid()" :one-liner t))
1242
1243 (defun getgid ()
1244 "Invokes getgid(2) and returns the integer GID."
1245 (c-inline2 () () :gid-t "getgid()" :one-liner t))
1246
1247 (defun getegid ()
1248 "Invokes getegid(2) and returns the integer effective GID."
1249 (c-inline2 () () :gid-t "getegid()" :one-liner t))
1250
1251 (defun setuid (uid)
1252 "Invokes setuid(2) with UID. Returns NIL on success or signals a condition
1253 of type UNIX-ERROR."
1254 (let ((err (c-inline2 (uid)
1255 (:uid-t)
1256 :int
1257 "
1258 {
1259 int err = 0;
1260
1261 if (setuid(#0) == -1)
1262 err = EPERM;
1263
1264 @(return) = err;
1265 }" :one-liner nil)))
1266 (if (= 0 err)
1267 nil
1268 (unix-error "setuid" err `(,uid)))))
1269
1270 (defun seteuid (uid)
1271 "Invokes seteuid(2) with UID. Returns NIL on success or signals a condition
1272 of type UNIX-ERROR."
1273 (let ((err (c-inline2 (uid)
1274 (:uid-t)
1275 :int
1276 "
1277 {
1278 int err = 0;
1279
1280 if (seteuid(#0) == -1)
1281 err = EPERM;
1282
1283 @(return) = err;
1284 }" :one-liner nil)))
1285 (if (= 0 err)
1286 nil
1287 (unix-error "seteuid" err `(,uid)))))
1288
1289 (defun setgid (gid)
1290 "Invokes setgid(2) with GID. Returns NIL on success or signals a condition
1291 of type UNIX-ERROR."
1292 (let ((err (c-inline2 (gid)
1293 (:gid-t)
1294 :int
1295 "
1296 {
1297 int err = 0;
1298
1299 if (setgid(#0) == -1)
1300 err = EPERM;
1301
1302 @(return) = err;
1303 }" :one-liner nil)))
1304 (if (= 0 err)
1305 nil
1306 (unix-error "setgid" err `(,gid)))))
1307
1308 (defun setegid (gid)
1309 "Invokes setegid(2) with GID. Returns NIL on success or signals a condition
1310 of type UNIX-ERROR."
1311 (let ((err (c-inline2 (gid)
1312 (:gid-t)
1313 :int
1314 "
1315 {
1316 int err = 0;
1317
1318 if (setegid(#0) == -1)
1319 err = EPERM;
1320
1321 @(return) = err;
1322 }" :one-liner nil)))
1323 (if (= 0 err)
1324 nil
1325 (unix-error "setegid" err `(,gid)))))
1326
1327 (defun getgroups ()
1328 "Invokes getgroups(2) and returns an array of integer GIDs on success.
1329 Signals a condition of type UNIX-ERROR on error."
1330 (multiple-value-bind (groups err)
1331 (c-inline-format ()
1332 ()
1333 (values :object :int)
1334 "
1335 {
1336 gid_t groups[_POSIX_NGROUPS_MAX + 1];
1337 cl_object v;
1338 int n;
1339
1340 if ((n = getgroups(_POSIX_NGROUPS_MAX, groups)) == -1) {
1341 @(return 0) = Cnil;
1342 @(return 1) = errno;
1343 } else {
1344 int i;
1345
1346 v = cl_make_array(3, MAKE_FIXNUM(n), @:element-type,
1347 @'fixnum);
1348 for (i = 0; i < n; i++)
1349 ecl_aset(v, i, ~A);
1350 @(return 0) = v;
1351 @(return 1) = 0;
1352 }
1353 }" #.(c-function<-system-type :gid-t "groups[i]"))
1354 (if (= 0 err)
1355 groups
1356 (unix-error "getgroups" err))))
1357
1358 (defun setgroups (groups)
1359 "Invokes setgroups(2) with elements of ARRAY and returns NIL on success or
1360 signals a condition of type UNIX-ERROR on failure."
1361 ;; CHECK-TYPE isn't safe enough here.
1362 (assert (and (typep groups '(array *))
1363 (not (some #'null (map 'list
1364 #'(lambda (e)
1365 (typep e '(integer 0 #xFFFFFFFF)))
1366 groups))))
1367 (groups)
1368 'type-error :datum groups
1369 :expected-type '(array (integer 0 #xFFFFFFFF) (*)))
1370 (let ((err (c-inline-format (groups (length groups))
1371 (:object :int)
1372 :int
1373 "
1374 {
1375 gid_t groups[_POSIX_NGROUPS_MAX + 1];
1376 int i, n = #1;
1377 cl_object v = #0;
1378
1379 if (n > _POSIX_NGROUPS_MAX)
1380 n = _POSIX_NGROUPS_MAX;
1381 for (i = 0; i < n; i++)
1382 groups[i] = (gid_t)~A(ecl_aref(v, i));
1383
1384 if (setgroups(n, groups) == 0)
1385 @(return) = 0;
1386 else
1387 @(return) = errno;
1388 }" #.(to-c-function<-system-type :gid-t))))
1389 (unless (= 0 err)
1390 (unix-error "setgroups" err `(,groups))))
1391 nil)
1392
1393 (defun getpid ()
1394 "Invokes getpid(2), returning the process ID of the current process."
1395 (c-inline2 () () :pid-t "getpid()" :one-liner t))
1396
1397 (defun getppid ()
1398 "Invokes getppid(2), returning the process ID of our parent process."
1399 (c-inline2 () () :pid-t "getppid()" :one-liner t))
1400
1401 (defun getpgrp ()
1402 "Invokes getpgrp(2), returning the process group ID of the current process."
1403 (c-inline2 () () :pid-t "getpgrp()" :one-liner t))
1404
1405 (defsyscall1 (:pid-t getpgid "getpgid" :no-signal) (:pid-t)
1406 "Invokes getpgid(2), returning the process group ID of process PID.")
1407
1408 (defsyscall1 (:int setpgid "setpgid" :no-signal) (:pid-t :pid-t)
1409 "Invokes setpgid(2) using PID and PGRP, returning 0 on success.")
1410
1411 (defsyscall1 (:int setpgrp "setpgrp" :no-signal) (:pid-t :pid-t)
1412 "Invokes setpgrp(2) using PID and PGRP, returning 0 on success.")
1413
1414
1415 (define-c-constants :fcntl "fcntl.h"
1416 (o-rdonly "O_RDONLY")
1417 (o-rwonly "O_WRONLY")
1418 (o-rdwr "O_RDWR")
1419 (o-nonblock "O_NONBLOCK")
1420 (o-append "O_APPEND")
1421 (o-creat "O_CREAT")
1422 (o-trunc "O_TRUNC")
1423 (o-excl "O_EXCL")
1424 (o-shlock "O_SHLOCK")
1425 (o-exlock "O_EXLOCK")
1426 (o-nofollow "O_NOFOLLOW")
1427 (o-dsync "O_DSYNC")
1428 (o-async "O_ASYNC")
1429 (o-sync "O_SYNC")
1430 (o-rsync "O_RSYNC")
1431 (o-alt-io "O_ALT_IO")
1432 (o-noctty "O_NOCTTY")
1433 (o-direct "O_DIRECT")
1434 (f-dupfd "F_DUPFD")
1435 (f-getfd "F_GETFD")
1436 (f-setfd "F_SETFD")
1437 (f-getfl "F_GETFL")
1438 (f-setfl "F_SETFL")
1439 (f-getown "F_GETOWN")
1440 (f-setown "F_SETOWN")
1441 (f-closem "F_CLOSEM")
1442 (f-maxfd "F_MAXFD")
1443 (f-getlk "F_GETLK")
1444 (f-setlk "F_SETLK")
1445 (f-setlkw "F_SETLKW")
1446 (f-unlck "F_UNLCK")
1447 (f-rdlck "F_RDLCK")
1448 (f-wrlck "F_WRLCK")
1449 (lock-sh "LOCK_SH")
1450 (lock-ex "LOCK_EX")
1451 (lock-nb "LOCK_NB")
1452 (lock-un "LOCK_UN"))
1453
1454
1455 (defsyscall1 (:int open-fd "open" :no-signal) (:cstring :int :mode-t)
1456 "Invokes open(2) with PATH FLAGS and MODE, returning a new integer file
1457 descriptor on success.")
1458
1459 (defsyscall1 (:int close-fd "close" :no-signal) (:int)
1460 "Invokes close(2) on FD, returning 0 on success.")
1461
1462 (defmacro with-open-fd ((fd path flags mode &optional no-signal) &body body)
1463 "Attempts to OPEN-FD PATH with FLAGS and MODE assigning the file descriptor
1464 to FD, to then evaluate BODY then making sure to close FD.
1465 If NO-SIGNAL, CLOSE-FD is invoked with :NO-SIGNAL"
1466 (let ((ifd (gensym)))
1467 `(let* ((,ifd (open-fd ,path ,flags ,mode))
1468 (,fd ,ifd))
1469 (unwind-protect
1470 (progn
1471 ,@body)
1472 (close-fd ,ifd ,no-signal)))))
1473
1474 (defmacro with-fd ((fd &key shutdown no-signal) &body body)
1475 "Evaluate BODY and then ensure to close FD.
1476 If SHUTDOWN, also ensure to shutdown the socket in both directions before
1477 closing. If NO-SIGNAL, SHUTDOWN and CLOSE-FD are invoked with :NO-SIGNAL T."
1478 (let ((efd (gensym))
1479 (nsignal (gensym)))
1480 `(let ((,efd ,fd)
1481 (,nsignal ,no-signal))
1482 (unwind-protect
1483 (progn
1484 ,@body)
1485 (progn
1486 ,@(when shutdown
1487 `((with-c-constants (:sys-socket)
1488 (shutdown ,efd shut-rdwr ,nsignal))))
1489 (close-fd ,efd ,nsignal))))))
1490
1491 (defsyscall1 (:int dup "dup") (:int)
1492 "Invokes dup(2) with OLD.
1493 Returns the new file descriptor on success.")
1494
1495 (defsyscall1 (:int dup2 "dup2") (:int :int)
1496 "Invokes dup2(2) with OLD and NEW.
1497 Returns the new file descriptor on success.")
1498
1499
1500 (ffi:clines "
1501 #include <stdbool.h>
1502 #include <sys/types.h>
1503 #include <sys/socket.h>
1504 #include <netinet/in.h>
1505 #include <netinet/tcp.h>
1506 #include <arpa/inet.h>
1507 #include <netdb.h>
1508 #include <sys/un.h>
1509 #include <string.h>
1510 ")
1511
1512 ; XXX Add missing stuff for broadcast and/or ipv6
1513 (define-c-constants :sys-socket "sys/socket.h"
1514 (pf-local "PF_LOCAL")
1515 (pf-inet "PF_INET")
1516 (pf-inet6 "PF_INET6")
1517 (af-local "AF_LOCAL")
1518 (af-inet "AF_INET")
1519 (af-inet6 "AF_INET6")
1520 (shut-rd "SHUT_RD")
1521 (shut-rw "SHUT_WR")
1522 (shut-rdwr "SHUT_RDWR")
1523 (sock-stream "SOCK_STREAM")
1524 (sock-dgram "SOCK_DGRAM")
1525 (so-debug "SO_DEBUG")
1526 (so-reuseaddr "SO_REUSEADDR")
1527 (so-reuseport "SO_REUSEPORT")
1528 (so-keepalive "SO_KEEPALIVE")
1529 (so-dontroute "SO_DONTROUTE")
1530 (so-linger "SO_LINGER")
1531 (so-broadcast "SO_BROADCAST")
1532 (so-oobinline "SO_OOBINLINE")
1533 (so-sndbuf "SO_SNDBUF")
1534 (so-rcvbuf "SO_RCVBUF")
1535 (so-sndlowat "SO_SNDLOWAT")
1536 (so-rcvlowat "SO_RCVLOWAT")
1537 (so-sndtimeo "SO_SNDTIMEO")
1538 (so-rcvtimeo "SO_RCVTIMEO")
1539 (so-timestamp "SO_TIMESTAMP")
1540 (so-type "SO_TYPE")
1541 (so-error "SO_ERROR")
1542 (sol-socket "SOL_SOCKET")
1543 (msg-oob "MSG_OOB")
1544 (msg-peek "MSG_PEEK")
1545 (msg-waitall "MSG_WAITALL")
1546 (msg-dontroute "MSG_DONTROUTE")
1547 (msg-eor "MSG_EOR")
1548 (msg-nosignal "MSG_NOSIGNAL"))
1549
1550 (define-c-constants :netinet-in "netinet/in.h"
1551 (ipproto-tcp "IPPROTO_TCP"))
1552
1553 (define-c-constants :netinet-tcp "netinet/tcp.h"
1554 (tcp-nodelay "TCP_NODELAY"))
1555
1556
1557 (defsyscall1 (:int socket "socket") (:int :int :int)
1558 "Invokes socket(2) with DOMAIN, TYPE and PROTOCOL.
1559 Returns a new socket file descriptor integer on success, or signals a condition
1560 of type UNIX-ERROR.")
1561
1562 (defsyscall1 (:int shutdown "shutdown" :no-signal) (:int :int)
1563 "Invokes shutdown(2) with FD and HOW, returning 0 on success.")
1564
1565
1566 (defun %sockopt-int (fd level optname)
1567 (multiple-value-bind (err val)
1568 (c-inline2 (fd level optname)
1569 (:int :int :int)
1570 (values :int :int)
1571 "
1572 {
1573 int val = 0, err = 0;
1574 socklen_t len = sizeof(int);
1575
1576 if (getsockopt(#0, #1, #2, &val, &len) == -1)
1577 err = errno;
1578
1579 @(return 0) = err;
1580 @(return 1) = val;
1581 }" :one-liner nil)
1582 (if (= 0 err)
1583 val
1584 (unix-error "getsockopt" err `(,fd ,level ,optname)))))
1585
1586 (defun (setf %sockopt-int) (val fd level optname)
1587 (let ((err (c-inline2 (fd level optname val)
1588 (:int :int :int :int)
1589 :int
1590 "
1591 {
1592 int err = 0, val = #3;
1593
1594 if (setsockopt(#0, #1, #2, &val, sizeof(int)) == -1)
1595 err = errno;
1596
1597 @(return) = err;
1598 }" :one-liner nil)))
1599 (if (= 0 err)
1600 val
1601 (unix-error "setsockopt" err `(,fd ,level ,optname ,val)))))
1602
1603 (defun %sockopt-bool (fd level optname)
1604 (multiple-value-bind (err val)
1605 (c-inline2 (fd level optname)
1606 (:int :int :int)
1607 (values :int :object)
1608 "
1609 {
1610 int val = 0, err = 0;
1611 socklen_t len = sizeof(int);
1612
1613 if (getsockopt(#0, #1, #2, &val, &len) == -1)
1614 err = errno;
1615
1616 @(return 0) = err;
1617 @(return 1) = (val != 0 ? Ct : Cnil);
1618 }" :one-liner nil)
1619 (if (= 0 err)
1620 val
1621 (unix-error "getsockopt" err `(,fd ,level ,optname)))))
1622
1623 (defun (setf %sockopt-bool) (val fd level optname)
1624 (check-type val boolean)
1625 (let ((err (c-inline2 (fd level optname val)
1626 (:int :int :int :object)
1627 :int
1628 "
1629 {
1630 int err = 0, val = (#3 != Cnil ? 1 : 0);
1631
1632 if (setsockopt(#0, #1, #2, &val, sizeof(int)) == -1)
1633 err = errno;
1634
1635 @(return) = err;
1636 }" :one-liner nil)))
1637 (if (= 0 err)
1638 val
1639 (unix-error "setsockopt" err `(,fd ,level ,optname ,val)))))
1640
1641 (define-c-structure timeval "struct timeval"
1642 (sec :long "tv_sec")
1643 (usec :long "tv_usec"))
1644 (define-c-cl-structure timeval)
1645 (define-c-structure-serializer timeval)
1646 (define-to-c-structure-serializer timeval)
1647
1648 (defun %sockopt-timeval (fd level optname)
1649 (multiple-value-bind (ret err)
1650 (c-inline2 (fd level optname)
1651 (:int :int :int)
1652 (values :object :int)
1653 "
1654 {
1655 struct timeval tv;
1656 cl_object ret = Cnil;
1657 int err = 0;
1658 socklen_t len = sizeof(struct timeval);
1659
1660 if (getsockopt(#0, #1, #2, &tv, &len) == -1)
1661 err = errno;
1662 else
1663 ret = fill_timeval_structure(&tv);
1664
1665 @(return 0) = ret;
1666 @(return 1) = err;
1667 }" :one-liner nil)
1668 (if ret
1669 ret
1670 (unix-error "getsockopt" err `(,fd ,level ,optname)))))
1671
1672 (defun (setf %sockopt-timeval) (tv fd level optname)
1673 (check-type tv timeval)
1674 (let ((err (c-inline2 (fd level optname tv)
1675 (:int :int :int :object)
1676 :int
1677 "
1678 {
1679 int err = 0;
1680 struct timeval tv;
1681
1682 fill_timeval_c_structure(&tv, #3);
1683 if (setsockopt(#0, #1, #2, &tv, sizeof(struct timeval)) == -1)
1684 err = errno;
1685
1686 @(return) = err;
1687 }" :one-liner nil)))
1688 (if (= 0 err)
1689 tv
1690 (unix-error "setsockopt" err `(,fd ,level ,optname ,tv)))))
1691
1692 (defun %sockopt-linger (fd level optname)
1693 (multiple-value-bind (err val1 val2)
1694 (c-inline2 (fd level optname)
1695 (:int :int :int)
1696 (values :int :object :int)
1697 "
1698 {
1699 int err = 0;
1700 struct linger val;
1701 socklen_t len = sizeof(struct linger);
1702
1703 val.l_onoff = 0;
1704 val.l_linger = 0;
1705 if (getsockopt(#0, #1, #2, &val, &len) == -1)
1706 err = errno;
1707
1708 @(return 0) = err;
1709 @(return 1) = (val.l_onoff != 0 ? Ct : Cnil);
1710 @(return 2) = val.l_linger;
1711 }" :one-liner nil)
1712 (if (= 0 err)
1713 `(,val1 ,val2)
1714 (unix-error "getsockopt" err `(,fd ,level ,optname)))))
1715
1716 (defun (setf %sockopt-linger) (val fd level optname)
1717 (destructuring-bind (onoff linger) val
1718 (check-type onoff boolean)
1719 (let ((err (c-inline2 (fd level optname onoff linger)
1720 (:int :int :int :object :int)
1721 :int
1722 "
1723 {
1724 int err = 0;
1725 struct linger val;
1726
1727 val.l_onoff = (#3 != Cnil ? 1 : 0);
1728 val.l_linger = #4;
1729 if (setsockopt(#0, #1, #2, &val, sizeof(struct linger)) == -1)
1730 err = errno;
1731
1732 @(return) = err;
1733 }" :one-liner nil)))
1734 (if (= 0 err)
1735 val
1736 (unix-error "setsockopt" err `(,fd ,level ,optname ,val))))))
1737
1738 ;;; XXX We could default level and optname and generate optname from name...
1739 (eval-when (:compile-toplevel :load-toplevel)
1740 (defmacro define-sockopt (name level optname type &key read-only)
1741 (check-type* (name symbol)
1742 (level symbol)
1743 (optname symbol)
1744 (type symbol)
1745 (read-only (or null boolean)))
1746 (let ((internal-function-name (intern (format nil "%SOCKOPT-~A" type)))
1747 (external-function-name (intern (format nil "SOCKOPT-~A" name))))
1748 `(progn
1749 (export ',external-function-name)
1750 (defun ,external-function-name (fd)
1751 (,internal-function-name fd ,level ,optname))
1752 ,@(unless read-only
1753 `((defun (setf ,external-function-name) (val fd)
1754 (setf (,internal-function-name fd ,level ,optname)
1755 val))))))))
1756
1757 (with-c-constants (:sys-socket :netinet-in :netinet-tcp)
1758 (define-sockopt debug sol-socket so-debug bool)
1759 (define-sockopt reuseaddr sol-socket so-reuseaddr bool)
1760 (define-sockopt reuseport sol-socket so-reuseport bool)
1761 (define-sockopt keepalive sol-socket so-keepalive bool)
1762 (define-sockopt dontroute sol-socket so-dontroute bool)
1763 (define-sockopt linger sol-socket so-linger linger)
1764 (define-sockopt broadcast sol-socket so-broadcast bool)
1765 (define-sockopt oobinline sol-socket so-oobinline bool)
1766 (define-sockopt sndbuf sol-socket so-sndbuf int)
1767 (define-sockopt rcvbuf sol-socket so-rcvbuf int)
1768 (define-sockopt sndlowat sol-socket so-sndlowat int)
1769 (define-sockopt rcvlowat sol-socket so-rcvlowat int)
1770 (define-sockopt sndtimeo sol-socket so-sndtimeo timeval)
1771 (define-sockopt rcvtimeo sol-socket so-rcvtimeo timeval)
1772 (define-sockopt timestamp sol-socket so-timestamp bool)
1773 (define-sockopt type sol-socket so-type int :read-only t)
1774 (define-sockopt error sol-socket so-error int :read-only t)
1775 (define-sockopt tcp-nodelay ipproto-tcp tcp-nodelay bool))
1776
1777
1778
1779 (defun %fcntl-int (fd cmd)
1780 (multiple-value-bind (ret err)
1781 (c-inline2 (fd cmd)
1782 (:int :int)
1783 (values :int :int)
1784 "
1785 {
1786 int ret, err = 0;
1787
1788 if ((ret = fcntl(#0, #1)) == -1)
1789 err = errno;
1790
1791 @(return 0) = ret;
1792 @(return 1) = err;
1793 }" :one-liner nil)
1794 (if (= -1 ret)
1795 (unix-error "fcntl" err `(,fd ,cmd))
1796 ret)))
1797
1798 (defun (setf %fcntl-int) (val fd cmd)
1799 (multiple-value-bind (ret err)
1800 (c-inline2 (fd cmd val)
1801 (:int :int :int)
1802 (values :int :int)
1803 "
1804 {
1805 int ret, err = 0;
1806
1807 if ((ret = fcntl(#0, #1, #2)) == -1)
1808 err = errno;
1809
1810 @(return 0) = ret;
1811 @(return 1) = err;
1812 }" :one-liner nil)
1813 (if (= -1 ret)
1814 (unix-error "fcntl" err `(,fd ,cmd ,val))
1815 ret)))
1816
1817 (defun %fcntl-bool (fd cmd)
1818 (multiple-value-bind (ret err)
1819 (c-inline2 (fd cmd)
1820 (:int :int)
1821 (values :int :int)
1822 "
1823 {
1824 int ret, err = 0;
1825
1826 if ((ret = fcntl(#0, #1)) == -1)
1827 err = errno;
1828
1829 @(return 0) = ret;
1830 @(return 1) = err;
1831 }" :one-liner nil)
1832 (if (= -1 ret)
1833 (unix-error "fcntl" err `(,fd ,cmd))
1834 (if (= 0 ret)
1835 nil
1836 t))))
1837
1838 (defun (setf %fcntl-bool) (val fd cmd)
1839 (check-type val boolean)
1840 (multiple-value-bind (ret err)
1841 (c-inline2 (fd cmd val)
1842 (:int :int :object)
1843 (values :int :int)
1844 "
1845 {
1846 int ret, err = 0, val = (#2 != Cnil ? 1 : 0);
1847
1848 if ((ret = fcntl(#0, #1, val)) == -1)
1849 err = errno;
1850
1851 @(return 0) = ret;
1852 @(return 1) = err;
1853 }" :one-liner nil)
1854 (if (= -1 ret)
1855 (unix-error "fcntl" err `(,fd ,cmd ,val))
1856 (if (= 0 ret)
1857 nil
1858 t))))
1859
1860
1861
1862 (define-c-structure flock "struct flock"
1863 (start :off-t "l_start")
1864 (len :off-t "l_len")
1865 (pid :pid-t "l_pid")
1866 (type :short "l_type")
1867 (whence :short "l_whence"))
1868 (define-c-structure-accessors flock)
1869
1870 (defstruct (flock (:constructor %make-flock)
1871 (:print-object
1872 (lambda (o s)
1873 (print-unreadable-object (o s :type t :identity t)
1874 (if (flock-pointer o)
1875 (prin1 `(:start ,(flock-start o)
1876 :len ,(flock-len o)
1877 :pid ,(flock-pid o)
1878 :type ,(flock-type o)
1879 :whence ,(flock-whence o)) s)
1880 (prin1 `(:pointer nil) s))))))
1881 pointer)
1882
1883 (defun make-flock (&key (start 0) (len 0) (pid 0) (type 0) (whence 0))
1884 "Creates a FLOCK structure which may be used with fcntl(2) related locking
1885 functions. These structures should be destroyed using DESTROY-FLOCK when no
1886 longer needed, otherwise memory leaks will occur."
1887 (let ((o (%make-flock :pointer (c-inline2 () () :pointer-void
1888 "malloc(sizeof(struct flock))"
1889 :one-liner t))))
1890 (handler-case
1891 (setf (flock-start o) start
1892 (flock-len o) len
1893 (flock-pid o) pid
1894 (flock-type o) type
1895 (flock-whence o) whence)
1896 (error (condition)
1897 (destroy-flock o)
1898 (error condition)))
1899 o))
1900
1901 (defun destroy-flock (o)
1902 (check-type o flock)
1903 (when (flock-pointer o)
1904 (c-inline2 ((flock-pointer o)) (:pointer-void) :void
1905 "free(#0)" :one-liner t)
1906 (setf (flock-pointer o) nil)))
1907
1908 (defun %fcntl-lock (fd cmd lock)
1909 (check-type lock flock)
1910 (multiple-value-bind (ret err)
1911 (c-inline2 (fd cmd (flock-pointer lock))
1912 (:int :int :pointer-void)
1913 (values :int :int)
1914 "
1915 {
1916 int ret, err = 0;
1917
1918 if ((ret = fcntl(#0, #1, #2)) == -1)
1919 err = errno;
1920
1921 @(return 0) = ret;
1922 @(return 1) = err;
1923 }" :one-liner nil)
1924 (if (= -1 ret)
1925 (unix-error "fcntl" err `(,fd ,cmd ,lock))
1926 ret)))
1927
1928 (defun (setf %fcntl-lock) (val fd cmd)
1929 (check-type val flock)
1930 (multiple-value-bind (ret err)
1931 (c-inline2 (fd cmd (flock-pointer val))
1932 (:int :int :pointer-void)
1933 (values :int :int)
1934 "
1935 {
1936 int ret, err = 0;
1937
1938 if ((ret = fcntl(#0, #1, #2)) == -1)
1939 err = errno;
1940
1941 @(return 0) = ret;
1942 @(return 1) = err;
1943 }" :one-liner nil)
1944 (if (= -1 ret)
1945 (unix-error "fcntl" err `(,fd ,cmd ,val))
1946 ret)))
1947
1948 (defun fcntl-getlk (fd lock)
1949 (with-c-constants (:fcntl)
1950 (%fcntl-lock fd f-getlk lock)
1951 lock))
1952 (defun (setf fcntl-setlk) (lock fd)
1953 (with-c-constants (:fcntl)
1954 (setf (%fcntl-lock fd f-setlk) lock)
1955 lock))
1956 (defun (setf fcntl-setlkw) (lock fd)
1957 (with-c-constants (:fcntl)
1958 (setf (%fcntl-lock fd f-setlkw) lock)
1959 lock))
1960
1961 (defun fcntl-dupfd (fd)
1962 (with-c-constants (:fcntl)
1963 (%fcntl-int fd f-dupfd)))
1964
1965 (defun fcntl-close-on-exec (fd)
1966 (with-c-constants (:fcntl)
1967 (%fcntl-bool fd f-getfd)))
1968 (defun (setf fcntl-close-on-exec) (val fd)
1969 (with-c-constants (:fcntl)
1970 (setf (%fcntl-bool fd f-setfd) val)))
1971
1972 (defun fcntl-status (fd)
1973 (with-c-constants (:fcntl)
1974 (%fcntl-int fd f-getfl)))
1975 (defun (setf fcntl-status) (val fd)
1976 (with-c-constants (:fcntl)
1977 (setf (%fcntl-int fd f-setfl) val)))
1978
1979 (defun fcntl-nonblock (fd)
1980 (with-c-constants (:fcntl)
1981 (let ((status (fcntl-status fd)))
1982 (if (zerop (logand status o-nonblock))
1983 nil
1984 t))))
1985 (defun (setf fcntl-nonblock) (val fd)
1986 (check-type val boolean)
1987 (with-c-constants (:fcntl)
1988 (let ((status (fcntl-status fd)))
1989 (cond (val
1990 (setf (fcntl-status fd)
1991 (logior status o-nonblock))
1992 t)
1993 (t
1994 (setf (fcntl-status fd)
1995 (logand status (lognot o-nonblock)))
1996 nil)))))
1997
1998 (defun fcntl-owner (fd)
1999 (with-c-constants (:fcntl)
2000 (%fcntl-int fd f-getown)))
2001 (defun (setf fcntl-owner) (val fd)
2002 (with-c-constants (:fcntl)
2003 (setf (%fcntl-int fd f-setown) val)))
2004
2005 (defun fcntl-closem (fd)
2006 (with-c-constants (:fcntl)
2007 (%fcntl-int fd f-closem)))
2008
2009 (defun fcntl-maxfd ()
2010 (with-c-constants (:fcntl)
2011 (%fcntl-int -1 f-maxfd)))
2012
2013
2014
2015 (ffi:clines "
2016
2017 /* So we can store a universal sockaddr variant to support multiple families */
2018 typedef struct usockaddr {
2019 union {
2020 struct sockaddr sockaddr;
2021 struct sockaddr_in sockaddr_in;
2022 struct sockaddr_in6 sockaddr_in6;
2023 struct sockaddr_un sockaddr_un;
2024 } u;
2025 } usockaddr_t;
2026 #define ss_family u.sockaddr.sa_family
2027 #define ss_len u.sockaddr.sa_len
2028
2029 struct u_af_info {
2030 size_t sock_length;
2031 size_t addr_length;
2032 size_t port_offset;
2033 size_t addr_offset;
2034 };
2035
2036 static struct u_af_info **u_afi = NULL, *u_afi_i = NULL;
2037
2038 /*
2039 * Note that the following macros should only be used after calling
2040 * u_afi_init(), since they require the u_afi array to previously have
2041 * been initialized. Moreover, the family of an address must have been
2042 * set for those macros to work, except for USOCKADDR_FAMILY() and
2043 * USOCKADDR().
2044 */
2045
2046 /* Returns pointer to family of address */
2047 #define USOCKADDR_FAMILY(s) \\
2048 ((sa_family_t *)(&(s)->ss_family))
2049
2050 /* Returns length of sockaddr-style address */
2051 #define USOCKADDR_SOCKLEN(s) \\
2052 (u_afi[(int)(s)->ss_family]->sock_length)
2053
2054 /* Returns length of internal address */
2055 #define USOCKADDR_ADDRLEN(s) \\
2056 (u_afi[(int)(s)->ss_family]->addr_length)
2057
2058 /* Returns pointer to port of address */
2059 #define USOCKADDR_PORT(s) \\
2060 ((in_port_t *)(((char *)s) + u_afi[(int)(s)->ss_family]->port_offset))
2061
2062 /* Returns pointer to family-specific address */
2063 #define USOCKADDR_ADDRESS(s) \\
2064 ((void *)(((char *)s) + u_afi[(int)(s)->ss_family]->addr_offset))
2065
2066 /* Returns struct sockaddr family-independent pointer */
2067 #define USOCKADDR(s) \\
2068 (&((s)->u.sockaddr))
2069
2070 static void
2071 u_afi_init(void)
2072 {
2073 int i, limit;
2074 struct sockaddr_in sin;
2075 struct sockaddr_in6 sin6;
2076 struct sockaddr_un sun;
2077
2078 /*
2079 * Initialize address family info lookup table.
2080 * This is used to optimize USOCKADDR*() macros.
2081 */
2082 limit = 0;
2083 if (limit < AF_INET)
2084 limit = AF_INET;
2085 if (limit < AF_INET6)
2086 limit = AF_INET6;
2087 if (limit < AF_LOCAL)
2088 limit = AF_LOCAL;
2089 limit++;
2090
2091 u_afi_i = malloc(sizeof(struct u_af_info) * 3);
2092 u_afi = malloc(sizeof(struct u_af_info *) * limit);
2093
2094 /* AF_INET */
2095 u_afi_i[0].sock_length = sizeof(struct sockaddr_in);
2096 u_afi_i[0].addr_length = sizeof(struct in_addr);
2097 u_afi_i[0].port_offset = (long)&sin.sin_port - (long)&sin;
2098 u_afi_i[0].addr_offset = (long)&sin.sin_addr - (long)&sin;
2099 /* AF_INET6 */
2100 u_afi_i[1].sock_length = sizeof(struct sockaddr_in6);
2101 u_afi_i[1].addr_length = sizeof(struct in6_addr);
2102 u_afi_i[1].port_offset = (long)&sin6.sin6_port - (long)&sin6;
2103 u_afi_i[1].addr_offset = (long)&sin6.sin6_addr - (long)&sin6;
2104 /* AF_LOCAL */
2105 u_afi_i[2].sock_length = sizeof(struct sockaddr_un);
2106 u_afi_i[2].addr_length = sizeof(sun.sun_path);
2107 u_afi_i[2].port_offset = 0; /* Invalid */
2108 u_afi_i[2].addr_offset = (long)&sun.sun_path - (long)&sun;
2109
2110 for (i = 0; i < limit; i++)
2111 u_afi[i] = NULL;
2112 u_afi[AF_INET] = &u_afi_i[0];
2113 u_afi[AF_INET6] = &u_afi_i[1];
2114 u_afi[AF_LOCAL] = &u_afi_i[2];
2115 }
2116
2117 /* XXX Should we use ECL foreign allocation functions instead? */
2118 static usockaddr_t *
2119 usockaddr_create(void)
2120 {
2121 usockaddr_t *sa = calloc(1, sizeof(usockaddr_t));
2122
2123 /* Set a default family so that our USOCKADDR_* macros work */
2124 sa->ss_family = AF_INET;
2125 /* Also set a proper address size */
2126 sa->ss_len = sizeof(struct sockaddr_in);
2127
2128 return sa;
2129 }
2130
2131 static void
2132 usockaddr_destroy(usockaddr_t *a)
2133 {
2134
2135 free(a);
2136 }
2137
2138 /*
2139 * XXX Although the following are useful, unless I can register an EQUALP
2140 * method using usockaddr_cmp(), I'd have to provide my own hashing library...
2141 * Common Lisp does not allow other predicates than the built-in ones for
2142 * MAKE-HASH-TABLE, and also doesn't provide those predicates as generic
2143 * functions :(
2144 * Perhaps that I could hack in a custom ECL-specific EQUALP hook though?
2145 * At worse, it may be used with custom hash table implementations.
2146 */
2147
2148 /* ARGSUSED */
2149 static uint32_t
2150 usockaddr_hash(const void *d, size_t len)
2151 {
2152 const usockaddr_t *sa = d;
2153 uint32_t hash = 0, *words;
2154 uint8_t *c;
2155
2156 switch (sa->ss_family) {
2157 case AF_INET:
2158 hash = (uint32_t)sa->u.sockaddr_in.sin_addr.s_addr;
2159 break;
2160 case AF_INET6:
2161 words = (uint32_t *)&sa->u.sockaddr_in6.sin6_addr;
2162 hash = words[0] + (67306411U * hash);
2163 hash = words[1] + (67306411U * hash);
2164 hash = words[2] + (67306411U * hash);
2165 hash = words[3] + (67306411U * hash);
2166 break;
2167 case AF_LOCAL:
2168 for (c = (uint8_t *)sa->u.sockaddr_un.sun_path;
2169 *c != '\0'; c++)
2170 hash = *c + (31 * hash);
2171 break;
2172 default:
2173 hash = 0xdeadbeef;
2174 }
2175
2176 return hash;
2177 }
2178
2179 /* ARGSUSED */
2180 static int
2181 usockaddr_cmp(const void *s, const void *d, size_t len)
2182 {
2183 const usockaddr_t *sa = s, *da = d;
2184 uint32_t *sawords, *dawords;
2185
2186 if (sa->ss_family != da->ss_family)
2187 return -1;
2188
2189 switch (sa->ss_family) {
2190 case AF_INET:
2191 if (sa->u.sockaddr_in.sin_addr.s_addr !=
2192 da->u.sockaddr_in.sin_addr.s_addr)
2193 return -1;
2194 break;
2195 case AF_INET6:
2196 sawords = (uint32_t *)&sa->u.sockaddr_in6.sin6_addr;
2197 dawords = (uint32_t *)&da->u.sockaddr_in6.sin6_addr;
2198 if (sawords[0] != dawords[0] || sawords[1] != dawords[1] ||
2199 sawords[2] != dawords[2] || sawords[3] != dawords[3])
2200 return -1;
2201 break;
2202 case AF_LOCAL:
2203 return strcmp(sa->u.sockaddr_un.sun_path,
2204 da->u.sockaddr_un.sun_path);
2205 break;
2206 default:
2207 return -1;
2208 }
2209
2210 return 0;
2211 }
2212
2213 /*
2214 * Allows C code to access 8-bit BASE-CHAR and byte vectors.
2215 */
2216 static void *
2217 vector8_pointer(cl_object v, size_t offset, size_t size)
2218 {
2219 bool valid = false;
2220
2221 size += offset;
2222 switch (type_of(v)) {
2223 case t_base_string:
2224 valid = (size <= v->base_string.dim);
2225 break;
2226 case t_vector:
2227 switch (v->vector.elttype) {
2228 case aet_b8:
2229 case aet_i8:
2230 case aet_bc:
2231 valid = (size <= v->vector.dim);
2232 break;
2233 }
2234 break;
2235 }
2236
2237 return (valid ? (&((uint8_t *)v->vector.self.t)[offset]): NULL);
2238 }
2239
2240 ")
2241
2242 ;;; XXX Initialization code
2243 (defun %address-init ()
2244 (ffi:c-inline () () :void "u_afi_init()" :one-liner t)
2245 nil)
2246 (%address-init)
2247
2248 (defmacro mapcase (key otherwise &rest pairs)
2249 "Similar to CASE yet simpler, this can work with non-literals without
2250 the need for the #. reader-macro. KEY is evaluated once and stored to
2251 a temporary variable, which is then tested using EQL against every first
2252 element of PAIRS list (evaluated), which if matches causes the second
2253 element of the corresponding list to be returned. If no match is found,
2254 returns OTHERWISE."
2255 (let ((%key (gensym)))
2256 `(let ((,%key ,key))
2257 (cond ,@(mapcar #'(lambda (pair)
2258 `((eql ,%key ,(first pair)) ,(second pair)))
2259 pairs)
2260 (t ,otherwise)))))
2261
2262 (defstruct (address
2263 (:constructor %make-address)
2264 (:print-object
2265 (lambda (addr stream)
2266 (print-unreadable-object (addr stream :type t :identity t)
2267 (if (address-pointer addr)
2268 (prin1 `(:family ,(with-c-constants (:sys-socket)
2269 (mapcase (address-family addr)
2270 'unknown
2271 (pf-inet 'pf-inet)
2272 (pf-inet6 'pf-inet6)
2273 (pf-local 'pf-local)))
2274 :address ,(address-address addr)
2275 :port ,(address-port addr))
2276 stream)
2277 (prin1 `(:pointer nil) stream))))))
2278 "A network address. Supports AF_INET, AF_INET6 and AF_LOCAL.
2279 Can be created using MAKE-ADDRESS and destroyed using DESTROY-ADDRESS."
2280 pointer)
2281
2282 (defun make-address (&key
2283 (address "127.0.0.1")
2284 (port 0)
2285 no-signal)
2286 "Creates a new network address object. ADDRESS (defaults to
2287 127.0.0.1) and PORT (defaults to 0) but may be specified.
2288 Returns the new network address on success, which should be explicitely
2289 destroyed later using DESTROY-ADDRESS. On failure, signals a condition of
2290 type UNIX-ERROR unless NO-SIGNAL, in which case it returns NIL."
2291 (let ((addr (%make-address :pointer (c-inline2 () () :pointer-void
2292 "usockaddr_create()"
2293 :one-liner t))))
2294 (handler-case
2295 (setf (address-address addr) address
2296 (address-port addr) port)
2297 (unix-error (condition)
2298 (destroy-address addr)
2299 (setf addr nil)
2300 (unless no-signal
2301 (error condition))))
2302 addr))
2303
2304 (defun destroy-address (address)
2305 "Destroys a network address. Unless this is done, resources will be leaked."
2306 (check-type address address)
2307 (when (address-pointer address)
2308 (c-inline2 ((address-pointer address)) (:pointer-void) :void
2309 "usockaddr_destroy(#0)" :one-liner t)
2310 (setf (address-pointer address) nil)))
2311
2312 (defun address-hash (address)
2313 "Efficiently returns an integer hash of the address part of ADDRESS."
2314 (check-type address address)
2315 (c-inline2 ((address-pointer address))
2316 (:pointer-void)
2317 :uint32-t
2318 "usockaddr_hash(#0, 0)" :one-liner t))
2319
2320 (defun address-eql (address1 address2)
2321 "Efficiently verifies if the address part of ADDRESS1 and ADDRESS2 are
2322 equal."
2323 (check-type address1 address)
2324 (check-type address2 address)
2325 (if (= 0 (c-inline2 ((address-pointer address1) (address-pointer address2))
2326 (:pointer-void :pointer-void)
2327 :int
2328 "usockaddr_cmp(#0, #1, 0)" :one-liner t))
2329 t
2330 nil))
2331
2332 (defun address-address (address)
2333 "Returns a string consisting of the address bound to ADDRESS."
2334 (check-type address address)
2335 (c-inline2 ((address-pointer address))
2336 (:pointer-void)
2337 :cstring
2338 "
2339 {
2340 const usockaddr_t *a = (usockaddr_t *)#0;
2341 char buf[256];
2342
2343 if (*(USOCKADDR_FAMILY(a)) == AF_LOCAL)
2344 @(return) = USOCKADDR_ADDRESS(a);
2345 else
2346 @(return) = inet_ntop(*(USOCKADDR_FAMILY(a)),
2347 USOCKADDR_ADDRESS(a), buf, 255);
2348 }" :one-liner nil))
2349
2350 (defun (setf address-address) (address-string address)
2351 "Permits to bind a new address to ADDRESS. Several address families
2352 are supported; If the address contains a '/', assume AF_LOCAL.
2353 If it contains ':', assume AF_INET6. Otherwise, assume AF_INET.
2354 A condition of type UNIX-ERROR may be signaled on error."
2355 (check-type address address)
2356 (check-type address-string string)
2357 (with-c-constants (:errno :sys-socket)
2358 (let* ((family (cond ((find #\/ address-string)
2359 af-local)
2360 ((find #\: address-string)
2361 af-inet6)
2362 (t af-inet)))
2363 (ret (c-inline2 ((address-pointer address) address-string family)
2364 (:pointer-void :cstring :int)
2365 :int
2366 "
2367 {
2368 usockaddr_t *a = (usockaddr_t *)#0;
2369 char *str = #1;
2370 int family = #2;
2371 int ret = 1;
2372
2373 *(USOCKADDR_FAMILY(a)) = family;
2374 a->ss_len = USOCKADDR_SOCKLEN(a);
2375 if (family == AF_LOCAL)
2376 strncpy(USOCKADDR_ADDRESS(a), str, 100);
2377 else
2378 ret = inet_pton(family, str, USOCKADDR_ADDRESS(a));
2379
2380 @(return) = ret;
2381 }" :one-liner nil)))
2382 (case ret
2383 (1 t)
2384 (0 (unix-error "(setf address-address)"
2385 EADDRNOTAVAIL
2386 `(,address ,address-string)))
2387 (otherwise (unix-error "(setf address-address)"
2388 (errno)
2389 `(,address ,address-string)))))))
2390
2391 (defun hostname<-address (address)
2392 "Resolves an address, returning a hostname string, or signaling a condition
2393 of type GAI-ERROR on failure."
2394 (check-type address address)
2395 (multiple-value-bind (hostname err)
2396 (c-inline2 ((address-pointer address))
2397 (:pointer-void)
2398 (values :cstring :int)
2399 "
2400 {
2401 const usockaddr_t *a = (usockaddr_t *)#0;
2402 int err = 0;
2403 char buf[NI_MAXHOST];
2404
2405 *buf = '\0';
2406 ecl_disable_interrupts();
2407 err = getnameinfo(USOCKADDR(a), USOCKADDR_SOCKLEN(a),
2408 buf, NI_MAXHOST - 1, NULL, 0, 0);
2409 ecl_enable_interrupts();
2410
2411 @(return 0) = buf;
2412 @(return 1) = err;
2413 }" :one-liner nil)
2414 (if (= 0 err)
2415 hostname
2416 ;;; getnameinfo(3) doesn't return errno but another system!
2417 (gai-error "getnameinfo" err `(,address)))))
2418
2419 ;;; XXX To resolve a hostname to an address using getaddrinfo(3)
2420 (defun address<-hostname (hostname)
2421 (check-type hostname string)
2422 nil)
2423
2424 (defun address-family (address)
2425 "Returns the current address family of ADDRESS. This may change if a
2426 new address is assigned to ADDRESS using (SETF ADDRESS-ADDRESS)."
2427 (check-type address address)
2428 (c-inline2 ((address-pointer address)) (:pointer-void) :uint8-t
2429 "
2430 {
2431 const usockaddr_t *a = (usockaddr_t *)#0;
2432
2433 @(return) = *(USOCKADDR_FAMILY(a));
2434 }" :one-liner nil))
2435
2436 (defun address-port (address)
2437 "Returns the numeric IP port of ADDRESS.
2438 For AF_LOCAL addresses, always returns 0."
2439 (check-type address address)
2440 (c-inline2 ((address-pointer address))
2441 (:pointer-void)
2442 :uint16-t
2443 "
2444 {
2445 const usockaddr_t *a = (usockaddr_t *)#0;
2446 uint16_t r = 0;
2447
2448 if (*(USOCKADDR_FAMILY(a)) != AF_LOCAL)
2449 r = ntohs(*(USOCKADDR_PORT(a)));
2450
2451 @(return) = r;
2452 }" :one-liner nil))
2453
2454 (defun (setf address-port) (port address)
2455 "Allows to set the IP port of ADDRESS to PORT.
2456 Has no effect on AF_LOCAL sockets."
2457 (check-type address address)
2458 (check-type port (integer 0 #xFFFF))
2459 (c-inline2 ((address-pointer address) port)
2460 (:pointer-void :uint16-t)
2461 :void
2462 "
2463 {
2464 usockaddr_t *a = (usockaddr_t *)#0;
2465
2466 if (*(USOCKADDR_FAMILY(a)) != AF_LOCAL)
2467 *(USOCKADDR_PORT(a)) = htons(#1);
2468 }" :one-liner nil))
2469
2470 (defun address-hash (address)
2471 "Efficient hashing function for use on ADDRESS objects.
2472 Returns a FIXNUM, which may or may not be unique, but which is suitable
2473 for use in hash table buckets. Note that only the address is taken into
2474 consideration, not the port. Multiple address families are supported."
2475 (check-type address address)
2476 (c-inline2 ((address-pointer address))
2477 (:pointer-void)
2478 :fixnum
2479 "usockaddr_hash(#0, 0)" :one-liner t))
2480
2481 (defun address-equal (address1 address2)
2482 "Efficient address comparison function for use with hash tables.
2483 Returns T if both address objects hold the same address, or NIL.
2484 The port is ignored. Multiple address families are supported."
2485 (check-type address1 address)
2486 (check-type address2 address)
2487 (let ((ret (c-inline2 ((address-pointer address1)
2488 (address-pointer address2))
2489 (:pointer-void :pointer-void)
2490 :int
2491 "usockaddr_cmp(#0, #1, 0)" :one-liner t)))
2492 (if (= 0 ret)
2493 t
2494 nil)))
2495
2496 (defun bind (fd address)
2497 "Invokes bind(2) on FD with ADDRESS. Returns NIL on success or signals a
2498 condition of type UNIX-ERROR on failure."
2499 (check-type address address)
2500 (multiple-value-bind (ret err)
2501 (c-inline2 (fd (address-pointer address))
2502 (:int :pointer-void)
2503 (values :int :int)
2504 "
2505 {
2506 usockaddr_t *a = (usockaddr_t *)#1;
2507 int fd = #0, err = 0, ret;
2508
2509 if ((ret = bind(fd, USOCKADDR(a), USOCKADDR_SOCKLEN(a)) == -1))
2510 err = errno;
2511
2512 @(return 0) = ret;
2513 @(return 1) = err;
2514 }" :one-liner nil)
2515 (if (= 0 ret)
2516 nil
2517 (unix-error "bind" err `(,fd ,address)))))
2518
2519 (defsyscall0 (listen-fd "listen") (:int :int)
2520 "Invokes listen(2) with FD and BACKLOG.")
2521
2522 (defun accept (fd address &optional no-signal)
2523 "Invokes accept(2) on FD and stores the client's address in ADDRESS.
2524 Returns the new client socket descriptor on success, or signals an error
2525 of type UNIX-ERROR on failure, unless NO-SIGNAL, in which case two values
2526 are returned: -1 as file descriptor and errno."
2527 (check-type address address)
2528 (multiple-value-bind (ret err)
2529 (c-inline2 (fd (address-pointer address))
2530 (:int :pointer-void)
2531 (values :int :int)
2532 "
2533 {
2534 usockaddr_t *a = (usockaddr_t *)#1;
2535 socklen_t slen;
2536 int fd = #0, ret, err = 0;
2537
2538 slen = USOCKADDR_SOCKLEN(a);
2539 if ((ret = accept(fd, USOCKADDR(a), &slen)) == -1)
2540 err = errno;
2541
2542 @(return 0) = ret;
2543 @(return 1) = err;
2544 }" :one-liner nil)
2545 (if (= -1 ret)
2546 (if no-signal
2547 (values ret err)
2548 (unix-error "accept" err `(,fd ,address)))
2549 ret)))
2550
2551 (defun connect (fd address &optional no-signal)
2552 "Invokes connect(2) on FD to ADDRESS. Returns NIL on success, or
2553 signals a condition of type UNIX-ERROR on failure, unless NO-SIGNAL,
2554 in which case two values are returned: -1 and errno."
2555 (check-type address address)
2556 (multiple-value-bind (ret err)
2557 (c-inline2 (fd (address-pointer address))
2558 (:int :pointer-void)
2559 (values :int :int)
2560 "
2561 {
2562 usockaddr_t *a = (usockaddr_t *)#1;
2563 int fd = #0, ret, err = 0;
2564
2565 if ((ret = connect(fd, USOCKADDR(a), USOCKADDR_SOCKLEN(a))) == -1)
2566 err = errno;
2567
2568 @(return 0) = ret;
2569 @(return 1) = err;
2570 }" :one-liner nil)
2571 (if (= -1 ret)
2572 (if no-signal
2573 (values ret err)
2574 (unix-error "connect" err `(,fd ,address)))
2575 nil)))
2576
2577 (defun read-fd (fd vector bytes &key no-signal (start 0))
2578 "Invokes read(2), attempting to read BYTES bytes from FD into VECTOR at
2579 offset START (defaulting to 0), which must have an element-size of 8-bit.
2580 Returns the number of bytes read, 0 for EOF, or signals a condition of type
2581 UNIX-ERROR on error, unless NO-SIGNAL in which case it returns -1 as the
2582 first value and errno as the second one."
2583 (multiple-value-bind (ret err)
2584 (c-inline2 (fd vector start bytes)
2585 (:int :object :size-t :size-t)
2586 (values :ssize-t :int)
2587 "
2588 {
2589 size_t bytes = #3;
2590 ssize_t ret;
2591 int err = 0;
2592 void *buf;
2593
2594 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2595 ret = -1;
2596 err = ERANGE;
2597 } else if ((ret = read(#0, buf, bytes)) == -1)
2598 err = errno;
2599
2600 @(return 0) = ret;
2601 @(return 1) = err;
2602 }" :one-liner nil)
2603 (if (> ret -1)
2604 ret
2605 (if no-signal
2606 (values ret err)
2607 (unix-error "read" err `(,fd ,vector ,start ,bytes))))))
2608
2609 (defun write-fd (fd vector bytes &key no-signal (start 0))
2610 "Invokes write(2), attempting to write BYTES bytes to FD from VECTOR at
2611 offset START (defaulting to 0), which must have an element-size of 8-bit.
2612 Returns the number of bytes written or signals a condition of type
2613 UNIX-ERROR on error, unless NO-SIGNAL in which case it returns -1 as the
2614 first value and errno as the second one."
2615 (multiple-value-bind (ret err)
2616 (c-inline2 (fd vector start bytes)
2617 (:int :object :size-t :size-t)
2618 (values :ssize-t :int)
2619 "
2620 {
2621 size_t bytes = #3;
2622 ssize_t ret;
2623 int err = 0;
2624 void *buf;
2625
2626 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2627 ret = -1;
2628 err = ERANGE;
2629 } else if ((ret = write(#0, buf, bytes)) == -1)
2630 err = errno;
2631
2632 @(return 0) = ret;
2633 @(return 1) = err;
2634 }" :one-liner nil)
2635 (if (> ret -1)
2636 ret
2637 (if no-signal
2638 (values ret err)
2639 (unix-error "write" err `(,fd ,vector ,start ,bytes))))))
2640
2641 (defsyscall1 (:off-t lseek "lseek" :no-signal) (:int :off-t :int)
2642 "Invokes lseek(2) on FD with OFFSET and WHENCE.
2643 On success, returns the new integer offset.")
2644
2645 (defun recv (fd vector bytes flags &key no-signal (start 0))
2646 "Invokes recv(2), attempting to read BYTES bytes from FD into VECTOR at
2647 offset START (defaulting to 0), which must have an element-size of 8-bit.
2648 Returns the number of bytes read or signals a condition of type UNIX-ERROR
2649 on error, unless NO-SIGNAL in which case it returns -1 as the first value
2650 and errno as the second one."
2651 (multiple-value-bind (ret err)
2652 (c-inline2 (fd vector start bytes flags)
2653 (:int :object :size-t :size-t :int)
2654 (values :ssize-t :int)
2655 "
2656 {
2657 size_t bytes = #3;
2658 ssize_t ret;
2659 int err = 0;
2660 void *buf;
2661
2662 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2663 ret = -1;
2664 err = ERANGE;
2665 } else if ((ret = recv(#0, buf, bytes, #4)) == -1)
2666 err = errno;
2667
2668 @(return 0) = ret;
2669 @(return 1) = err;
2670 }" :one-liner nil)
2671 (if (> ret -1)
2672 ret
2673 (if no-signal
2674 (values ret err)
2675 (unix-error "recv" err `(,fd ,vector ,start ,bytes ,flags))))))
2676
2677 ;;; XXX Test
2678 (defun recvfrom (fd vector bytes flags address &key no-signal (start 0))
2679 "Invokes recvfrom(2), attempting to read BYTES bytes from FD into VECTOR at
2680 offset START (defaulting to 0), which must have an element-size of 8-bit.
2681 FLAGS are the ORed optional flags and ADDRESS the recipient address.
2682 Returns the number of bytes read or signals a condition of type UNIX-ERROR
2683 on error, unless NO-SIGNAL in which case it returns -1 as the first value
2684 and errno as the second one."
2685 (check-type address address)
2686 (multiple-value-bind (ret err)
2687 (c-inline2 (fd vector start bytes flags (address-pointer address))
2688 (:int :object :size-t :size-t :int :pointer-void)
2689 (values :ssize-t :int)
2690 "
2691 {
2692 usockaddr_t *a = (usockaddr_t *)#5;
2693 socklen_t slen;
2694 size_t bytes = #3;
2695 ssize_t ret;
2696 int err = 0;
2697 void *buf;
2698
2699 slen = USOCKADDR_SOCKLEN(a);
2700 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2701 ret = -1;
2702 err = ERANGE;
2703 } else if ((ret = recvfrom(#0, buf, bytes, #4, USOCKADDR(a), &slen))
2704 == -1)
2705 err = errno;
2706
2707 @(return 0) = ret;
2708 @(return 1) = err;
2709 }" :one-liner nil)
2710 (if (> ret -1)
2711 ret
2712 (if no-signal
2713 (values ret err)
2714 (unix-error "recvfrom" err
2715 `(,fd ,vector ,start ,bytes ,flags ,address))))))
2716
2717 (defun send (fd vector bytes flags &key no-signal (start 0))
2718 "Invokes send(2), attempting to write BYTES bytes to FD from VECTOR at
2719 offset START (defaulting to 0), which must have an element-size of 8-bit.
2720 Returns the number of bytes written or signals a condition of type
2721 UNIX-ERROR on error, unless NO-SIGNAL in which case it returns -1 as the
2722 first value and errno as the second one."
2723 (multiple-value-bind (ret err)
2724 (c-inline2 (fd vector start bytes flags)
2725 (:int :object :size-t :size-t :int)
2726 (values :ssize-t :int)
2727 "
2728 {
2729 size_t bytes = #3;
2730 ssize_t ret;
2731 int err = 0;
2732 void *buf;
2733
2734 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2735 ret = -1;
2736 err = ERANGE;
2737 } else if ((ret = send(#0, buf, bytes, #4)) == -1)
2738 err = errno;
2739
2740 @(return 0) = ret;
2741 @(return 1) = err;
2742 }" :one-liner nil)
2743 (if (> ret -1)
2744 ret
2745 (if no-signal
2746 (values ret err)
2747 (unix-error "send" err `(,fd ,vector ,start ,bytes ,flags))))))
2748
2749 ;;; XXX Test
2750 (defun sendto (fd vector bytes flags address &key no-signal (start 0))
2751 "Invokes sendto(2), attempting to write BYTES bytes to FD from VECTOR at
2752 offset START (defaulting to 0), which must have an element-size of 8-bit.
2753 FLAGS are optional ORed flags and ADDRESS is the destination address.
2754 Returns the number of bytes written or signals a condition of type
2755 UNIX-ERROR on error, unless NO-SIGNAL in which case it reutrns -1 as the
2756 first value and an errno as the second one."
2757 (check-type address address)
2758 (multiple-value-bind (ret err)
2759 (c-inline2 (fd vector start bytes flags (address-pointer address))
2760 (:int :object :size-t :size-t :int :pointer-void)
2761 (values :ssize-t :int)
2762 "
2763 {
2764 usockaddr_t *a = (usockaddr_t *)#5;
2765 size_t bytes = #3;
2766 ssize_t ret;
2767 int err = 0;
2768 void *buf;
2769
2770 if ((buf = vector8_pointer(#1, #2, bytes)) == NULL) {
2771 ret = -1;
2772 err = ERANGE;
2773 } else if ((ret = sendto(#0, buf, bytes, #4, USOCKADDR(a),
2774 USOCKADDR_SOCKLEN(a))) == -1)
2775 err = errno;
2776
2777 @(return 0) = ret;
2778 @(return 1) = err;
2779 }" :one-liner nil)
2780 (if (> ret -1)
2781 ret
2782 (if no-signal
2783 (values ret err)
2784 (unix-error "sendto" err
2785 `(,fd ,vector ,start ,bytes ,flags ,address))))))
2786
2787 ;;; XXX recvmsg/sendmsg
2788
2789
2790 (defun exit (status)
2791 "Invokes exit(3) with STATUS. Note that this may not be friendly to your
2792 environment depending. Also note the difference between exit(3) and _exit(2)."
2793 (c-inline2 (status) (:int) :void "exit(#0)" :one-liner t))
2794
2795 (defun _exit (status)
2796 "Invokes _exit(2) with STATUS. This may not be friendly to your environment.
2797 Also note the difference between exit(3) and _exit(2)."
2798 (c-inline2 (status) (:int) :void "_exit(#0)" :one-liner t))
2799
2800 (defsyscall1 (:int fork "fork" :no-signal) ()
2801 "Invokes fork(2). On success, the new PID is returned in the parent,
2802 0 is returned in the child.")
2803
2804 (defsyscall1 (:int vfork "vfork" :no-signal) ()
2805 "Invokes vfork(2). On success, the new PID is returned in the parent,
2806 0 is returned in the child.")
2807
2808 (defsyscall1 (:pid-t setsid "setsid" :no-signal) ()
2809 "Invokes setsid(2) returning the new process group on success.")
2810
2811 (defsyscall0 (chroot "chroot" :no-signal) (:cstring)
2812 "Invokes chroot(2) with PATH.")
2813
2814 (defsyscall0 (fchroot "fchroot" :no-signal) (:int)
2815 "Invokes fchroot(2) with FD.")
2816
2817 (defun execve (path argv &optional envp)
2818 "Invokes execve(2) with PATH, ARGV sequence and optional ENVP sequence.
2819 This function usually doesn't return, unless an error occurs, in which case
2820 it returns the errno value, and the process should exit with _exit(2).
2821 A condition of type UNIX-ERROR is signaled if invalid arguments are suppled."
2822 (flet ((check-seq (seq)
2823 (check-type seq sequence)
2824 (map 'list #'(lambda (e)
2825 (check-type e string))
2826 seq)))
2827 (handler-case
2828 (progn
2829 (check-seq argv)
2830 (when envp
2831 (check-seq envp)))
2832 (type-error ()
2833 (with-c-constants (:errno)
2834 (unix-error "execve" einval `(,path ,argv ,envp)))))
2835 (c-inline2 (path argv envp)
2836 (:cstring :object :object)
2837 :int
2838 "
2839 {
2840 cl_object argv_seq = #1, envp_seq = #2;
2841 char **argv = NULL, **envp = NULL;
2842 int i, l;
2843
2844 l = ecl_length(argv_seq);
2845 argv = malloc(sizeof(char *) * (l + 1));
2846 for (i = 0; i < l; i++)
2847 argv[i] = ecl_base_string_pointer_safe(
2848 si_copy_to_simple_base_string(ecl_elt(argv_seq, i)));
2849 argv[i] = NULL;
2850
2851 if (envp_seq != Cnil) {
2852 l = ecl_length(envp_seq);
2853 envp = malloc(sizeof(char *) * (l + 1));
2854 for (i = 0; i < l; i++)
2855 envp[i] = ecl_base_string_pointer_safe(
2856 si_copy_to_simple_base_string(
2857 ecl_elt(envp_seq, i)));
2858 envp[i] = NULL;
2859 }
2860
2861 if (execve(#0, argv, envp) == -1)
2862 @(return) = errno;
2863 else
2864 @(return) = 0;
2865
2866 if (argv != NULL)
2867 free(argv);
2868 if (envp != NULL)
2869 free(envp);
2870 }" :one-liner nil)))
2871
2872
2873 (defsyscall0 (flock "flock" :no-signal) (:int :int)
2874 "Invokes flock(2) on FD with OPERATION,")
2875
2876 (defun timeofday ()
2877 "Invokes gettimeofday(2) and returns a TIMEVAL object, or signals a condition
2878 of type UNIX-ERROR on error."
2879 (multiple-value-bind (ret err)
2880 (c-inline2 ()
2881 ()
2882 (values :object :int)
2883 "
2884 {
2885 struct timeval tv;
2886 cl_object ret = Cnil;
2887 int err = 0;
2888
2889 if (gettimeofday(&tv, NULL) == -1)
2890 err = errno;
2891 else
2892 ret = fill_timeval_structure(&tv);
2893
2894 @(return 0) = ret;
2895 @(return 1) = err;
2896 }" :one-liner nil)
2897 (if ret
2898 ret
2899 (unix-error "gettimeofday" err))))
2900
2901 (defun (setf timeofday) (tv)
2902 "Invokes settimeofday(2) and returns TV on success, or signals a condition
2903 of type UNIX-ERROR."
2904 (check-type tv timeval)
2905 (let ((err (c-inline2 (tv)
2906 (:object)
2907 :int
2908 "
2909 {
2910 struct timeval tv;
2911 int err = 0;
2912
2913 fill_timeval_c_structure(&tv, #0);
2914 if (settimeofday(&tv, NULL) == -1)
2915 err = errno;
2916
2917 @(return) = err;
2918 }" :one-liner nil)))
2919 (if (= 0 err)
2920 tv
2921 (unix-error "settimeofday" err `(,tv)))))
2922
2923
2924
2925 (ffi:clines "
2926 #include <sys/resource.h>
2927 ")
2928
2929 (define-c-structure rusage "struct rusage"
2930 (utime :timeval "ru_utime")
2931 (stime :timeval "ru_stime")
2932 (maxrss :long "ru_maxrss")
2933 (ixrss :long "ru_ixrss")
2934 (idrss :long "ru_idrss")
2935 (isrss :long "ru_isrss")
2936 (minflt :long "ru_minflt")
2937 (majflt :long "ru_majflt")
2938 (nswap :long "ru_nswap")
2939 (inblock :long "ru_inblock")
2940 (oublock :long "ru_oublock")
2941 (msgsnd :long "ru_msgsnd")
2942 (msgrcv :long "ru_msgrcv")
2943 (nsignals :long "ru_nsignals")
2944 (nvcsw :long "ru_nvcsw")
2945 (nivcsw :long "ru_nivcsw"))
2946 (define-c-cl-structure rusage)
2947 (define-c-structure-serializer rusage)
2948
2949 (define-c-constants :sys-resource "sys/resource.h"
2950 (rusage-self "RUSAGE_SELF")
2951 (rusage-children "RUSAGE_CHILDREN")
2952 (rlimit-as "RLIMIT_AS")
2953 (rlimit-core "RLIMIT_CORE")
2954 (rlimit-cpu "RLIMIT_CPU")
2955 (rlimit-data "RLIMIT_DATA")
2956 (rlimit-fsize "RLIMIT_FSIZE")
2957 (rlimit-memlock "RLIMIT_MEMLOCK")
2958 (rlimit-nofile "RLIMIT_NOFILE")
2959 (rlimit-nproc "RLIMIT_NPROC")
2960 (rlimit-rss "RLIMIT_RSS")
2961 (rlimit-sbsize "RLIMIT_SBSIZE")
2962 (rlimit-stack "RLIMIT_STACK")
2963 (prio-process "PRIO_PROCESS")
2964 (prio-pgrp "PRIO_PGRP")
2965 (prio-user "PRIO_USER"))
2966
2967 (defun getrusage (who)
2968 "Invokes getrusage(2) returning a filled structure of type RUSAGE or signals
2969 a condition of type UNIX-ERROR on error."
2970 (multiple-value-bind (ret err)
2971 (c-inline2 (who)
2972 (:int)
2973 (values :object :int)
2974 "
2975 {
2976 struct rusage ru;
2977 cl_object ret = Cnil;
2978 int err = 0;
2979
2980 if (getrusage(#0, &ru) == -1)
2981 err = errno;
2982 else
2983 ret = fill_rusage_structure(&ru);
2984
2985 @(return 0) = ret;
2986 @(return 1) = err;
2987 }" :one-liner nil)
2988 (if ret
2989 ret
2990 (unix-error "getrusage" err `(,who)))))
2991
2992 (define-c-structure rlimit "struct rlimit"
2993 (cur :rlim-t "rlim_cur")
2994 (max :rlim-t "rlim_max"))
2995 (define-c-cl-structure rlimit)
2996 (define-c-structure-serializer rlimit)
2997 (define-to-c-structure-serializer rlimit)
2998
2999 (defun rlimit (resource)
3000 "Invokes getrlimit(2) with RESOURCE and returns an RLIMIT object, or
3001 signals a condition of type UNIX-ERROR on error."
3002 (multiple-value-bind (ret err)
3003 (c-inline2 (resource)
3004 (:int)
3005 (values :object :int)
3006 "
3007 {
3008 struct rlimit rlp;
3009 cl_object ret = Cnil;
3010 int err = 0;
3011
3012 if (getrlimit(#0, &rlp) == -1)
3013 err = errno;
3014 else
3015 ret = fill_rlimit_structure(&rlp);
3016
3017 @(return 0) = ret;
3018 @(return 1) = err;
3019 }" :one-liner nil)
3020 (if ret
3021 ret
3022 (unix-error "getrlimit" err `(,resource)))))
3023
3024 (defun (setf rlimit) (rlimit resource)
3025 "Invoke setrlimit(2) with RESOURCE and RLIMIT.
3026 Returns RLIMIT on success, or signals a condition of type UNIX-ERROR."
3027 (check-type rlimit rlimit)
3028 (multiple-value-bind (ret err)
3029 (c-inline2 (resource rlimit)
3030 (:int :object)
3031 (values :int :int)
3032 "
3033 {
3034 struct rlimit rlp;
3035 int ret, err = 0;
3036
3037 fill_rlimit_c_structure(&rlp, #1);
3038 if ((ret = setrlimit(#0, &rlp)) == -1)
3039 err = errno;
3040
3041 @(return 0) = ret;
3042 @(return 1) = err;
3043 }" :one-liner nil)
3044 (if (= 0 ret)
3045 rlimit
3046 (unix-error "setrlimit" err `(,resource ,rlimit)))))
3047
3048 (defun priority (which who)
3049 "Invokes getpriority(2) with WHICH and WHO and returns a priority number,
3050 or signals a condition of type UNIX-ERROR on error."
3051 (multiple-value-bind (ret err)
3052 (c-inline2 (which who)
3053 (:int :id-t)
3054 (values :int :int)
3055 "
3056 {
3057 int ret, err = 0;
3058
3059 /* Note that getpriority(2) may rightfully return -1 */
3060 errno = 0;
3061 if ((ret = getpriority(#0, #1)) == -1)
3062 err = errno;
3063
3064 @(return 0) = ret;
3065 @(return 1) = err;
3066 }" :one-liner nil)
3067 (if (= 0 err)
3068 ret
3069 (unix-error "getpriority" err `(,which ,who)))))
3070
3071 (defun (setf priority) (priority which who)
3072 "Invokes setpriority(2) with WHICH WHO and PRIORITY and returns PRIORITY
3073 on success, or signals a condition of type UNIX-ERROR."
3074 (multiple-value-bind (ret err)
3075 (c-inline2 (which who priority)
3076 (:int :id-t :int)
3077 (values :int :int)
3078 "
3079 {
3080 int ret, err = 0;
3081
3082 if ((ret = setpriority(#0, #1, #2)) == -1)
3083 err = errno;
3084
3085 @(return 0) = ret;
3086 @(return 1) = err;
3087 }" :one-liner nil)
3088 (if (= -1 ret)
3089 (unix-error "setpriority" err `(,which ,who ,priority))
3090 priority)))
3091
3092
3093 ;;; XXX Eventually also support openlog_r() etc, but these would require to
3094 ;;; transparently store the structure in thread-specific storage. It'd be
3095 ;;; nice for ECL to provide such a facility.
3096 ;;; We might eventually also want to support setlogmask(3).
3097
3098 (define-c-constants :syslog "syslog.h"
3099 (log-emerg "LOG_EMERG")
3100 (log-alert "LOG_ALERT")
3101 (log-crit "LOG_CRIT")
3102 (log-err "LOG_ERR")
3103 (log-warning "LOG_WARNING")
3104 (log-notice "LOG_NOTICE")
3105 (log-info "LOG_INFO")
3106 (log-debug "LOG_DEBUG")
3107 (log-cons "LOG_CONS")
3108 (log-ndelay "LOG_NDELAY")
3109 (log-perror "LOG_PERROR")
3110 (log-pid "LOG_PID")
3111 (log-auth "LOG_AUTH")
3112 (log-authpriv "LOG_AUTHPRIV")
3113 (log-cron "LOG_CRON")
3114 (log-daemon "LOG_DAEMON")
3115 (log-ftp "LOG_FTP")
3116 (log-kern "LOG_KERN")
3117 (log-lpr "LOG_LPR")
3118 (log-mail "LOG_MAIL")
3119 (log-news "LOG_NEWS")
3120 (log-syslog "LOG_SYSLOG")
3121 (log-user "LOG_USER")
3122 (log-uucp "LOG_UUCP")
3123 (log-local0 "LOG_LOCAL0")
3124 (log-local1 "LOG_LOCAL1")
3125 (log-local2 "LOG_LOCAL2")
3126 (log-local3 "LOG_LOCAL3")
3127 (log-local4 "LOG_LOCAL4")
3128 (log-local5 "LOG_LOCAL5")
3129 (log-local6 "LOG_LOCAL6")
3130 (log-local7 "LOG_LOCAL7"))
3131
3132 (defun openlog (ident logopt facility)
3133 "Invokes openlog(3) with IDENT LOGOPT and FACILITY. Returns NIL."
3134 (c-inline2 (ident logopt facility)
3135 (:cstring :int :int)
3136 :void
3137 "openlog(#0, #1, #2)" :one-liner t)
3138 nil)
3139
3140 (defun closelog ()
3141 "Invokes closelog(3). Returns NIL."
3142 (c-inline2 () () :void "closelog()" :one-liner t))
3143
3144 (defun syslog (priority fmt &rest args)
3145 "Invokes syslog(3) with PRIORITY, FMT and optional ARGS. Returns NIL.
3146 Note that similarily to using C syslog(3), this function allows Common Lisp
3147 FORMAT syntax, and as such care should be taken to provide a \"~A\" FMT
3148 parameter to prevent custom user or remote supplied format controls."
3149 (let ((line (apply #'format nil fmt args)))
3150 (c-inline2 (priority line)
3151 (:int :cstring)
3152 :void
3153 "syslog(#0, \"%s\", #1)" :one-liner t))
3154 nil)
3155
3156
3157
3158 (defun setproctitle (fmt &rest args)
3159 "Invokes setproctitle(3), setting the title of the process. Returns NIL."
3160 (let ((line (apply #'format nil fmt args)))
3161 (c-inline2 (line)
3162 (:cstring)
3163 :void
3164 "setproctitle(\"%s\", #0)" :one-liner t))
3165 nil)
3166
3167
3168
3169 (ffi:clines "
3170 #include <time.h>
3171 ")
3172
3173 (define-c-structure tm "struct tm"
3174 (sec :int "tm_sec")
3175 (min :int "tm_min")
3176 (hour :int "tm_hour")
3177 (mday :int "tm_mday")
3178 (mon :int "tm_mon")
3179 (year :int "tm_year")
3180 (wday :int "tm_wday")
3181 (yday :int "tm_yday")
3182 (isdst :int "tm_isdst")
3183 (gmtoff :long "tm_gmtoff")
3184 (zone :cstring "tm_zone"))
3185 (define-c-cl-structure tm)
3186 (define-c-structure-serializer tm)
3187 (define-to-c-structure-serializer tm)
3188
3189 (defun posix-time ()
3190 "Invokes time(3) and returns the current time, or signals a condition of
3191 type UNIX-ERROR."
3192 (multiple-value-bind (ret err)
3193 (c-inline2 ()
3194 ()
3195 (values :time-t :int)
3196 "
3197 {
3198 int err = 0;
3199 time_t t;
3200
3201 if ((t = time(NULL)) == ((time_t)-1))
3202 err = errno;
3203
3204 @(return 0) = t;
3205 @(return 1) = err;
3206 }" :one-liner nil)
3207 (if (= -1 ret)
3208 (unix-error "time" err)
3209 ret)))
3210
3211 (defun ctime (time)
3212 "Invokes ctime_r(2) and returns a string with the current time."
3213 (c-inline2 (time)
3214 (:time-t)
3215 :cstring
3216 "
3217 {
3218 char buf[32];
3219 time_t time = #0;
3220
3221 @(return) = ctime_r(&time, buf);
3222 }" :one-liner nil))
3223
3224 (defun difftime (time0 time1)
3225 "Invokes difftime(3) with TIME0 and TIME1 and returns a double."
3226 (c-inline2 (time0 time1) (:time-t :time-t) :double
3227 "difftime(#0, #1)" :one-liner t))
3228
3229 (defun localtime (time)
3230 "Invokes localtime_r(3) and returns a TM structure."
3231 (c-inline2 (time)
3232 (:time-t)
3233 :object
3234 "
3235 {
3236 struct tm tm;
3237 time_t time = #0;
3238
3239 @(return) = fill_tm_structure(localtime_r(&time, &tm));
3240 }" :one-liner nil))
3241
3242 (defun gmtime (time)
3243 "Invokes gmtime_r(3) and returns a TM structure."
3244 (c-inline2 (time)
3245 (:time-t)
3246 :object
3247 "
3248 {
3249 struct tm tm;
3250 time_t time = #0;
3251
3252 @(return) = fill_tm_structure(gmtime_r(&time, &tm));
3253 }" :one-liner nil))
3254
3255 (defun asctime (tm)
3256 "Invokes asctime_r(3) with TM and returns a time string."
3257 (check-type tm tm)
3258 (c-inline2 (tm)
3259 (:object)
3260 :cstring
3261 "
3262 {
3263 struct tm tm;
3264 char buf[32];
3265
3266 fill_tm_c_structure(&tm, #0);
3267 @(return) = asctime_r(&tm, buf);
3268 }" :one-liner nil))
3269
3270 (defun mktime (tm)
3271 "Invokes mktime(3) with TM and returns a :TIME-T integer."
3272 (check-type tm tm)
3273 (c-inline2 (tm)
3274 (:object)
3275 :time-t
3276 "
3277 {
3278 struct tm tm;
3279
3280 fill_tm_c_structure(&tm, #0);
3281 @(return) = mktime(&tm);
3282 }" :one-liner nil))
3283
3284
3285 (defun isatty (fd)
3286 "Invokes isatty(3) and returns T if FD is a tty or NIL with an errno value."
3287 (multiple-value-bind (ret err)
3288 (c-inline2 (fd)
3289 (:int)
3290 (values :int :int)
3291 "
3292 {
3293 int ret, err = 0;
3294
3295 if ((ret = isatty(#0)) == 0)
3296 err = errno;
3297
3298 @(return 0) = ret;
3299 @(return 1) = err;
3300 }" :one-liner nil)
3301 (if (= 1 ret)
3302 t
3303 (values nil err))))
3304
3305 (defun ttyname (fd)
3306 "Invokes ttyname_r(3) on FD and returns a string or signals a condition of
3307 type UNIX-ERROR. The FD must be that of a tty."
3308 (multiple-value-bind (ret err)
3309 (c-inline2 (fd)
3310 (:int)
3311 (values :cstring :int)
3312 "
3313 {
3314 char buf[MAXPATHLEN];
3315 int err;
3316
3317 *buf = '\0';
3318 err = ttyname_r(#0, buf, MAXPATHLEN - 1);
3319
3320 @(return 0) = buf;
3321 @(return 1) = err;
3322 }" :one-liner nil)
3323 (if (= 0 err)
3324 ret
3325 (unix-error "ttyname_r" err `(,fd)))))
3326
3327 (defun ttyslot ()
3328 "Invokes ttyslot(3) and returns the tty slot if found, or 0."
3329 (c-inline2 () () :int "ttyslot()" :one-liner t))
3330
3331 (defsyscall1 (:int openpt "posix_openpt" :no-signal) (:int)
3332 "Invokes posix_openpt(3) which will use OFLAGS as open(2) flags.
3333 Returns the new file descriptor on success.")
3334
3335 (defsyscall0 (grantpt "grantpt" :no-signal) (:int)
3336 "Invokes grantpt(3) on FD.")
3337
3338 (defsyscall0 (unlockpt "unlockpt" :no-signal) (:int)
3339 "Invokes unlockpt(3) on FD.")
3340
3341 #+threads(defvar *ptsname-lock* (mp:make-lock :name 'ptsname-lock))
3342 #+threads(defun ptsname (masterfd)
3343 "Invokes ptsname(3) with MASTERFD and returns a string containing the
3344 pathname of the slave pseudo-terminal associated with master pty MASTERFD.
3345 On error, NIL is returned as first value as errno as second value.
3346 Note that this function internally uses a lock because ptsname(3) is not
3347 thread safe."
3348 (mp:with-lock (*ptsname-lock*)
3349 (multiple-value-bind (ret err)
3350 (c-inline2 (masterfd)
3351 (:int)
3352 (values :cstring :int)
3353 "
3354 {
3355 int err = 0;
3356 char *buf;
3357
3358 if ((buf = ptsname(#0)) == NULL)
3359 err = errno;
3360
3361 @(return 0) = buf;
3362 @(return 1) = err;
3363 }" :one-liner nil)
3364 (if (= 0 err)
3365 ret
3366 (values nil err)))))
3367 #-threads(defun ptsname (masterfd)
3368 "Invokes ptsname(3) with MASTERFD and returns a string containing the
3369 pathname of the slave pseudo-terminal associated with master pty MASTERFD.
3370 On error, NIL is returned as first value as errno as second value."
3371 (multiple-value-bind (ret err)
3372 (c-inline2 (masterfd)
3373 (:int)
3374 (values :cstring :int)
3375 "
3376 {
3377 int err = 0;
3378 char *buf;
3379
3380 if ((buf = ptsname(#0)) == NULL)
3381 err = errno;
3382
3383 @(return 0) = buf;
3384 @(return 1) = err;
3385 }" :one-liner nil)
3386 (if (= 0 err)
3387 ret
3388 (values nil err))))
3389
3390
3391
3392 (define-c-constants :dirent "dirent.h"
3393 (dt-unknown "DT_UNKNOWN")
3394 (dt-fifo "DT_FIFO")
3395 (dt-chr "DT_CHR")
3396 (dt-dir "DT_DIR")
3397 (dt-blk "DT_BLK")
3398 (dt-reg "DT_REG")
3399 (dt-lnk "DT_LNK")
3400 (dt-sock "DT_SOCK")
3401 (dt-wht "DT_WHT"))
3402
3403 (defstruct dir
3404 pointer)
3405
3406 ;;; XXX Our DEFINE-C-STRUCTURE system should automatically #include, like
3407 ;;; our DEFINE-C-CONSTANTS one...
3408 (ffi:clines "#include <dirent.h>")
3409 (define-c-structure dirent "struct dirent"
3410 (fileno :ino-t "d_fileno")
3411 (reclen :uint16-t "d_reclen")
3412 (type :uint8-t "d_type")
3413 (name :cstring "d_name"))
3414 (define-c-cl-structure dirent)
3415 (define-c-structure-serializer dirent)
3416
3417 (defun opendir (path &optional no-signal)
3418 "Invokes opendir(3), returning a DIR object. Signals a signal of type
3419 UNIX-ERROR on error, unless NO-SIGNAL, where two values are returned:
3420 NIL and errno. CLOSEDIR should be used to discard the DIR object."
3421 (multiple-value-bind (ret err)
3422 (c-inline2 (path)
3423 (:cstring)
3424 (values :pointer-void :int)
3425 "
3426 {
3427 DIR *dir;
3428 int err = 0;
3429
3430 if ((dir = opendir(#0)) == NULL)
3431 err = errno;
3432
3433 @(return 0) = dir;
3434 @(return 1) = err;
3435 }" :one-liner nil)
3436 (if (ffi:null-pointer-p ret)
3437 (if no-signal
3438 (values nil err)
3439 (unix-error "opendir" err `(,path)))
3440 (make-dir :pointer ret))))
3441
3442 (defun closedir (dir &optional no-signal)
3443 "Invokes closedir(3) on DIR. Returns T on success, or signals a condition
3444 of type UNIX-ERROR, unless NO-SIGNAL, where two values are returned:
3445 NIL and errno."
3446 (check-type dir dir)
3447 (multiple-value-bind (ret err)
3448 (c-inline2 ((dir-pointer dir))
3449 (:pointer-void)
3450 (values :int :int)
3451 "
3452 {
3453 int ret, err = 0;
3454 DIR *dir = #0;
3455
3456 if ((ret = closedir(dir)) == -1)
3457 err = errno;
3458
3459 @(return 0) = ret;
3460 @(return 1) = err;
3461 }" :one-liner nil)
3462 (if (= 0 ret)
3463 (progn
3464 (setf (dir-pointer dir) nil)
3465 t)
3466 (if no-signal
3467 (values nil err)
3468 (unix-error "closedir" err `(,dir))))))
3469
3470 ;;; XXX It appears that some systems, as well as POSIX, advocate defining
3471 ;;; the d_name field of the dirent structure with length 0 or 1, requireing
3472 ;;; the caller to use a call such as pathconf(2) on the directory, then
3473 ;;; using malloc(3) with sizeof(struct dirent) + 1 + obtained size at
3474 ;;; opendir(2) time.
3475 ;;; Instead of simply ensuring that struct dirent contais a d_name
3476 ;;; string of size NAME_MAX, and NAME_MAX being sure to be large enough to
3477 ;;; hold file names for any file system supported by the OS (like BSD does).
3478 ;;; As insane as the new advocated approach is, we might need to take it into
3479 ;;; consideration if porting this code over to other OSs.
3480 ;;; See http://www.NetBSD.org/cgi-bin/query-pr-single.pl?number=43310
3481 ;;; Currently this code is safe on NetBSD, the awesome OS we target.
3482 (defun readdir (dir &optional no-signal)
3483 "Invokes readdir_r(3) on DIR and returns a DIRENT, or NIL if no more
3484 entries are available, with a second value of 0. Signals a condition of type
3485 UNIX-ERROR on failure, unless NO-SIGNAL, where NIL is returned with the error
3486 number as a second value."
3487 (check-type dir dir)
3488 (multiple-value-bind (ret err)
3489 (c-inline2 ((dir-pointer dir))
3490 (:pointer-void)
3491 (values :object :int)
3492 "
3493 {
3494 DIR *dir = #0;
3495 struct dirent ent, *entp;
3496 cl_object ret = Cnil;
3497 int err;
3498
3499 if ((err = readdir_r(dir, &ent, &entp)) == 0) {
3500 if (entp != NULL)
3501 ret = fill_dirent_structure(entp);
3502 }
3503
3504 @(return 0) = ret;
3505 @(return 1) = err;
3506 }" :one-liner nil)
3507 (if ret
3508 (values ret 0)
3509 (if (= 0 err)
3510 (values nil 0)
3511 (if no-signal
3512 (values nil err)
3513 (unix-error "readdir_r" err `(,dir)))))))
3514
3515 (defun telldir (dir)
3516 "Invokes telldir(3) on DIR, returning a token which may be later used with
3517 SEEKDIR."
3518 (check-type dir dir)
3519 (c-inline2 ((dir-pointer dir))
3520 (:pointer-void)
3521 :long
3522 "telldir(#0)" :one-liner t))
3523
3524 (defun seekdir (dir token)
3525 "Invokes seekdir(3) on DIR with TOKEN. Returns nothing."
3526 (check-type dir dir)
3527 (c-inline2 ((dir-pointer dir) token)
3528 (:pointer-void :long)
3529 :void
3530 "seekdir(#0, #1)" :one-liner t))
3531
3532 (defun rewinddir (dir)
3533 "Invokes rewinddir(3) on DIR. Returns nothing."
3534 (check-type dir dir)
3535 (c-inline2 ((dir-pointer dir))
3536 (:pointer-void)
3537 :void
3538 "rewinddir(#0)" :one-liner t))
3539
3540 (defun dirfd (dir)
3541 "Invokes dirfd(3) on DIR, returning a file descriptor on success or -1."
3542 (check-type dir dir)
3543 (c-inline2 ((dir-pointer dir))
3544 (:pointer-void)
3545 :int
3546 "
3547 {
3548 DIR *dir = #0;
3549
3550 @(return) = dirfd(dir);
3551 }" :one-liner nil))
3552
3553 (defmacro with-opendir ((dir path) &body body)
3554 "Attempts to (OPENDIR PATH) and evaluates BODY while making sure to
3555 close DIR."
3556 (let ((idir (gensym)))
3557 `(let* ((,idir (opendir ,path))
3558 (,dir ,idir))
3559 (unwind-protect
3560 (progn
3561 ,@body)
3562 (closedir ,idir)))))
3563
3564 (ffi:clines "
3565 #include <libgen.h>
3566 ")
3567
3568 ;;; Those functions are unfortunately not thread-safe.
3569 #+threads(defvar *basename-lock* (mp:make-lock :name 'basename-lock))
3570 #+threads(defun basename (path)
3571 (mp:with-lock (*basename-lock*)
3572 (c-inline2 (path)
3573 (:cstring)
3574 :cstring
3575 "basename(#0)" :one-liner t)))
3576 #+threads(defun dirname (path)
3577 (mp:with-lock (*basename-lock*)
3578 (c-inline2 (path)
3579 (:cstring)
3580 :cstring
3581 "dirname(#0)" :one-liner t)))
3582 #-threads(defun basename (path)
3583 (c-inline2 (path)
3584 (:cstring)
3585 :cstring
3586 "basename(#0)" :one-liner t))
3587 #-threads(defun dirname (path)
3588 (c-inline2 (path)
3589 (:cstring)
3590 :cstring
3591 "dirname(#0)" :one-liner t))
3592
3593 (defun dirtree (path)
3594 "Returns a tree of all directories and files contained within PATH,
3595 or signals a condition of type UNIX-ERROR. Every list of the tree begins
3596 with the directory name, followed by the directories and files contained
3597 within."
3598 (let ((basename (basename path)))
3599 (with-opendir (dir path)
3600 (list basename
3601 (loop
3602 for ent = (readdir dir)
3603 for name = (if ent
3604 (dirent-name ent)
3605 nil)
3606 while ent
3607 unless (or (string= "." name)
3608 (string= ".." name))
3609 collect
3610 (with-c-constants (:dirent)
3611 (if (not (= dt-dir (dirent-type ent)))
3612 name
3613 (dirtree (concatenate 'string path "/" name)))))))))
3614
3615
3616 (ffi:clines "
3617 #include <sys/event.h>
3618 #include <sys/time.h>
3619 ")
3620
3621 (define-c-constants :sys-event "sys/event.h"
3622 (ev-add "EV_ADD")
3623 (ev-enable "EV_ENABLE")
3624 (ev-disable "EV_DISABLE")
3625 (ev-delete "EV_DELETE")
3626 (ev-oneshot "EV_ONESHOT")
3627 (ev-clear "EV_CLEAR")
3628 (ev-eof "EV_EOF")
3629 (ev-error "EV_ERROR")
3630 (kfilter-byfilter "KFILTER_BYFILTER")
3631 (kfilter-byname "KFILTER_BYNAME")
3632 (evfilt-read "EVFILT_READ")
3633 (evfilt-write "EVFILT_WRITE")
3634 (evfilt-aio "EVFILT_AIO")
3635 (evfilt-vnode "EVFILT_VNODE")
3636 (note-delete "NOTE_DELETE")
3637 (note-write "NOTE_WRITE")
3638 (note-extend "NOTE_EXTEND")
3639 (note-attrib "NOTE_ATTRIB")
3640 (note-link "NOTE_LINK")
3641 (note-rename "NOTE_RENAME")
3642 (note-revoke "NOTE_REVOKE")
3643 (evfilt-proc "EVFILT_PROC")
3644 (note-exit "NOTE_EXIT")
3645 (note-fork "NOTE_FORK")
3646 (note-exec "NOTE_EXEC")
3647 (note-track "NOTE_TRACK")
3648 (note-trackerr "NOTE_TRACKERR")
3649 (evfilt-signal "EVFILT_SIGNAL")
3650 (evfilt-timer "EVFILT_TIMER"))
3651
3652 (define-c-structure timespec "struct timespec"
3653 (sec :time-t "tv_sec")
3654 (nsec :long "tv_nsec"))
3655 (define-c-cl-structure timespec)
3656 ;(define-c-structure-serializer timespec)
3657 (define-to-c-structure-serializer timespec)
3658
3659 (define-c-structure kevent "struct kevent"
3660 (ident :uintptr-t "ident")
3661 (filter :uint32-t "filter")
3662 (flags :uint32-t "flags")
3663 (fflags :uint32-t "fflags")
3664 (data :int64-t "data")
3665 (udata :intptr-t "udata"))
3666 (define-c-cl-structure kevent)
3667 (define-c-structure-serializer kevent)
3668 (define-to-c-structure-serializer kevent)
3669
3670 (defmacro set-kevent (ev (ident filter flags fflags data udata))
3671 "Permits to set all fields of a KEVENT structure to new values without
3672 needing to create a new KEVENT structure instance using MAKE-KEVENT.
3673 This macro is also quite faster than a possible (SETF KEVENT) function
3674 once compiled. Returns EV, allowing to embed SET-KEVENT into KEVENT-SET-ADD."
3675 (let ((iev (gensym)))
3676 `(let ((,iev ,ev))
3677 (setf (kevent-ident ,iev) ,ident
3678 (kevent-filter ,iev) ,filter
3679 (kevent-flags ,iev) ,flags
3680 (kevent-fflags ,iev) ,fflags
3681 (kevent-data ,iev) ,data
3682 (kevent-udata ,iev) ,udata)
3683 ,iev)))
3684
3685 (ffi:clines "
3686 typedef struct kevent_set {
3687 int size, fill_pointer;
3688 struct kevent *array;
3689 } kevent_set_t;
3690
3691 kevent_set_t *
3692 kevent_set_create(int initial_size)
3693 {
3694 kevent_set_t *set = malloc(sizeof(kevent_set_t));
3695
3696 set->array = calloc(initial_size, sizeof(struct kevent));
3697 set->size = initial_size;
3698 set->fill_pointer = 0;
3699
3700 return set;
3701 }
3702
3703 void
3704 kevent_set_destroy(kevent_set_t *set)
3705 {
3706
3707 free(set->array);
3708 free(set);
3709 }
3710
3711 inline void
3712 kevent_set_add(kevent_set_t *set, struct kevent *ev)
3713 {
3714
3715 if (set->fill_pointer == set->size) {
3716 set->size *= 2;
3717 set->array = realloc(set->array, set->size);
3718 }
3719 set->array[set->fill_pointer++] = *ev;
3720 }
3721 ")
3722
3723 (defstruct (kevent-set
3724 (:constructor %make-kevent-set)
3725 (:print-object
3726 (lambda (set stream)
3727 (print-unreadable-object (set stream :type t :identity t)
3728 (if (kevent-set-pointer set)
3729 (prin1 `(:size ,(kevent-set-size set)
3730 :fill-pointer ,(kevent-set-fill-pointer set))
3731 stream)
3732 (prin1 `(pointer nil) stream))))))
3733 pointer)
3734
3735 (defun make-kevent-set (&optional (initial-size 64))
3736 "Create a KEVENT-SET structure which may be used to store KEVENTs.
3737 INITIAL-SIZE (defaulting to 64) specifies how many KEVENTs this set may
3738 hold. This size will automatically be doubled as necessary and the
3739 set grown if KEVENT-SET-ADD needs more room.
3740 Two sets are normally created per KQUEUE descriptor, one on which to
3741 use KEVENT-SET-ADD on, and the other to use DO-KEVENT-SET on.
3742 These sets may be reused across KEVENT calls.
3743 Note that to discard a set DESTROY-KEVENT-SET should be used or memory
3744 will be leaked."
3745 (when (< initial-size 1)
3746 (with-c-constants (:errno)
3747 (unix-error "kevent_set_create" einval `(,initial-size))))
3748 (%make-kevent-set :pointer (c-inline2 (initial-size)
3749 (:int)
3750 :pointer-void
3751 "kevent_set_create(#0)"
3752 :one-liner t)))
3753
3754 (defun destroy-kevent-set (set)
3755 "Destroy a KEVENT-SET previously created using MAKE-KEVENT-SET."
3756 (check-type set kevent-set)
3757 (when (kevent-set-pointer set)
3758 (c-inline2 ((kevent-set-pointer set)) (:pointer-void) :void
3759 "kevent_set_destroy(#0)" :one-liner t)
3760 (setf (kevent-set-pointer set) nil)))
3761
3762 (defun kevent-set-size (set)
3763 "Reports the SIZE of the KEVENT-SET specified by SET.
3764 This is the allocated number of KEVENT slots, which may grow automatically
3765 with KEVENT-SET-ADD."
3766 (check-type set kevent-set)
3767 (c-inline2 ((kevent-set-pointer set))
3768 (:pointer-void)
3769 :int
3770 "
3771 {
3772 kevent_set_t *set = #0;
3773
3774 @(return) = set->size;
3775 }" :one-liner nil))
3776
3777 (defun kevent-set-fill-pointer (set)
3778 "Reports the FILL-POINTER of the KEVENT-SET specified by SET.
3779 This specifies how many active entries are stored into SET, and
3780 may be flushed completely using KEVENT-SET-EMPTY."
3781 (check-type set kevent-set)
3782 (c-inline2 ((kevent-set-pointer set))
3783 (:pointer-void)
3784 :int
3785 "
3786 {
3787 kevent_set_t *set = #0;
3788
3789 @(return) = set->fill_pointer;
3790 }" :one-liner nil))
3791
3792 (defun kevent-set-add (set ev)
3793 "Queue the KEVENT EV to the KEVENT-SET specified by SET, and automatically
3794 grow SET's SIZE as necessary, doubling it. Note that although it's important
3795 to provide a KEVENT structure to this function, this structure can be reused
3796 as its values are internally copied. The SET-KEVENT macro may be used to
3797 efficiently set new values to EV, instead of needing to create extra objects."
3798 (check-type set kevent-set)
3799 (check-type ev kevent)
3800 (c-inline2 ((kevent-set-pointer set) ev)
3801 (:pointer-void :object)
3802 :void
3803 "
3804 {
3805 kevent_set_t *set = #0;
3806 struct kevent ev;
3807
3808 fill_kevent_c_structure(&ev, #1);
3809 kevent_set_add(set, &ev);
3810 }" :one-liner nil)
3811 ev)
3812
3813 (defun kevent-set-empty (set)
3814 "Flush any pending KEVENTs queued into the KEVENT-SET SET, by resetting
3815 the set's FILL-POINTER to 0."
3816 (check-type set kevent-set)
3817 (c-inline2 ((kevent-set-pointer set))
3818 (:pointer-void)
3819 :void
3820 "
3821 {
3822 kevent_set_t *set = #0;
3823
3824 set->fill_pointer = 0;
3825 }" :one-liner nil)
3826 set)
3827
3828 (defun %kevent-set-ref (set index)
3829 "Internal function used by the DO-KEVENT-SET iterator macro."
3830 (check-type set kevent-set)
3831 (c-inline2 ((kevent-set-pointer set) index)
3832 (:pointer-void :int)
3833 :object
3834 "
3835 {
3836 kevent_set_t *set = #0;
3837 int i = #1;
3838
3839 @(return) = (set->fill_pointer <= i ? Cnil :
3840 fill_kevent_structure(&set->array[i]));
3841 }" :one-liner nil))
3842
3843 (defmacro do-kevent-set ((ev set) &body body)
3844 "Iterate though all active KEVENTs of the KEVENT-SET SET, binding each
3845 KEVENT to EV and evaluating BODY."
3846 (let ((iset (gensym))
3847 (i (gensym))
3848 (l (gensym)))
3849 `(let* ((,iset ,set)
3850 (,l (kevent-set-fill-pointer ,iset)))
3851 (declare (type fixnum ,l))
3852 (loop
3853 for ,i of-type fixnum from 0 below ,l
3854 do
3855 (let ((,ev (%kevent-set-ref ,iset ,i)))
3856 ,@body)))))
3857
3858 (defun kqueue ()
3859 "Invokes kqueue(2) returning a new kqueue system descriptor.
3860 At least one such descriptor is needed for use with KEVENT."
3861 (c-inline2 () () :int "kqueue()" :one-liner t))
3862
3863 (defun kevent (fd change-set event-set &optional timeout)
3864 "Invokes kevent(2), returning its actual integer return value.
3865 FD should be a descriptor created using KQUEUE,
3866 CHANGE-SET a KEVENT-SET to which wanted KEVENTs have been queued using
3867 KEVENT-SET-ADD,
3868 EVENT-SET another KEVENT-SET which will receive the current events report,
3869 and can then be iterated through using DO-KEVENTS-SET, This may be NIL
3870 when the intention is not to receive events.
3871 TIMEOUT is an optional TIMESPEC structure specifying a timeout, or
3872 NIL (the default) to wait indefinitely until at least one event occurs.
3873 The main events loop only should comport a single KEVENT syscall for optimal
3874 performance."
3875 (check-type change-set kevent-set)
3876 (check-type event-set (or null kevent-set))
3877 (check-type timeout (or null timespec))
3878 (when (eq change-set event-set)
3879 (with-c-constants (:errno)
3880 (unix-error "kevent" einval `(,fd ,change-set ,event-set ,timeout))))
3881 (c-inline2 (fd
3882 (kevent-set-pointer change-set)
3883 (if event-set
3884 (kevent-set-pointer event-set)
3885 (ffi:make-null-pointer :pointer-void))
3886 timeout)
3887 (:int
3888 :pointer-void
3889 :pointer-void
3890 :object)
3891 :int
3892 "
3893 {
3894 kevent_set_t *change_set = #1, *event_set = #2;
3895 cl_object timeout = #3;
3896 struct kevent *array = NULL;
3897 struct timespec ts, *tsptr = NULL;
3898 int array_size = 0, ret;
3899
3900 if (event_set != NULL) {
3901 array = event_set->array;
3902 array_size = event_set->size;
3903 }
3904 if (timeout != Cnil) {
3905 fill_timespec_c_structure(&ts, timeout);
3906 tsptr = &ts;
3907 }
3908
3909 ret = kevent(#0, change_set->array, change_set->fill_pointer,
3910 array, array_size, tsptr);
3911
3912 if (ret < 1 && event_set != NULL)
3913 event_set->fill_pointer = 0;
3914 else {
3915 if (event_set != NULL)
3916 event_set->fill_pointer = ret;
3917 change_set->fill_pointer = 0;
3918 }
3919
3920 @(return) = ret;
3921 }" :one-liner nil))
3922
3923
3924
3925 (defun make-fd-stream (fd &key
3926 (mode :input-output)
3927 (external-format :default))
3928 "Open a STREAM over the specified FD for unbuffered use.
3929 Note that even READ-SEQUENCE and WRITE-SEQUENCE only operate one character
3930 at a time, which is suboptimal, resulting in a flood of syscalls,
3931 independent of the stream's EXTERNAL-FORMAT."
3932 (unless (member mode '(:input :output :input-output))
3933 (with-c-constants (:errno)
3934 (unix-error "make-fd-stream" einval `(,fd ,mode ,external-format))))
3935 (let ((stream (c-inline2 ("FD-STREAM" fd mode)
3936 (:object :int :object)
3937 :object
3938 "
3939 {
3940 cl_object mode_symbol = #2;
3941 int mode;
3942
3943 if (mode_symbol == @:input)
3944 mode = smm_input;
3945 else if (mode_symbol == @:output)
3946 mode = smm_output;
3947 else
3948 mode = smm_io;
3949
3950 @(return) = ecl_make_file_stream_from_fd(#0, #1, mode, 8,
3951 ECL_STREAM_DEFAULT_FORMAT, Cnil);
3952 }" :one-liner nil)))
3953 (unless (eq :default external-format)
3954 (setf (stream-external-format stream) external-format))
3955 stream))
3956
3957 (defun make-fd-file-stream (fd &key
3958 (mode :input-output)
3959 (buffering :full)
3960 (external-format :default))
3961 "Open a STREAM over the specified FD for buffered use. Internally uses
3962 fdopen(3) to create a FILE stdio handle."
3963 (unless (member mode '(:input :output :input-output))
3964 (with-c-constants (:errno)
3965 (unix-error "make-fd-file-stream" einval
3966 `(,fd ,mode ,buffering ,external-format))))
3967 (let ((stream (c-inline2 ("FD-FILE-STREAM" fd mode)
3968 (:object :int :object)
3969 :object
3970 "
3971 {
3972 cl_object mode_symbol = #2;
3973 int mode;
3974
3975 if (mode_symbol == @:input)
3976 mode = smm_input;
3977 else if (mode_symbol == @:output)
3978 mode = smm_output;
3979 else
3980 mode = smm_io;
3981
3982 @(return) = ecl_make_stream_from_fd(#0, #1, mode, 8,
3983 ECL_STREAM_DEFAULT_FORMAT, Cnil);
3984 }" :one-liner nil)))
3985 (si::set-buffering-mode stream buffering)
3986 (unless (eq :default external-format)
3987 (setf (stream-external-format stream) external-format))
3988 stream))
3989
3990
3991 (ffi:clines "
3992
3993 /*
3994 * Allows access to CL unicode CHARACTER UTF-32 and other 32-bit vectors
3995 * from C code.
3996 */
3997 static void *
3998 vector32_pointer(cl_object v, size_t offset, size_t size)
3999 {
4000 bool valid = false;
4001
4002 size += offset;
4003 switch (type_of(v)) {
4004 case t_string:
4005 valid = (size <= v->string.dim);
4006 break;
4007 case t_vector:
4008 switch (v->vector.elttype) {
4009 case aet_i32:
4010 case aet_b32:
4011 case aet_fix:
4012 case aet_index:
4013 case aet_ch:
4014 valid = (size <= v->vector.dim);
4015 break;
4016 }
4017 break;
4018 }
4019
4020 return (valid ? (&((int32_t *)v->vector.self.t)[offset]): NULL);
4021 }
4022
4023 #include <stdint.h>
4024
4025 enum utf8_status {
4026 UTF8_UNKNOWN = 0,
4027 UTF8_BYTES_ARRAY_EMPTY,
4028 UTF8_CHARS_ARRAY_FULL,
4029 UTF8_INVALID_START_BYTE,
4030 UTF8_INVALID_CONT_BYTE,
4031 UTF8_OVERLONG_SEQUENCE,
4032 UTF8_CHAR_OUT_OF_RANGE,
4033 UTF8_CHARS_ARRAY_EMPTY,
4034 UTF8_BYTES_ARRAY_FULL
4035 };
4036
4037 static int utf8_decode(int32_t **, int32_t *,
4038 const uint8_t **, const uint8_t *);
4039 static int utf8_encode(uint8_t **, uint8_t *,
4040 const int32_t **, const int32_t *);
4041
4042 #define GET_BYTE(v) \\
4043 if (b_p == end_bytes) { \\
4044 status = UTF8_BYTES_ARRAY_EMPTY; \\
4045 break; \\
4046 } \\
4047 v = *b_p++;
4048
4049 #define VALID_CONT_BYTE(v) \\
4050 if ((v) < 0x7e || (v) > 0xbf) { \\
4051 status = UTF8_INVALID_CONT_BYTE; \\
4052 break; \\
4053 }
4054
4055 /*
4056 * Decodes UTF-8 sequences found in the array bound by <bytes> and <end_bytes>
4057 * to UTF-32 characters added to the array bound by <chars> and <end_chars>.
4058 * Returns with <bytes> set to after the last successfully decoded sequence,
4059 * and with <chars> set to after the last character added.
4060 * Returns an UTF8_<status>.
4061 */
4062 static int
4063 utf8_decode(int32_t **chars, int32_t *end_chars,
4064 const uint8_t **bytes, const uint8_t *end_bytes)
4065 {
4066 int status = UTF8_UNKNOWN;
4067 int32_t *c_p = *chars;
4068 const uint8_t *b_p = *bytes;
4069 uint8_t b1 = 0, b2 = 0, b3 = 0, b4 = 0;
4070
4071 for (; c_p < end_chars; *bytes = b_p) {
4072
4073 GET_BYTE(b1);
4074 if (b1 < 0x80) {
4075 *c_p++ = b1;
4076 continue;
4077 }
4078
4079 if (b1 < 0xc0) {
4080 status = UTF8_INVALID_START_BYTE;
4081 break;
4082 }
4083
4084 GET_BYTE(b2);
4085 VALID_CONT_BYTE(b2);
4086 if (b1 < 0xc2) {
4087 status = UTF8_OVERLONG_SEQUENCE;
4088 break;
4089 }
4090 if (b1 < 0xe0) {
4091 *c_p++ = ((0x1f & b1) << 6) | (b2 & ~0x80);
4092 continue;
4093 }
4094
4095 GET_BYTE(b3);
4096 VALID_CONT_BYTE(b3);
4097 if (b1 == 0xe0 && b2 < 0xa0) {
4098 status = UTF8_OVERLONG_SEQUENCE;
4099 break;
4100 }
4101 if (b1 < 0xf0) {
4102 *c_p++ = ((b1 & 0x0f) << 12) |
4103 (((b2 & 0x3f) << 6) |
4104 (b3 & 0x3f));
4105 continue;
4106 }
4107
4108 GET_BYTE(b4);
4109 VALID_CONT_BYTE(b4);
4110 if (b1 == 0xf0 && b2 < 0x90) {
4111 status = UTF8_OVERLONG_SEQUENCE;
4112 break;
4113 }
4114 if (b1 < 0xf8) {
4115 if (b1 > 0xf4 || (b1 == 0xf4 && b2 > 0x8f)) {
4116 status = UTF8_CHAR_OUT_OF_RANGE;
4117 break;
4118 }
4119 *c_p++ = (((b1 & 0x07) << 18) |
4120 ((b2 & ~0x80) << 12) |
4121 ((b3 & ~0x80) << 6) |
4122 (b4 & ~0x80));
4123 continue;
4124 }
4125
4126 status = UTF8_OVERLONG_SEQUENCE;
4127 break;
4128 }
4129
4130 if (c_p == end_chars)
4131 status = UTF8_CHARS_ARRAY_FULL;
4132
4133 *chars = c_p;
4134
4135 return status;
4136 }
4137
4138 #undef GET_BYTE
4139 #undef VALID_CONT_BYTE
4140
4141
4142 /*
4143 * Encodes the UTF-32 characters found in the array enclosed by <chars> and
4144 * <end_chars> to UTF-8 bytes into the array enclosed by <bytes> and
4145 * <end_bytes>. Returns an UTF8_* status code.
4146 * <bytes> will be set after the last byte set, and <chars> after the last
4147 * character encoded.
4148 */
4149 static int
4150 utf8_encode(uint8_t **bytes, uint8_t *end_bytes,
4151 const int32_t **chars, const int32_t *end_chars)
4152 {
4153 int status = UTF8_UNKNOWN, n;
4154 uint8_t *b_p = *bytes;
4155 const int32_t *c_p = *chars;
4156 int32_t c;
4157
4158 for (; c_p < end_chars; c_p++) {
4159 c = *c_p;
4160
4161 if (c < 0x80)
4162 n = 1;
4163 else if (c < 0x0800)
4164 n = 2;
4165 else if (c < 0x00010000)
4166 n = 3;
4167 else
4168 n = 4;
4169
4170 if (end_bytes - b_p < n) {
4171 status = UTF8_BYTES_ARRAY_FULL;
4172 break;
4173 }
4174
4175 switch (n) {
4176 case 1:
4177 *b_p = (uint8_t)c;
4178 break;
4179 case 2:
4180 b_p[0] = 0xc0 | (c >> 6);
4181 b_p[1] = 0x80 | (c & 0x3f);
4182 break;
4183 case 3:
4184 b_p[0] = 0xe0 | (c >> 12);
4185 b_p[1] = 0x80 | (0x3f & (c >> 6));
4186 b_p[2] = 0x80 | (c & 0x3f);
4187 break;
4188 case 4:
4189 b_p[0] = 0xf0 | (0x07 & (c >> 18));
4190 b_p[1] = 0x80 | (0x3f & (c >> 12));
4191 b_p[2] = 0x80 | (0x3f & (c >> 6));
4192 b_p[3] = 0x80 | (c & 0x3f);
4193 break;
4194 }
4195
4196 b_p = &b_p[n];
4197 }
4198
4199 if (c_p == end_chars)
4200 status = UTF8_CHARS_ARRAY_EMPTY;
4201
4202 *bytes = b_p;
4203 *chars = c_p;
4204
4205 return status;
4206 }
4207
4208 ")
4209
4210 (defun utf8-decode (bytes &key (start 0) end)
4211 (check-type bytes base-string)
4212 (unless end
4213 (setf end (- (length bytes) start)))
4214 (let* ((string (make-array end
4215 :element-type 'character
4216 :fill-pointer 0))
4217 (chars (c-inline2 (string bytes start (- end start))
4218 (:object :object :size-t :size-t)
4219 :int
4220 "
4221 {
4222 cl_object string = #0, bytes = #1;
4223 size_t offset = #2, size = #3;
4224 int32_t *c_p, *cp, *ecp;
4225 const uint8_t *b_p, *bp, *ebp;
4226 int chars = 0;
4227
4228 if ((c_p = vector32_pointer(string, 0, size)) != NULL &&
4229 (b_p = vector8_pointer(bytes, offset, size)) != NULL) {
4230 int status;
4231
4232 cp = c_p; ecp = &c_p[size];
4233 bp = b_p; ebp = &b_p[size];
4234 for (;;) {
4235 status = utf8_decode(&cp, ecp, &bp, ebp);
4236 if (status == UTF8_BYTES_ARRAY_EMPTY ||
4237 status == UTF8_CHARS_ARRAY_FULL)
4238 break;
4239 *cp++ = *bp++;
4240 }
4241 chars = (cp - c_p);
4242 }
4243
4244 @(return) = chars;
4245 }" :one-liner nil)))
4246 (setf (fill-pointer string) chars)
4247 string))
4248
4249 (defun utf8-encode (string &key (start 0) end)
4250 (check-type string string)
4251 ;; We could return the supplied BASE-STRING STRING as-is, but this would
4252 ;; result in illegal UTF-8 output for any extended LATIN-1 character.
4253 (when (typep string 'base-string)
4254 (setf string (map 'string #'identity string)))
4255 (unless end
4256 (setf end (- (length string) start)))
4257 (let* ((bytes (make-array (* 4 end)
4258 :element-type 'base-char
4259 :fill-pointer 0))
4260 (nbytes (c-inline2 (bytes string start (- end start))
4261 (:object :object :size-t :size-t)
4262 :int
4263 "
4264 {
4265 cl_object string = #1, bytes = #0;
4266 size_t offset = #2, size = #3;
4267 const int32_t *c_p, *cp, *ecp;
4268 uint8_t *b_p, *bp, *ebp;
4269 int nbytes = 0;
4270
4271 if ((c_p = vector32_pointer(string, offset, size)) != NULL &&
4272 (b_p = vector8_pointer(bytes, 0, size)) != NULL) {
4273 int status;
4274
4275 cp = c_p; ecp = &c_p[size];
4276 bp = b_p; ebp = &b_p[size * 4];
4277 for (;;) {
4278 status = utf8_encode(&bp, ebp, &cp, ecp);
4279 if (status == UTF8_CHARS_ARRAY_EMPTY ||
4280 status == UTF8_BYTES_ARRAY_FULL)
4281 break;
4282 /*
4283 * XXX It would be nice to dynamically resize
4284 * the bytes array instead of allocating *4...
4285 */
4286 }
4287 nbytes = (bp - b_p);
4288 }
4289
4290 @(return) = nbytes;
4291 }" :one-liner nil)))
4292 (setf (fill-pointer bytes) nbytes)
4293 bytes))
4294
4295 ;;; XXX The buffer queue functions could be implemented in C for higher
4296 ;;; performance. But first write a test server and profile it.
4297
4298 (defstruct (buffer
4299 (:constructor %make-buffer))
4300 (head 0 :type fixnum)
4301 (tail 0 :type fixnum)
4302 (size 0 :type fixnum :read-only t)
4303 (external-format :latin-1 :type symbol)
4304 (bytes nil :type (simple-array base-char (*))))
4305
4306 (defun make-buffer (size &key (external-format :latin-1))
4307 "Create an I/O buffer/queue of SIZE bytes with EXTERNAL-FORMAT
4308 :LATIN-1 (default or :UTF-8)."
4309 (assert (member external-format '(:latin-1 :utf-8))
4310 (external-format)
4311 "EXTERNAL-FORMAT not one of :LATIN-1 :UTF-8")
43