├── .gitignore ├── version.sexp ├── tests ├── .gitignore ├── data │ ├── kafka_latin-1_cr.txt │ ├── kafka_latin-1_lf.txt │ ├── kafka_latin-1_crlf.txt │ ├── russian_utf-8_cr.txt │ ├── russian_utf-8_lf.txt │ ├── russian_utf-8_crlf.txt │ ├── hebrew_utf-8_cr.txt │ ├── hebrew_utf-8_lf.txt │ ├── hebrew_utf-8_crlf.txt │ ├── tilton_ascii_cr.txt │ ├── tilton_utf-8_cr.txt │ ├── tilton_ascii_lf.txt │ ├── tilton_utf-8_lf.txt │ ├── tilton_ascii_crlf.txt │ └── tilton_utf-8_crlf.txt ├── base.lisp ├── pkgdcl.lisp ├── defsuites.lisp ├── Makefile └── multiplex.lisp ├── .gitattributes ├── .gitconfig ├── src ├── streams │ ├── gray │ │ ├── TODO │ │ ├── pkgdcl.lisp │ │ ├── conditions.lisp │ │ ├── fd-mixin.lisp │ │ ├── classes.lisp │ │ └── buffer.lisp │ └── zeta │ │ ├── pkgdcl.lisp │ │ ├── conditions.lisp │ │ ├── types.lisp │ │ └── device.lisp ├── multiplex │ ├── TODO │ ├── detect.lisp │ ├── utils.lisp │ ├── pkgdcl.lisp │ ├── fd-entry.lisp │ ├── timers.lisp │ ├── multiplexer.lisp │ ├── scheduler.lisp │ ├── fd-wait.lisp │ ├── backend-kqueue.lisp │ └── backend-poll.lisp ├── conf │ ├── pkgdcl.lisp │ └── requires.lisp ├── new-cl │ ├── types.lisp │ ├── definitions.lisp │ ├── pkgdcl.lisp │ └── gray-streams.lisp ├── sockets │ ├── TODO │ ├── namedb │ │ ├── etc-files.lisp │ │ ├── file-monitor.lisp │ │ └── hosts.lisp │ ├── config.lisp │ ├── dns │ │ ├── common.lisp │ │ ├── conditions.lisp │ │ └── nameservers.lisp │ ├── iface.lisp │ ├── trivial-sockets.lisp │ ├── bsd.lisp │ └── conditions.lisp ├── base │ ├── debug.lisp │ ├── asdf.lisp │ ├── time.lisp │ ├── deffoldable.lisp │ ├── types.lisp │ ├── sequence.lisp │ ├── reader.lisp │ ├── conditions.lisp │ ├── matching.lisp │ ├── pkgdcl.lisp │ ├── defobsolete.lisp │ ├── defalias.lisp │ └── return-star.lisp ├── iolib │ └── pkgdcl.lisp ├── os │ ├── ffi-types-unix.lisp │ ├── pkgdcl.lisp │ └── ffi-functions-unix.lisp ├── pathnames │ └── pkgdcl.lisp └── syscalls │ ├── designators.lisp │ ├── os-conditions-unix.lisp │ └── conditions.lisp ├── .template.lisp ├── examples ├── Makefile ├── README ├── package.lisp ├── ex2-client.lisp ├── ex1-client.lisp ├── ex3-client.lisp ├── ex2-server.lisp ├── ex4-client.lisp ├── ex1-server.lisp ├── ex3-server.lisp ├── gen-tutorial └── echo-server.lisp ├── doc ├── .gitignore ├── streams.texinfo ├── macros.texinfo ├── Makefile ├── license.texinfo └── iolib.texinfo ├── iolib.conf.asd ├── iolib.asdf.asd ├── .travis.yml ├── README.md ├── iolib.common-lisp.asd ├── install-repo.bash ├── iolib.base.asd ├── LICENCE ├── iolib.examples.asd ├── extras └── ping.lisp └── CHANGES /.gitignore: -------------------------------------------------------------------------------- 1 | misc 2 | *~ 3 | .fasls 4 | -------------------------------------------------------------------------------- /version.sexp: -------------------------------------------------------------------------------- 1 | ;; -*- lisp -*- 2 | "0.8.4" 3 | -------------------------------------------------------------------------------- /tests/.gitignore: -------------------------------------------------------------------------------- 1 | echo-server 2 | echo-server.exe 3 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.lisp diff=lisp 2 | *.texinfo diff=texinfo 3 | -------------------------------------------------------------------------------- /tests/data/kafka_latin-1_cr.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sionescu/iolib/HEAD/tests/data/kafka_latin-1_cr.txt -------------------------------------------------------------------------------- /tests/data/kafka_latin-1_lf.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sionescu/iolib/HEAD/tests/data/kafka_latin-1_lf.txt -------------------------------------------------------------------------------- /tests/data/kafka_latin-1_crlf.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sionescu/iolib/HEAD/tests/data/kafka_latin-1_crlf.txt -------------------------------------------------------------------------------- /.gitconfig: -------------------------------------------------------------------------------- 1 | [diff "lisp"] 2 | xfuncname="^(\\(def.*)$" 3 | [diff "texinfo"] 4 | xfuncname="^(@(sub)*section.*)$" 5 | -------------------------------------------------------------------------------- /src/streams/gray/TODO: -------------------------------------------------------------------------------- 1 | -*- outline -*- 2 | 3 | * High priority 4 | - make sure the stream code works with non-blocking FDs 5 | -------------------------------------------------------------------------------- /src/multiplex/TODO: -------------------------------------------------------------------------------- 1 | -*- text -*- 2 | 3 | * Add Solaris /dev/poll suport 4 | * handle EINTR 5 | * handle EACCESS(kqueue) et caetera... 6 | -------------------------------------------------------------------------------- /.template.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Short file description. 4 | ;;; 5 | 6 | (in-package ...) 7 | 8 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: tutorial 2 | 3 | tutorial: tutorial.tmpl gen-tutorial 4 | ./gen-tutorial 5 | 6 | clean: 7 | rm -f *.fasl *~ tutorial 8 | -------------------------------------------------------------------------------- /tests/base.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- iolib/base test suite. 4 | ;;; 5 | 6 | (in-package :iolib/tests) 7 | 8 | (in-suite :iolib/base) 9 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | manual 2 | include 3 | # hmm, doc/*.{aux,cp,etc} doesn't work 4 | *.aux 5 | *.cp 6 | *.cps 7 | *.fn 8 | *.info 9 | *.ky 10 | *.log 11 | *.pg 12 | *.toc 13 | *.tp 14 | *.vr 15 | *.vrs 16 | -------------------------------------------------------------------------------- /src/conf/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (defpackage :iolib/conf 7 | (:nicknames :iolib.conf) 8 | (:use :common-lisp) 9 | (:export #:load-gray-streams)) 10 | -------------------------------------------------------------------------------- /src/new-cl/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Type definitions and constructors 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp) 7 | 8 | (deftype boolean () 9 | 'cl:boolean) 10 | 11 | (defun boolean (x) 12 | (if x t nil)) 13 | -------------------------------------------------------------------------------- /src/streams/zeta/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/zstreams 9 | (:use :iolib/base :iolib/pathnames :cffi) 10 | (:export 11 | )) 12 | -------------------------------------------------------------------------------- /src/multiplex/detect.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Detect available multiplexers. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | ;;; TODO: do real detecting here 9 | (setf *default-multiplexer* 10 | (cdar (sort *available-multiplexers* #'< :key #'car))) 11 | -------------------------------------------------------------------------------- /tests/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; pkgdcl.lisp --- Package definition. 4 | ;;; 5 | 6 | (in-package :cl-user) 7 | 8 | (defpackage :iolib/tests 9 | (:nicknames :iolib/tests) 10 | (:use :5am :iolib/base :iolib :iolib/pathnames) 11 | #+sb-package-locks 12 | (:lock t) 13 | (:export #:*echo-address* #:*echo-port*)) 14 | -------------------------------------------------------------------------------- /tests/data/russian_utf-8_cr.txt: -------------------------------------------------------------------------------- 1 | Зарегистрируйтесь сейчас на Десятую Международную Конференцию по Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. Конференция соберет широкий круг экспертов по вопросам глобального Интернета и Unicode, локализации и интернационализации, воплощению и применению Unicode в различных операционных системах и программных приложениях, шрифтах, верстке и многоязычных компьютерных системах. -------------------------------------------------------------------------------- /tests/data/russian_utf-8_lf.txt: -------------------------------------------------------------------------------- 1 | Зарегистрируйтесь сейчас на Десятую Международную Конференцию по 2 | Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. 3 | Конференция соберет широкий круг экспертов по вопросам глобального 4 | Интернета и Unicode, локализации и интернационализации, воплощению и 5 | применению Unicode в различных операционных системах и программных 6 | приложениях, шрифтах, верстке и многоязычных компьютерных системах. 7 | -------------------------------------------------------------------------------- /tests/data/russian_utf-8_crlf.txt: -------------------------------------------------------------------------------- 1 | Зарегистрируйтесь сейчас на Десятую Международную Конференцию по 2 | Unicode, которая состоится 10-12 марта 1997 года в Майнце в Германии. 3 | Конференция соберет широкий круг экспертов по вопросам глобального 4 | Интернета и Unicode, локализации и интернационализации, воплощению и 5 | применению Unicode в различных операционных системах и программных 6 | приложениях, шрифтах, верстке и многоязычных компьютерных системах. 7 | -------------------------------------------------------------------------------- /src/sockets/TODO: -------------------------------------------------------------------------------- 1 | -*- outline -*- 2 | 3 | * High priority 4 | - add read/write timeouts to sockets 5 | - add proper NETWORK-MASK class and rewrite address-arithmetic.lisp 6 | 7 | * Medium priority 8 | - make it possible to re-open sockets 9 | - add/fix socket options 10 | 11 | * Low priority 12 | - make it possible to send credentials over unix sockets 13 | - unlink socket file when closing a passive local socket 14 | 15 | * Very low priority 16 | - implement SCTP sockets 17 | -------------------------------------------------------------------------------- /tests/defsuites.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Main test suite definition. 4 | ;;; 5 | 6 | (in-package :iolib/tests) 7 | 8 | (def-suite :iolib 9 | :description "Main test suite for IOLib.") 10 | 11 | (def-suite :iolib/base :in :iolib) 12 | 13 | (def-suite :iolib/pathnames :in :iolib) 14 | 15 | (def-suite :iolib/multiplex :in :iolib) 16 | 17 | (def-suite :iolib/streams :in :iolib) 18 | 19 | (def-suite :iolib/sockets :in :iolib) 20 | -------------------------------------------------------------------------------- /iolib.conf.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defsystem :iolib.conf 4 | :description "Compile-time configuration for IOLib." 5 | :author "Stelian Ionescu " 6 | :licence "MIT" 7 | :version (:read-file-form "version.sexp") 8 | :defsystem-depends-on (:iolib.asdf) 9 | :around-compile "iolib/asdf:compile-wrapper" 10 | :encoding :utf-8 11 | :pathname "src/conf/" 12 | :components 13 | ((:file "pkgdcl") 14 | (:file "requires" :depends-on ("pkgdcl")))) 15 | -------------------------------------------------------------------------------- /src/conf/requires.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Load all non-ASDF deps - usually implementation-specific REQUIREs 4 | ;;; 5 | 6 | (in-package :iolib/conf) 7 | 8 | (defun load-gray-streams () 9 | #+(and allegro (not (version>= 9 0))) 10 | (unless (fboundp 'stream:stream-write-string) 11 | (require "streamc")) 12 | #+(or cmu abcl) 13 | (require :gray-streams) 14 | #+ecl 15 | (when (fboundp 'gray::redefine-cl-functions) 16 | (gray::redefine-cl-functions))) 17 | -------------------------------------------------------------------------------- /iolib.asdf.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | #.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) 4 | (error "You need ASDF >= 3.1 to load this system correctly.")) 5 | 6 | (defsystem :iolib.asdf 7 | :description "A few ASDF component classes." 8 | :author "Stelian Ionescu " 9 | :licence "MIT" 10 | :version (:read-file-form "version.sexp") 11 | :depends-on (:alexandria) 12 | :encoding :utf-8 13 | :pathname "src/base/" 14 | :components 15 | ((:file "asdf"))) 16 | -------------------------------------------------------------------------------- /src/new-cl/definitions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Various definers 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp) 7 | 8 | (defmacro defconstant (name value &optional documentation 9 | &environment env) 10 | (destructuring-bind (name &key (test ''eql)) 11 | (alexandria:ensure-list name) 12 | (macroexpand-1 13 | `(alexandria:define-constant ,name ,value 14 | :test ,test 15 | ,@(when documentation `(:documentation ,documentation))) 16 | env))) 17 | -------------------------------------------------------------------------------- /tests/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*- 2 | # 3 | # --- Make targets for test echo server. 4 | # 5 | 6 | # On my mingw/msys system this Makefile doesn't work so well for 7 | # some reason. The following, however, does work: 8 | # gcc -c echo-server.c 9 | # g++ -l echo-server.o -o echo-server.exe 10 | 11 | CFLAGS ?= -Wall 12 | 13 | all: echo-server 14 | 15 | echo-server: echo-server.c 16 | $(CC) -o $@ $(CFLAGS) $< 17 | 18 | clean: 19 | rm -f echo-server echo-server.exe 20 | 21 | # vim: ft=make ts=4 noet 22 | -------------------------------------------------------------------------------- /src/base/debug.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Debug helpers. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (defvar *safety-checks* 9 | #+iolib-debug t #-iolib-debug nil 10 | "Enables safety checks throught the IOLib codebase.") 11 | 12 | (defmacro debug-only (&body body) 13 | (when *safety-checks* 14 | `(progn ,@body))) 15 | 16 | (defmacro debug-only* (&body body) 17 | `(when *safety-checks* 18 | (progn ,@body))) 19 | 20 | (defmacro production-only (&body body) 21 | (unless *safety-checks* 22 | `(progn ,@body))) 23 | 24 | (defmacro production-only* (&body body) 25 | `(unless *safety-checks* 26 | ,@body)) 27 | -------------------------------------------------------------------------------- /doc/streams.texinfo: -------------------------------------------------------------------------------- 1 | @node Overview 2 | @chapter Overview 3 | 4 | Describe this library here. 5 | 6 | @node IO Streams 7 | @chapter IO Streams 8 | 9 | @section Stream Classes 10 | 11 | @include include/class-io.streams-dual-channel-gray-stream.texinfo 12 | @include include/class-io.streams-dual-channel-single-fd-gray-stream.texinfo 13 | @include include/class-io.streams-dual-channel-fd-mixin.texinfo 14 | @include include/class-io.streams-dual-channel-single-fd-mixin.texinfo 15 | 16 | @section Stream Accessors 17 | 18 | @include include/fun-io.streams-fd-non-blocking.texinfo 19 | @include include/fun-io.streams-input-fd-non-blocking.texinfo 20 | @include include/fun-io.streams-output-fd-non-blocking.texinfo 21 | -------------------------------------------------------------------------------- /src/streams/gray/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/streams 9 | (:nicknames :iolib.streams) 10 | (:use :iolib/base :cffi) 11 | (:export 12 | ;; Classes 13 | #:dual-channel-fd-mixin 14 | #:dual-channel-gray-stream 15 | 16 | ;; Conditions 17 | #:hangup 18 | #:no-characters-to-unread 19 | 20 | ;; Accessors 21 | #:external-format-of 22 | #:fd-non-blocking 23 | #:fd-of 24 | #:read-buffer-size 25 | #:read-buffer-empty-p 26 | #:write-buffer-size 27 | #:write-buffer-empty-p 28 | 29 | #:read-sequence* 30 | #:write-sequence* 31 | #:drain-input-buffer 32 | )) 33 | -------------------------------------------------------------------------------- /doc/macros.texinfo: -------------------------------------------------------------------------------- 1 | @c Some plain TeX macrology to wrap text in \hbox{} only if the text 2 | @c contains no hyphens. 3 | @iftex 4 | @tex 5 | \newif\ifdash 6 | \long\def\dashp#1{\expandafter\setnext#1-\dashphelper} 7 | \long\def\setnext#1-{\futurelet\next\dashphelper} 8 | \long\def\dashphelper#1\dashphelper{ 9 | \ifx\dashphelper\next\dashfalse\else\dashtrue\fi 10 | } 11 | \def\lw#1{\leavevmode\dashp{#1}\ifdash#1\else\hbox{#1}\fi} 12 | @end tex 13 | @end iftex 14 | 15 | @c A Texinfo binding for the plain TeX above. Analogous to Texinfo's 16 | @c @w, but for Lisp symbols. AFAICT, the comment characters are 17 | @c necessary to prevent treating the newline as a space. 18 | @macro lw{word} 19 | @iftex 20 | @tex 21 | \\lw{\word\}% 22 | @end tex 23 | @end iftex 24 | @ifnottex 25 | \word\@c 26 | @end ifnottex 27 | @end macro 28 | -------------------------------------------------------------------------------- /src/base/asdf.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- ASDF component classes 4 | ;;; 5 | 6 | (defpackage :iolib/asdf 7 | (:nicknames :iolib.asdf) 8 | (:use :common-lisp) 9 | (:export #:compile-wrapper) 10 | #+sb-package-locks 11 | (:lock t)) 12 | 13 | (in-package :iolib/asdf) 14 | 15 | (defun compile-wrapper (continuation) 16 | (let ((*readtable* (copy-readtable)) 17 | (uiop:*uninteresting-compiler-conditions* 18 | (append '(#+sbcl sb-int:package-at-variance) 19 | uiop:*uninteresting-compiler-conditions*))) 20 | (with-standard-io-syntax 21 | (let (;; Compilation fails because of CFFI types that 22 | ;; can't be printed readably, so bind to NIL 23 | (*print-readably* nil)) 24 | (funcall continuation))))) 25 | -------------------------------------------------------------------------------- /src/sockets/namedb/etc-files.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; etc-files.lisp --- Common parsing routines for /etc namedb files. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defun space-char-p (char) 9 | (declare (type character char)) 10 | (or (char= char #\Space) 11 | (char= char #\Tab))) 12 | 13 | (defun split-etc-tokens (line) 14 | (declare (type string line)) 15 | (let ((comment-start (position #\# line))) 16 | (split-sequence-if #'space-char-p line 17 | :remove-empty-subseqs t 18 | :start 0 :end comment-start))) 19 | 20 | (defun map-etc-file (thunk file) 21 | (with-open-file (fin file :external-format :latin-1) 22 | (loop :for line := (read-line fin nil nil) 23 | :while line :do (funcall thunk (split-etc-tokens line))))) 24 | -------------------------------------------------------------------------------- /src/streams/gray/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Gray stream conditions. 4 | ;;; 5 | 6 | (in-package :iolib/streams) 7 | 8 | (define-condition hangup (stream-error) 9 | () 10 | (:report (lambda (c s) 11 | (format s "Stream ~S hang up." 12 | (stream-error-stream c)))) 13 | (:documentation "Condition signaled when the underlying device of a stream 14 | is closed by the remote end while writing to it.")) 15 | 16 | (define-condition no-characters-to-unread (stream-error) 17 | () 18 | (:report (lambda (c s) 19 | (format s "No uncommitted character to unread on stream ~S." 20 | (stream-error-stream c)))) 21 | (:documentation "Condition signaled when UNREAD-CHAR is called on a stream either: 22 | 1) without having been preceded by a READ-CHAR, or 23 | 2) after a PEEK-CHAR")) 24 | -------------------------------------------------------------------------------- /src/sockets/config.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Special variable definitions. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defvar *ipv6* nil 9 | "Specifies the default behaviour with respect to IPv6: 10 | - nil : Only IPv4 addresses are used. 11 | - :ipv6 : Only IPv6 addresses are used. 12 | - t : If both IPv4 and IPv6 addresses are found they are returned in the best order possible (see RFC 3484). 13 | Default value is NIL.") 14 | 15 | (deftype *ipv6*-type () 16 | '(member t nil :ipv6)) 17 | 18 | (defconstant +max-backlog-size+ somaxconn 19 | "Maximum length of the pending connections queue (hard limit).") 20 | 21 | (defvar *default-backlog-size* 5 22 | "Default length of the pending connections queue (soft limit).") 23 | 24 | (defvar *default-linger-seconds* 15 25 | "Default linger timeout when enabling SO_LINGER option on a socket.") 26 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | os: linux 2 | dist: jammy 3 | language: generic 4 | 5 | env: 6 | jobs: 7 | - LISP=sbcl 8 | - LISP=ccl 9 | - LISP=ecl 10 | # - LISP=allegro 11 | # - LISP=cmucl 12 | 13 | jobs: 14 | fast_finish: true 15 | allow_failures: 16 | # - env: LISP=allegro 17 | # - env: LISP=cmucl 18 | - env: LISP=ecl 19 | 20 | notifications: 21 | email: 22 | on_success: change 23 | on_failure: always 24 | irc: 25 | channels: 26 | - "irc.libera.chat#iolib" 27 | on_success: change 28 | on_failure: always 29 | use_notice: true 30 | skip_join: true 31 | 32 | install: 33 | - curl -L https://raw.githubusercontent.com/lispci/cl-travis/master/install.sh | sh 34 | - sudo ./install-repo.bash "$LISP" 35 | 36 | script: 37 | - cl -e "(cl:in-package :cl-user) 38 | (ql:quickload :iolib/tests :verbose t) 39 | (uiop:quit (if (5am:run! :iolib) 0 1))" 40 | -------------------------------------------------------------------------------- /src/multiplex/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Miscellaneous utilities. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | (defun timeout->timeval (timeout tv) 9 | (with-foreign-slots ((isys:sec isys:usec) 10 | tv (:struct isys:timeval)) 11 | (multiple-value-bind (%sec %usec) 12 | (decode-timeout timeout) 13 | (setf isys:sec %sec 14 | isys:usec %usec)))) 15 | 16 | (defun timeout->timespec (timeout ts) 17 | (with-foreign-slots ((isys:sec isys:nsec) 18 | ts (:struct isys:timespec)) 19 | (multiple-value-bind (%sec %usec) 20 | (decode-timeout timeout) 21 | (setf isys:sec %sec 22 | isys:nsec (* 1000 %usec))))) 23 | 24 | (defun timeout->milliseconds (timeout) 25 | (if timeout 26 | (multiple-value-bind (sec usec) 27 | (decode-timeout timeout) 28 | (+ (* sec 1000) 29 | (truncate usec 1000))) 30 | -1)) 31 | -------------------------------------------------------------------------------- /src/iolib/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (macrolet 9 | ((defconduit (name &body clauses) 10 | (assert (= 1 (length clauses))) 11 | (assert (eql :use (caar clauses))) 12 | (flet ((get-symbols (packages) 13 | (let (symbols) 14 | (with-package-iterator (iterator packages :external) 15 | (loop (multiple-value-bind (morep symbol) (iterator) 16 | (unless morep (return)) 17 | (push symbol symbols)))) 18 | (remove-duplicates symbols)))) 19 | `(defpackage ,name 20 | (:use #:common-lisp ,@(cdar clauses)) 21 | (:export ,@(get-symbols (cdar clauses))))))) 22 | 23 | (defconduit :iolib 24 | (:use :iolib/multiplex :iolib/streams :iolib/sockets))) 25 | 26 | ;; SBCL changes *package* if LOAD-OPing :iolib in the REPL 27 | t 28 | -------------------------------------------------------------------------------- /src/os/ffi-types-unix.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Foreign types related to lfp_spawn(3) 4 | ;;; 5 | 6 | (in-package :iolib/os) 7 | 8 | (pkg-config-cflags "libfixposix") 9 | 10 | (include "lfp.h") 11 | 12 | (constant (+stdin+ "STDIN_FILENO")) 13 | (constant (+stdout+ "STDOUT_FILENO")) 14 | (constant (+stderr+ "STDERR_FILENO")) 15 | 16 | (cstruct lfp-spawnattr-t "lfp_spawnattr_t") 17 | 18 | (cstruct lfp-spawn-file-actions-t "lfp_spawn_file_actions_t") 19 | 20 | (constant (lfp-spawn-setsigmask "LFP_SPAWN_SETSIGMASK")) 21 | (constant (lfp-spawn-setsigdefault "LFP_SPAWN_SETSIGDEFAULT")) 22 | (constant (lfp-spawn-setpgroup "LFP_SPAWN_SETPGROUP")) 23 | (constant (lfp-spawn-resetids "LFP_SPAWN_RESETIDS")) 24 | (constant (lfp-spawn-setuid "LFP_SPAWN_SETUID")) 25 | (constant (lfp-spawn-setgid "LFP_SPAWN_SETGID")) 26 | (constant (lfp-spawn-usevfork "LFP_SPAWN_USEVFORK")) 27 | ;; (constant (lfp-spawn-setschedparam "LFP_SPAWN_SETSCHEDPARAM")) 28 | ;; (constant (lfp-spawn-setscheduler "LFP_SPAWN_SETSCHEDULER")) 29 | -------------------------------------------------------------------------------- /src/streams/gray/fd-mixin.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- FD mixin definitions 4 | ;;; 5 | 6 | (in-package :iolib/streams) 7 | 8 | (defmethod shared-initialize :around ((stream dual-channel-fd-mixin) slot-names &key) 9 | (declare (ignore slot-names)) 10 | (call-next-method) 11 | (setf (isys:fd-nonblock-p (fd-of stream)) t)) 12 | 13 | ;;;; CLOSE 14 | 15 | (defmethod close :before ((fd-mixin dual-channel-fd-mixin) &key abort) 16 | (declare (ignore abort)) 17 | (when (fd-of fd-mixin) 18 | (isys:close (fd-of fd-mixin)) 19 | (setf (fd-of fd-mixin) nil))) 20 | 21 | ;;;; Get and Set O_NONBLOCK 22 | 23 | (defmethod fd-non-blocking ((fd-mixin dual-channel-fd-mixin)) 24 | (isys:fd-nonblock-p (fd-of fd-mixin))) 25 | (defobsolete fd-non-blocking "stream FDs are now always non-blocking.") 26 | 27 | (defmethod (setf fd-non-blocking) (mode (fd-mixin dual-channel-fd-mixin)) 28 | (check-type mode boolean "a boolean value") 29 | (setf (isys:fd-nonblock-p (fd-of fd-mixin)) mode)) 30 | (defobsolete (setf fd-non-blocking) "stream FDs are now always non-blocking.") 31 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*- 2 | 3 | MANUAL := "iolib" 4 | SYSTEM := "iolib" 5 | PACKAGES := sockets iolib.streams 6 | TITLE := "IOLib Manual" 7 | CSS := "default" 8 | 9 | export LISP ?= sbcl 10 | export SBCL_OPTIONS ?= --noinform 11 | 12 | .PHONY: all clean html pdf upload 13 | 14 | all: 15 | texinfo-docstrings all $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES) 16 | 17 | pdf: 18 | texinfo-docstrings pdf $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES) 19 | 20 | html: 21 | texinfo-docstrings html $(SYSTEM) $(MANUAL) $(TITLE) $(CSS) $(PACKAGES) 22 | 23 | upload: 24 | # rsync -av --delete -e ssh manual common-lisp.net:/project/FOO/public_html/ 25 | # scp -r manual common-lisp.net:/project/cffi/public_html/ 26 | 27 | clean: 28 | find . \( -name "*.pdf" -o -name "*.html" -o -name "*.info" -o -name "*.aux" -o -name "*.cp" -o -name "*.fn" -o -name "*.fns" -o -name "*.ky" -o -name "*.log" -o -name "*.pg" -o -name "*.toc" -o -name "*.tp" -o -name "*.vr" -o -name "*.dvi" -o -name "*.cps" -o -name "*.vrs" \) -exec rm {} \; 29 | rm -rf include manual 30 | 31 | # vim: ft=make ts=4 noet 32 | -------------------------------------------------------------------------------- /doc/license.texinfo: -------------------------------------------------------------------------------- 1 | @quotation 2 | Permission is hereby granted, free of charge, to any person obtaining 3 | a copy of this software and associated documentation files (the 4 | ``Software''), to deal in the Software without restriction, including 5 | without limitation the rights to use, copy, modify, merge, publish, 6 | distribute, sublicense, and/or sell copies of the Software, and to 7 | permit persons to whom the Software is furnished to do so, subject to 8 | the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be 11 | included in all copies or substantial portions of the Software. 12 | 13 | @sc{The software is provided ``as is'', without warranty of any kind, 14 | express or implied, including but not limited to the warranties of 15 | merchantability, fitness for a particular purpose and noninfringement. 16 | In no event shall the authors or copyright holders be liable for any 17 | claim, damages or other liability, whether in an action of contract, 18 | tort or otherwise, arising from, out of or in connection with the 19 | software or the use or other dealings in the software.} 20 | @end quotation 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | -*- markdown -*- 2 | 3 | * Compilation IOlib requires a C library named LibFixPOSIX - 4 | https://github.com/sionescu/libfixposix - and its headers in order to 5 | compile. LibFixPOSIX can either be installed manually, for which there 6 | are instructions in the source code, or through distro repositories. 7 | 8 | As of Debian 9.0 Stable, the libfixposix package uses code from 2011, 9 | which is incompatible with the current IOlib and will cause a SEGFAULT 10 | on load. Don't use it. 11 | 12 | * Tests 13 | Some of the socket tests require an echo server, the default being 14 | one on the Internet. If you can't use that, set 15 | iolib-tests:*echo-address* and iolib-test:*echo-port* appropriately to 16 | point the echo tests somewhere else. 17 | 18 | * Generating documentation 19 | To generate the documentation, use this patched version of 20 | texinfo-docstrings: http://gitorious.org/iolib/texinfo-docstrings 21 | Then make sure that IOLib's .asd files and texinfo-docstrings.asd can 22 | be loaded and run GNU make inside doc/ ; you'll then find the 23 | generated docs under manual/. This procedure has only been tested 24 | with SBCL. 25 | -------------------------------------------------------------------------------- /iolib.common-lisp.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defsystem :iolib.common-lisp 4 | :description "Slightly modified Common Lisp." 5 | :author "Stelian Ionescu " 6 | :licence "MIT" 7 | :version (:read-file-form "version.sexp") 8 | :defsystem-depends-on (:iolib.asdf :iolib.conf) 9 | :depends-on (:alexandria) 10 | :around-compile "iolib/asdf:compile-wrapper" 11 | :encoding :utf-8 12 | :pathname "src/new-cl/" 13 | :components 14 | ((:file "conduits") 15 | #+scl (:file "scl-gray-streams") 16 | (:file "pkgdcl" :depends-on ("conduits" #+scl "scl-gray-streams") 17 | :perform 18 | (compile-op :before (o c) 19 | (symbol-call :iolib.conf '#:load-gray-streams)) 20 | :perform 21 | (load-op :before (o c) 22 | (symbol-call :iolib.conf '#:load-gray-streams)) 23 | :perform 24 | (load-source-op :before (o c) 25 | (symbol-call :iolib.conf '#:load-gray-streams))) 26 | (:file "gray-streams" 27 | :depends-on ("pkgdcl" #+scl "scl-gray-streams")) 28 | (:file "definitions" :depends-on ("pkgdcl")) 29 | (:file "types" :depends-on ("pkgdcl")))) 30 | 31 | -------------------------------------------------------------------------------- /install-repo.bash: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -o pipefail # trace ERR through pipes 4 | set -o errtrace # trace ERR through 'time command' and other functions 5 | set -o nounset ## set -u : exit the script if you try to use an uninitialised variable 6 | set -o errexit ## set -e : exit the script if any statement returns a non-true return value 7 | set -o xtrace # print commands as they are executed 8 | 9 | ARCH=amd64 10 | case "$1" in 11 | allegro | *32 ) ARCH=i386 ;; 12 | esac 13 | 14 | KEYFILE=/etc/apt/keyrings/obs-sionescu.key 15 | cat > /etc/apt/sources.list.d/libfixposix.list < /etc/apt/preferences.d/libfixposix <" 6 | :licence "MIT" 7 | :version (:read-file-form "version.sexp") 8 | :defsystem-depends-on (:iolib.asdf :iolib.conf) 9 | :depends-on (:iolib.common-lisp :alexandria :split-sequence) 10 | :around-compile "iolib/asdf:compile-wrapper" 11 | :encoding :utf-8 12 | :pathname "src/base/" 13 | :components 14 | ((:file "pkgdcl") 15 | (:file "return-star" :depends-on ("pkgdcl")) 16 | (:file "types" :depends-on ("pkgdcl" "return-star")) 17 | (:file "debug" :depends-on ("pkgdcl" "return-star")) 18 | (:file "conditions" :depends-on ("pkgdcl" "return-star")) 19 | (:file "defalias" :depends-on ("pkgdcl" "return-star")) 20 | (:file "deffoldable" :depends-on ("pkgdcl" "return-star")) 21 | (:file "defobsolete" :depends-on ("pkgdcl" "return-star")) 22 | (:file "reader" :depends-on ("pkgdcl" "return-star" "conditions")) 23 | (:file "sequence" :depends-on ("pkgdcl" "return-star")) 24 | (:file "matching" :depends-on ("pkgdcl" "return-star")) 25 | (:file "time" :depends-on ("pkgdcl" "return-star")) 26 | (:file "dynamic-buffer" :depends-on ("pkgdcl" "return-star" "sequence")))) 27 | -------------------------------------------------------------------------------- /src/pathnames/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/pathnames 9 | (:nicknames :ipath :iolib.pathnames) 10 | (:use :iolib/base) 11 | (:export 12 | ;; Classes and types 13 | #:file-path #:file-path-designator 14 | #+unix #:unix-path 15 | #+windows #:unc-path 16 | 17 | ;; Accessors 18 | #:file-path-host 19 | #:file-path-device 20 | #:file-path-components 21 | #:file-path-directory 22 | #:file-path-file 23 | #:file-path-file-name 24 | #:file-path-file-type 25 | #:file-path-namestring 26 | #:file-path-trailing-delimiter 27 | 28 | ;; Constructors 29 | #:file-path 30 | #:make-file-path 31 | #:parse-file-path 32 | 33 | ;; Named reader 34 | #:p 35 | 36 | ;; Operations 37 | #:merge-file-paths 38 | #:enough-file-path 39 | 40 | ;; Predicates 41 | #:file-path-p 42 | #:absolute-file-path-p 43 | #:relative-file-path-p 44 | 45 | ;; Conditions 46 | #:invalid-file-path 47 | 48 | ;; Constants 49 | #:+directory-delimiter+ 50 | #:+alternative-delimiter+ 51 | #:+execution-path-delimiter+ 52 | 53 | ;; Specials 54 | #:*default-file-path-defaults* 55 | #:*default-execution-path*)) 56 | -------------------------------------------------------------------------------- /src/sockets/dns/common.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- DNS client constants. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defconstant +dns-max-datagram-size+ 4096) 9 | 10 | (defconstant +opcode-standard+ 0) 11 | 12 | ;;; Query types 13 | 14 | (defconstant (+query-type-map+ :test 'equal) 15 | '((:a . 1) (:ns . 2) (:cname . 5) (:soa . 6) 16 | (:wks . 11) (:ptr . 12) (:hinfo . 13) (:mx . 15) 17 | (:txt . 16) (:aaaa . 28) (:srv . 33) (:any . 255))) 18 | 19 | (defun query-type-number (id) 20 | (cdr (assoc id +query-type-map+))) 21 | 22 | (defun query-type-id (number) 23 | (car (rassoc number +query-type-map+))) 24 | 25 | (defun dns-record-type-p (id) 26 | (query-type-number id)) 27 | 28 | ;;; Query classes 29 | 30 | (defconstant (+query-class-map+ :test 'equal) 31 | '((:in . 1) (:any . 255))) 32 | 33 | (defun query-class-number (id) 34 | (cdr (assoc id +query-class-map+))) 35 | 36 | (defun query-class-id (number) 37 | (car (rassoc number +query-class-map+))) 38 | 39 | ;;; Error codes 40 | 41 | (defconstant (+rcode-map+ :test 'equal) 42 | '((:no-error . 0) (:format-error . 1) 43 | (:server-failure . 2) (:name-error . 3) 44 | (:not-implemented . 4) (:refused . 5))) 45 | 46 | (defun rcode-number (id) 47 | (cdr (assoc id +rcode-map+))) 48 | 49 | (defun rcode-id (number) 50 | (car (rassoc number +rcode-map+))) 51 | -------------------------------------------------------------------------------- /src/base/time.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Time utils. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (deftype timeout () 9 | 'double-float) 10 | 11 | (deftype timeout-designator () 12 | '(or non-negative-real (member t nil))) 13 | 14 | (deftype positive-timeout-designator () 15 | '(or non-negative-real (eql t))) 16 | 17 | ;;; Break a real timeout into seconds and microseconds. 18 | (defun decode-timeout (timeout) 19 | (assert (or (not timeout) 20 | (and (typep timeout 'real) 21 | (not (minusp timeout)))) 22 | (timeout) 23 | "The timeout must be a non-negative real or NIL: ~S" timeout) 24 | (typecase timeout 25 | (null nil) 26 | (integer (values timeout 0)) 27 | (real 28 | (multiple-value-bind (q r) (truncate (coerce timeout 'timeout)) 29 | (declare (type unsigned-byte q) 30 | (type timeout r)) 31 | (values q (the (values unsigned-byte t) (truncate (* r 1d6)))))))) 32 | 33 | (defun normalize-timeout (timeout) 34 | (assert (and (typep timeout 'real) 35 | (not (minusp timeout))) 36 | (timeout) 37 | "The timeout must be non-negative: ~A" timeout) 38 | (coerce timeout 'timeout)) 39 | 40 | (defun clamp-timeout (timeout &optional (min 0) (max most-positive-fixnum)) 41 | (clamp (or timeout most-positive-fixnum) 42 | (if min (max min 0) 0) (or max most-positive-fixnum))) 43 | -------------------------------------------------------------------------------- /src/base/deffoldable.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Declaring forms as foldable(pure) 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | #+sbcl 9 | (defmacro %deffoldable (func argument-types return-type) 10 | `(sb-c:defknown ,func ,argument-types ,return-type (sb-c:foldable) 11 | :overwrite-fndb-silently t)) 12 | 13 | #-(or sbcl) 14 | (defmacro %deffoldable (&rest args) 15 | (declare (ignore args))) 16 | 17 | (defun constantp (form &optional env) 18 | (cl:constantp (if (symbolp form) 19 | (macroexpand form env) 20 | form) 21 | env)) 22 | 23 | (defun constant-form-value (form &optional env) 24 | (declare (ignorable env)) 25 | #+clozure 26 | (ccl::eval-constant form) 27 | #+sbcl 28 | (sb-int:constant-form-value form env) 29 | #-(or clozure sbcl) 30 | (eval form)) 31 | 32 | (defmacro deffoldable (func &optional 33 | (argument-types (list t)) 34 | (return-type t)) 35 | (alexandria:with-gensyms (form env args) 36 | `(eval-when (:compile-toplevel :load-toplevel :execute) 37 | (%deffoldable ,func ,argument-types ,return-type) 38 | (define-compiler-macro ,func (&whole ,form &rest ,args 39 | &environment ,env) 40 | (declare (ignore ,args)) 41 | (if (constantp ,form ,env) 42 | (constant-form-value ,form ,env) 43 | ,form))))) 44 | -------------------------------------------------------------------------------- /src/base/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Types. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (deftype function-designator () 9 | '(or symbol function)) 10 | 11 | (defun symbol-with-name-of-length-one (thing) 12 | (if (and (symbolp thing) 13 | (= 1 (length (symbol-name thing)))) 14 | (char (symbol-name thing) 0) 15 | nil)) 16 | 17 | (deftype character-designator () 18 | '(or character (string 1) (satisfies symbol-with-name-of-length-one))) 19 | 20 | 21 | ;; Vector types 22 | 23 | (deftype ub8 () '(unsigned-byte 8)) 24 | (deftype ub16 () '(unsigned-byte 16)) 25 | (deftype ub32 () '(unsigned-byte 32)) 26 | (deftype ub64 () '(unsigned-byte 64)) 27 | (deftype sb8 () '(signed-byte 8)) 28 | (deftype sb16 () '(signed-byte 16)) 29 | (deftype sb32 () '(signed-byte 32)) 30 | (deftype sb64 () '(signed-byte 64)) 31 | 32 | (deftype ub8-sarray (&optional (size '*)) 33 | `(simple-array ub8 (,size))) 34 | (deftype ub8-vector (&optional (size '*)) 35 | `(vector ub8 ,size)) 36 | 37 | (deftype ub16-sarray (&optional (size '*)) 38 | `(simple-array ub16 (,size))) 39 | (deftype ub16-vector (&optional (size '*)) 40 | `(vector ub16 ,size)) 41 | 42 | (deftype ub32-sarray (&optional (size '*)) 43 | `(simple-array ub32 (,size))) 44 | (deftype ub32-vector (&optional (size '*)) 45 | `(vector ub32 ,size)) 46 | 47 | (deftype ub64-sarray (&optional (size '*)) 48 | `(simple-array ub64 (,size))) 49 | (deftype ub64-vector (&optional (size '*)) 50 | `(vector ub64 ,size)) 51 | -------------------------------------------------------------------------------- /src/sockets/dns/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Resolver conditions. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (define-condition resolver-error (isys:iolib-error) 9 | ((datum :initarg :data :reader resolver-error-datum)) 10 | (:documentation 11 | "Signaled when an error occurs while trying to resolve an address.")) 12 | (setf (documentation 'resolver-error-datum 'function) 13 | "Return the datum that caused the signalling of a RESOLVER-ERROR condition.") 14 | 15 | (defmacro define-resolver-error (name format-string &optional documentation) 16 | `(define-condition ,name (resolver-error) () 17 | (:report (lambda (condition stream) 18 | (format stream ,format-string (resolver-error-datum condition)))) 19 | (:documentation ,documentation))) 20 | 21 | (define-resolver-error resolver-again-error 22 | "Temporary failure occurred while resolving: ~S" 23 | "Condition signaled when a temporary failure occurred.") 24 | 25 | (define-resolver-error resolver-fail-error 26 | "Non recoverable error occurred while resolving: ~S" 27 | "Condition signaled when a non-recoverable error occurred.") 28 | 29 | (define-resolver-error resolver-no-name-error 30 | "Host or service not found: ~S" 31 | "Condition signaled when a host or service was not found.") 32 | 33 | (define-resolver-error resolver-unknown-error 34 | "Unknown error while resolving: ~S" 35 | "Condition signaled when an unknown error is signaled while resolving 36 | an address.") 37 | -------------------------------------------------------------------------------- /examples/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 2 | ;;;; and this code is released under the same license as IOLib. 3 | 4 | (defpackage :iolib.examples 5 | (:nicknames :iolib/examples) 6 | (:use :cl :iolib :bordeaux-threads) 7 | #+sb-package-locks 8 | (:lock t) 9 | (:export :run-ex1-client 10 | :run-ex2-client 11 | :run-ex3-client 12 | :run-ex4-client 13 | :run-ex5a-client 14 | :run-ex5b-client 15 | 16 | :run-ex1-server 17 | :run-ex2-server 18 | :run-ex3-server 19 | :run-ex4-server 20 | :run-ex5-server 21 | :run-ex6-server 22 | :run-ex7-server 23 | :run-ex8-server 24 | )) 25 | 26 | (in-package :iolib.examples) 27 | 28 | ;;;; This file also contains some simply utilities to help the writing of the 29 | ;;;; examples. 30 | 31 | ;; The example host:port to which clients connect. Servers often bind to 32 | ;; any interface, but listen on this port. 33 | (defparameter *host* "localhost") 34 | (defparameter *port* 9999) 35 | 36 | ;; A simple, but efficient, queue implementation, used by some examples. 37 | (defun make-queue () 38 | (cons nil nil)) 39 | 40 | (defun enqueue (obj q) 41 | (if (null (car q)) 42 | (setf (cdr q) (setf (car q) (list obj))) 43 | (setf (cdr (cdr q)) (list obj) 44 | (cdr q) (cdr (cdr q)))) 45 | (car q)) 46 | 47 | (defun dequeue (q) 48 | (pop (car q))) 49 | 50 | (defun empty-queue (q) 51 | (null (car q))) 52 | 53 | -------------------------------------------------------------------------------- /src/syscalls/designators.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- CFFI type designators. 4 | ;;; 5 | 6 | (in-package :iolib/syscalls) 7 | 8 | ;;;------------------------------------------------------------------------- 9 | ;;; CFFI Type Designators 10 | ;;;------------------------------------------------------------------------- 11 | 12 | (defmacro define-designator (name cffi-type &body type-clauses) 13 | (let ((type `(quote (or ,@(mapcar #'car type-clauses)))) 14 | (ctype (format-symbol t "~A-~A" (string name) (string '#:designator)))) 15 | `(progn 16 | (deftype ,name () ,type) 17 | (defun ,name (,name) 18 | (etypecase ,name 19 | ,@type-clauses)) 20 | (define-foreign-type ,ctype () 21 | () 22 | (:simple-parser ,ctype) 23 | (:actual-type ,cffi-type)) 24 | (defmethod expand-to-foreign (value (type ,ctype)) 25 | `(convert-to-foreign 26 | (let ((,',name ,value)) 27 | (etypecase ,',name ,@',type-clauses)) 28 | ,',cffi-type))))) 29 | 30 | (define-designator pointer-or-nil :pointer 31 | (null (null-pointer)) 32 | (foreign-pointer pointer-or-nil)) 33 | 34 | (define-designator bool :int 35 | (null 0) 36 | (t 1)) 37 | 38 | 39 | ;;;------------------------------------------------------------------------- 40 | ;;; Other Types 41 | ;;;------------------------------------------------------------------------- 42 | 43 | ;;; FIXME: with fd namespaces on Linux, someday this might be no 44 | ;;; longer correct 45 | (deftype fd () '(integer 0 65535)) 46 | -------------------------------------------------------------------------------- /doc/iolib.texinfo: -------------------------------------------------------------------------------- 1 | \input texinfo @c -*-texinfo-*- 2 | @c %**start of header 3 | @setfilename iolib.info 4 | @settitle IOLib 0.6.0 Manual 5 | 6 | @c @exampleindent 2 7 | @c @documentencoding utf-8 8 | 9 | @c %**end of header 10 | 11 | @c for install-info 12 | @c @dircategory %%INFO-CATEGORY%% 13 | @c @direntry 14 | @c * net.sockets: %%PROJECT-DESCRIPTION%% 15 | @c @end direntry 16 | 17 | @include macros.texinfo 18 | 19 | @c Show types, functions, and concepts in the same index. 20 | @syncodeindex tp cp 21 | @syncodeindex fn cp 22 | 23 | @copying 24 | @c Copyright @copyright{} 2084 John Doe 25 | 26 | @include license.texinfo 27 | @end copying 28 | 29 | @titlepage 30 | @title IOLib 0.6.0 Manual 31 | @subtitle draft version 32 | @c @author John Doe 33 | @page 34 | @vskip 0pt plus 1filll 35 | @insertcopying 36 | @end titlepage 37 | 38 | @contents 39 | 40 | @ifnottex 41 | @node Top 42 | @top IOLib 43 | @insertcopying 44 | @end ifnottex 45 | 46 | @c Top Menu 47 | @menu 48 | * Overview:: 49 | @c * Stream Library:: 50 | * Networking Library:: 51 | * Comprehensive Index:: 52 | @end menu 53 | 54 | @node Overview 55 | @chapter Overview 56 | 57 | Describe IOLib here. 58 | 59 | @c @node Stream Library 60 | @c @chapter Streams 61 | @c @include streams.texinfo 62 | 63 | @node Networking Library 64 | @chapter Networking 65 | @include networking.texinfo 66 | 67 | @c We call this node ``Comprehensive Index'' so that texinfo's HTML 68 | @c output doesn't generate an index.html that'd overwrite the manual's 69 | @c initial page. 70 | @node Comprehensive Index 71 | @unnumbered Index 72 | @printindex cp 73 | 74 | @bye 75 | -------------------------------------------------------------------------------- /src/sockets/namedb/file-monitor.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; file-monitor.lisp --- Monitor files on disk. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defclass file-monitor () 9 | ((file :initform (error "Must supply a file name") 10 | :initarg :file :accessor file-of) 11 | (timestamp :initarg :timestamp :accessor timestamp-of) 12 | (update-fn :initarg :update-fn :accessor update-fn-of) 13 | (lock :initarg :lock :accessor lock-of)) 14 | (:default-initargs :timestamp 0)) 15 | 16 | (defmethod initialize-instance :after ((monitor file-monitor) &key file) 17 | (unless (slot-boundp monitor 'lock) 18 | (setf (lock-of monitor) 19 | (bt:make-lock (format nil "Lock for monitor of ~S" file))))) 20 | 21 | (defmethod print-object ((monitor file-monitor) stream) 22 | (print-unreadable-object (monitor stream :type nil :identity nil) 23 | (format stream "File monitor for ~S" (file-of monitor)))) 24 | 25 | (defun monitor-oldp (monitor) 26 | (declare (type file-monitor monitor)) 27 | (let ((mtime (file-write-date (file-of monitor)))) 28 | (values (< (timestamp-of monitor) mtime) 29 | mtime))) 30 | 31 | (defgeneric update-monitor (monitor) 32 | (:method ((monitor file-monitor)) 33 | (bt:with-lock-held ((lock-of monitor)) 34 | (multiple-value-bind (oldp mtime) (monitor-oldp monitor) 35 | (when oldp 36 | (funcall (update-fn-of monitor) (file-of monitor)) 37 | (multiple-value-prog1 38 | (values (timestamp-of monitor) mtime) 39 | (setf (timestamp-of monitor) mtime))))))) 40 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2003, Zach Beane 2 | Copyright (C) 2004, Daniel Barlow 3 | Copyright (C) 2005-2006, Emily Backes 4 | Copyright (C) 2005-2006, Dan Knapp 5 | Copyright (c) 2005 David Lichteblau 6 | Copyright (C) 2006-2008, Stelian Ionescu 7 | Copyright (C) 2007, François-René Rideau 8 | Copyright (C) 2007, Luís Oliveira 9 | Copyright (C) 2008, Attila Lendvai 10 | 11 | Permission is hereby granted, free of charge, to any person obtaining 12 | a copy of this software and associated documentation files (the 13 | "Software"), to deal in the Software without restriction, including 14 | without limitation the rights to use, copy, modify, merge, publish, 15 | distribute, sublicense, and/or sell copies of the Software, and to 16 | permit persons to whom the Software is furnished to do so, subject to 17 | the following conditions: 18 | 19 | The above copyright notice and this permission notice shall be 20 | included in all copies or substantial portions of the Software. 21 | 22 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 23 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 24 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 25 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 26 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 27 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 28 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 29 | -------------------------------------------------------------------------------- /iolib.examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (defsystem :iolib.examples 4 | :description "Examples for IOLib tutorial at http://pages.cs.wisc.edu/~psilord/blog/data/iolib-tutorial/tutorial.html" 5 | :author "Peter Keller " 6 | :maintainer "Stelian Ionescu " 7 | :licence "MIT" 8 | :version (:read-file-form "version.sexp") 9 | :defsystem-depends-on (:iolib.base) 10 | :depends-on (:iolib :bordeaux-threads) 11 | :around-compile "iolib/asdf:compile-wrapper" 12 | :pathname "examples/" 13 | :components ((:file "package") 14 | (:file "ex1-client" :depends-on ("package")) 15 | (:file "ex2-client" :depends-on ("package")) 16 | (:file "ex3-client" :depends-on ("package")) 17 | (:file "ex4-client" :depends-on ("package")) 18 | (:file "ex5a-client" :depends-on ("package")) 19 | (:file "ex5b-client" :depends-on ("package")) 20 | (:file "ex1-server" :depends-on ("package")) 21 | (:file "ex2-server" :depends-on ("package")) 22 | (:file "ex3-server" :depends-on ("package")) 23 | (:file "ex4-server" :depends-on ("package")) 24 | (:file "ex5-server" :depends-on ("package")) 25 | (:file "ex6-server" :depends-on ("package")) 26 | (:file "ex7-buffer" :depends-on ("package")) 27 | (:file "ex7-server" :depends-on ("package" "ex7-buffer")) 28 | (:file "ex8-buffer" :depends-on ("package")) 29 | (:file "ex8-server" :depends-on ("package" "ex8-buffer")))) 30 | -------------------------------------------------------------------------------- /src/multiplex/fd-entry.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; fd-entry.lisp --- FD event structure. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | ;;;; EVENT 9 | 10 | (deftype fd-event-type () 11 | '(member :read :write)) 12 | 13 | (defstruct (fd-handler 14 | (:constructor make-fd-handler 15 | (fd type callback one-shot-p &optional timer)) 16 | (:copier nil)) 17 | (fd nil :type unsigned-byte) 18 | (type nil :type fd-event-type) 19 | (callback nil :type function-designator) 20 | (timer nil :type (or null timer)) 21 | ;; one-shot events are removed after being triggered 22 | (one-shot-p nil :type boolean)) 23 | 24 | ;;;; FD-ENTRY 25 | 26 | (defstruct (fd-entry 27 | (:constructor make-fd-entry (fd)) 28 | (:copier nil)) 29 | (fd 0 :type unsigned-byte) 30 | (read-handler nil :type (or null fd-handler)) 31 | (write-handler nil :type (or null fd-handler)) 32 | (write-ts 0.0d0 :type double-float) 33 | (error-callback nil :type (or null function-designator))) 34 | 35 | (defun fd-entry-handler (fd-entry event-type) 36 | (case event-type 37 | (:read (fd-entry-read-handler fd-entry)) 38 | (:write (fd-entry-write-handler fd-entry)))) 39 | 40 | (defun (setf fd-entry-handler) (event fd-entry event-type) 41 | (case event-type 42 | (:read (setf (fd-entry-read-handler fd-entry) event)) 43 | (:write (setf (fd-entry-write-handler fd-entry) event)))) 44 | 45 | (defun fd-entry-empty-p (fd-entry) 46 | (and (null (fd-entry-read-handler fd-entry)) 47 | (null (fd-entry-write-handler fd-entry)))) 48 | -------------------------------------------------------------------------------- /examples/ex2-client.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This example is almost the same as ex1-client.lisp, except we move it 7 | ;;;; closer to a Common Lisp style. 8 | 9 | ;; ex-0b 10 | (defun run-ex2-client (&key (host *host*) (port *port*)) 11 | 12 | ;; We introduce with-open-socket here as a means to easily wrap 13 | ;; usually synchronous and blocking communication with a form that 14 | ;; ensures the socket is closed no matter how we exit it. 15 | (with-open-socket 16 | (socket :connect :active 17 | :address-family :internet 18 | :type :stream 19 | :external-format '(:utf-8 :eol-style :crlf) 20 | :ipv6 nil) 21 | 22 | ;; Do a blocking connect to the daytime server on the port. We 23 | ;; also introduce lookup-hostname, which converts a hostname to an 24 | ;; 4 values, but in our case we only want the first, which is an 25 | ;; address. 26 | (connect socket (lookup-hostname host) :port port :wait t) 27 | (format t "Connected to server ~A:~A from my local connection at ~A:~A!~%" 28 | (remote-name socket) (remote-port socket) 29 | (local-name socket) (local-port socket)) 30 | 31 | ;; read the one line of information I need from the daytime 32 | ;; server. I can use read-line here because this is a TCP 33 | ;; socket. It will block until the whole line is read. 34 | (let ((line (read-line socket))) 35 | (format t "~A" line) 36 | t))) 37 | ;; ex-0e 38 | -------------------------------------------------------------------------------- /src/base/sequence.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Sequence utils 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (defmacro check-bounds (sequence start end) 9 | (with-gensyms (length) 10 | `(let ((,length (length ,sequence))) 11 | (check-type ,start unsigned-byte "a non-negative integer") 12 | (when ,end (check-type ,end unsigned-byte "a non-negative integer or NIL")) 13 | (unless ,end 14 | (setf ,end ,length)) 15 | (unless (<= ,start ,end ,length) 16 | (error "Wrong sequence bounds. start: ~S end: ~S" ,start ,end))))) 17 | 18 | (declaim (inline %join)) 19 | (defun %join (connector strings) 20 | (concatenate 'string (car strings) 21 | (reduce (lambda (str1 str2) 22 | (concatenate 'string str1 connector str2)) 23 | (cdr strings) 24 | :initial-value ""))) 25 | 26 | (declaim (inline join)) 27 | (defun join (connector &rest strings) 28 | (%join (string connector) strings)) 29 | 30 | (declaim (inline join*)) 31 | (defun join* (connector strings) 32 | (%join (string connector) strings)) 33 | 34 | (defmacro shrink-vector (str size) 35 | #+allegro `(excl::.primcall 'sys::shrink-svector ,str ,size) 36 | #+cmu `(lisp::shrink-vector ,str ,size) 37 | #+lispworks `(system::shrink-vector$vector ,str ,size) 38 | #+sbcl `(sb-kernel:shrink-vector ,str ,size) 39 | #+scl `(common-lisp::shrink-vector ,str ,size) 40 | #-(or allegro cmu lispworks sbcl scl) `(subseq ,str 0 ,size)) 41 | 42 | (declaim (inline full-string)) 43 | (defun full-string (string) 44 | (etypecase string 45 | (string 46 | (if (zerop (length string)) 47 | nil 48 | string)))) 49 | -------------------------------------------------------------------------------- /src/os/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/os 9 | (:nicknames :iolib.os) 10 | (:use :iolib/base :iolib/pathnames :cffi) 11 | (:import-from :iolib/syscalls 12 | #:defsyscall #:sstring 13 | #:mode-t #:pid-t #:uid-t #:gid-t 14 | #:get-monotonic-time) 15 | (:import-from :iolib/pathnames #:split-root/nodes) 16 | (:export 17 | 18 | ;; Evironment 19 | #:environment 20 | #:environment-variable 21 | #:makunbound-environment-variable 22 | #:clear-environment 23 | 24 | ;; Processes 25 | #:process 26 | #:process-pid 27 | #:process-pty 28 | #:process-stdin 29 | #:process-stdout 30 | #:process-stderr 31 | #:process-status 32 | #:create-process 33 | #:run-program 34 | #:process-activep 35 | #:process-kill 36 | #:+stdin+ 37 | #:+stdout+ 38 | #:+stderr+ 39 | 40 | ;; Directories 41 | #:current-directory 42 | #:with-current-directory 43 | #:delete-files 44 | #:directory-exists-p 45 | #:list-directory 46 | #:mapdir 47 | #:walk-directory 48 | #:with-directory-iterator 49 | 50 | ;; Files 51 | #:absolute-file-path 52 | #:resolve-file-path 53 | #:file-exists-p 54 | #:good-symlink-exists-p 55 | #:regular-file-exists-p 56 | #:file-kind 57 | 58 | ;; Symlinks 59 | #:read-symlink 60 | #:make-symlink 61 | #:make-hardlink 62 | 63 | ;; Permissions 64 | #:file-permissions 65 | 66 | ;; Temporary files 67 | ;; #:open-temporary-file 68 | ;; #:with-temporary-file 69 | 70 | ;; Password entries 71 | #:user-info 72 | 73 | ;; Time 74 | #:get-monotonic-time 75 | 76 | ;; Specials 77 | #:*temporary-directory* 78 | )) 79 | -------------------------------------------------------------------------------- /examples/ex1-client.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; The entry call to this example is: (run-ex1-client) It can take 7 | ;;;; two keyword arguements of :host STRING and :port INTEGER. 8 | 9 | ;;;; This example implements a very simple IPV4 TCP blocking i/o 10 | ;;;; client which talks to a date server. After connecting to the date 11 | ;;;; server, a single line is sent from the server to the cilent and 12 | ;;;; then the client disconnects. 13 | 14 | ;;;; We don't handle many errors and this code is written from a 15 | ;;;; C-style perspective that we will avoid where possible in future 16 | ;;;; examples. 17 | 18 | ;; ex-0b 19 | (defun run-ex1-client (&key (host *host*) (port *port*)) 20 | ;; ex-0e 21 | 22 | ;; ex-1b 23 | ;; Create a internet TCP socket under IPV4 24 | (let ((socket 25 | (make-socket 26 | :connect :active 27 | :address-family :internet 28 | :type :stream 29 | :external-format '(:utf-8 :eol-style :crlf) 30 | :ipv6 nil))) 31 | ;; ex-1e 32 | 33 | ;; ex-2b 34 | ;; do a blocking connect to the daytime server on the port. 35 | (connect socket (lookup-hostname host) :port port :wait t) 36 | (format t "Connected to server ~A:~A via my local connection at ~A:~A!~%" 37 | (remote-host socket) (remote-port socket) 38 | (local-host socket) (local-port socket)) 39 | ;; ex-2e 40 | 41 | ;; ex-3b 42 | ;; read the one line of information I need from the daytime 43 | ;; server. I can use read-line here because this is a TCP socket. 44 | (let ((line (read-line socket))) 45 | (format t "~A" line)) 46 | ;; ex-3e 47 | 48 | ;; ex-4b 49 | ;; all done 50 | (close socket) 51 | t)) 52 | ;; ex-4e 53 | -------------------------------------------------------------------------------- /src/base/reader.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Reader utils 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | ;; Literal object dispatcher 9 | 10 | (defconstant +read-literal-dispatch-char+ #\#) 11 | (defconstant +read-literal-sub-char+ #\/) 12 | 13 | (defun read-literal-dispatcher (stream char arg) 14 | (declare (ignore char arg)) 15 | (let* ((literal-syntax-name 16 | (with-output-to-string (s) 17 | (loop :for c := (read-char stream t nil t) 18 | :do (if (char= c +read-literal-sub-char+) 19 | (loop-finish) 20 | (write-char c s))))) 21 | (literal-reader 22 | (getf (symbol-plist (read-from-string literal-syntax-name)) 23 | 'read-literal-fn))) 24 | (if (functionp literal-reader) 25 | (funcall literal-reader stream) 26 | (error 'unknown-literal-syntax 27 | :stream stream 28 | :name literal-syntax-name)))) 29 | 30 | (defun enable-literal-reader* (&optional (readtable *readtable*)) 31 | (set-dispatch-macro-character +read-literal-dispatch-char+ 32 | +read-literal-sub-char+ 33 | 'read-literal-dispatcher 34 | readtable)) 35 | 36 | (defmacro enable-literal-reader (&optional (readtable '*readtable*)) 37 | `(eval-when (:compile-toplevel) 38 | (setf *readtable* (copy-readtable ,readtable)) 39 | (enable-literal-reader*))) 40 | 41 | (defmacro define-literal-reader (name (stream) &body body) 42 | `(setf (getf (symbol-plist ',name) 'read-literal-fn) 43 | (lambda (,stream) ,@body))) 44 | 45 | (defmacro fcase (&body clauses) 46 | `(cond 47 | ,@(loop :for c :in clauses 48 | :for test := (car c) 49 | :for forms := (cdr c) 50 | :collect `((featurep ',test) ,@forms)))) 51 | -------------------------------------------------------------------------------- /src/base/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Error conditions. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | ;;;------------------------------------------------------------------------- 9 | ;;; Subtype Errors 10 | ;;;------------------------------------------------------------------------- 11 | 12 | (define-condition subtype-error (error) 13 | ((datum :initarg :type :reader subtype-error-datum) 14 | (expected-supertype :initarg :expected-supertype 15 | :reader subtype-error-expected-supertype)) 16 | (:report 17 | (lambda (condition stream) 18 | (format stream "~S is not a recognizable subtype of ~S" 19 | (subtype-error-datum condition) 20 | (subtype-error-expected-supertype condition))))) 21 | 22 | 23 | ;;;------------------------------------------------------------------------- 24 | ;;; Literal Syntax Errors 25 | ;;;------------------------------------------------------------------------- 26 | 27 | (define-condition unknown-literal-syntax (reader-error) 28 | ((name :initarg :name :reader unknown-literal-syntax-name)) 29 | (:report (lambda (condition stream) 30 | (format stream "Unknown literal read syntax: ~S" 31 | (unknown-literal-syntax-name condition))))) 32 | 33 | 34 | ;;;------------------------------------------------------------------------- 35 | ;;; Bugs 36 | ;;;------------------------------------------------------------------------- 37 | 38 | (define-condition iolib-bug (error) 39 | ((message :initarg :message :reader iolib-bug-message)) 40 | (:report 41 | (lambda (condition stream) 42 | (format stream "~A.~%This seems to be a bug in IOlib. ~ 43 | Please report it to iolib-devel@common-lisp.net" 44 | (iolib-bug-message condition))))) 45 | 46 | (defun bug (control &rest args) 47 | (error 'iolib-bug :message (format nil "~?" control args))) 48 | -------------------------------------------------------------------------------- /examples/ex3-client.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This example is similar to ex2-client.lisp, except we've added in 7 | ;;;; catching of various conditions which may be signaled during the 8 | ;;;; network communication. 9 | 10 | ;; ex-0b 11 | (defun run-ex3-client-helper (host port) 12 | 13 | ;; Create a internet TCP socket under IPV4 14 | (with-open-socket 15 | (socket :connect :active 16 | :address-family :internet 17 | :type :stream 18 | :external-format '(:utf-8 :eol-style :crlf) 19 | :ipv6 nil) 20 | 21 | ;; do a blocking connect to the daytime server on the port. 22 | (connect socket (lookup-hostname host) :port port :wait t) 23 | (format t "Connected to server ~A:~A from my local connection at ~A:~A!~%" 24 | (remote-name socket) (remote-port socket) 25 | (local-name socket) (local-port socket)) 26 | 27 | (handler-case 28 | ;; read the one line of information I need from the daytime 29 | ;; server. I can use read-line here because this is a TCP 30 | ;; socket. It will block until the whole line is read. 31 | (let ((line (read-line socket))) 32 | (format t "~A" line) 33 | t) 34 | 35 | ;; However, let's notice the signaled condition if the server 36 | ;; went away prematurely... 37 | (end-of-file () 38 | (format t "Got end-of-file. Server closed connection!"))))) 39 | ;; ex-0e 40 | 41 | ;; ex-1b 42 | ;; The main entry point into ex3-client 43 | (defun run-ex3-client (&key (host *host*) (port *port*)) 44 | (handler-case 45 | 46 | (run-ex3-client-helper host port) 47 | 48 | ;; handle a commonly signaled error... 49 | (socket-connection-refused-error () 50 | (format t "Connection refused to ~A:~A. Maybe the server isn't running?~%" 51 | (lookup-hostname host) port)))) 52 | ;; ex-1e 53 | -------------------------------------------------------------------------------- /src/sockets/dns/nameservers.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Nameservers management. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defvar *resolv.conf-file* "/etc/resolv.conf") 9 | 10 | (defvar *dns-nameservers* nil 11 | "List of the DNS nameservers to use.") 12 | 13 | (defvar *dns-domain* nil 14 | "The current machine's domain.") 15 | 16 | (defvar *dns-search-domain* nil 17 | "A domain name to be appended to the name to be searched when 18 | the latter does not contain dots.") 19 | 20 | (defvar *resolvconf-lock* (bt:make-lock "/etc/resolv.conf lock")) 21 | 22 | ;;; Only parses NAMESERVER, DOMAIN and SEARCH directives, for now. 23 | (defun parse-/etc/resolv.conf (file) 24 | (let (nameservers domain search-domain) 25 | (flet ((parse-one-line (tokens) 26 | (when (< (length tokens) 2) (error 'parse-error)) 27 | (destructuring-bind (option value &rest more-values) tokens 28 | (switch (option :test #'string-equal) 29 | ("nameserver" (ignore-parse-errors 30 | (push (ensure-address value) 31 | nameservers))) 32 | ("domain" (setf domain value)) 33 | ("search" (setf search-domain (cons value more-values))))))) 34 | (map-etc-file (lambda (tokens) 35 | (ignore-errors (parse-one-line tokens))) 36 | file) 37 | (values (nreverse nameservers) domain search-domain)))) 38 | 39 | (defun update-dns-parameters (file) 40 | (multiple-value-bind (ns domain search) 41 | (parse-/etc/resolv.conf file) 42 | (setf *dns-nameservers* (or ns +ipv4-loopback+) 43 | ;; everything after the first dot 44 | *dns-domain* (cdr (split-sequence #\. domain :count 2)) 45 | *dns-search-domain* search))) 46 | 47 | (defvar *resolv.conf-monitor* 48 | (make-instance 'file-monitor 49 | :file *resolv.conf-file* 50 | :update-fn 'update-dns-parameters 51 | :lock *resolvconf-lock*)) 52 | -------------------------------------------------------------------------------- /tests/data/hebrew_utf-8_cr.txt: -------------------------------------------------------------------------------- 1 | :ץראה תאו םימשה תא םיהלא ארב תישארב א 1 םוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2 :םימה ינפ-לע תפחרמ םיהלא חורו :רוא-יהיו רוא יהי םיהלא רמאיו ג 3 םיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4 :ךשחה ןיבו רואה ןיב הליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5 :דחא םוי רקב-יהיו ברע-יהיו יהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6 :םימל םימ ןיב לידבמ רשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7 עיקרל לעמ רשא םימה ןיבו עיקרל תחתמ :ןכ-יהיו רקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8 :ינש םוי םוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9 :ןכ-יהיו השביה הארתו דחא ארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10 :בוט-יכ םיהלא אריו םימי ערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11 ץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע :ןכ-יהיו ץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12 םיהלא אריו והנימל וב-וערז רשא ירפ-השע :בוט-יכ :ישילש םוי רקב-יהיו ברע-יהיו גי 13 לידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14 םידעומלו תתאל ויהו הלילה ןיבו םויה ןיב :םינשו םימילו ץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15 :ןכ-יהיו רואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16 תלשממל ןטקה רואמה-תאו םויה תלשממל לדגה :םיבכוכה תאו הלילה ריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17 :ץראה-לע ןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18 :בוט-יכ םיהלא אריו ךשחה :יעיבר םוי רקב-יהיו ברע-יהיו טי 19 ףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20 :םימשה עיקר ינפ-לע ץראה-לע ףפועי שפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21 תאו םהנימל םימה וצרש רשא תשמרה היחה :בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ ואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22 :ץראב ברי ףועהו םימיב םימה-תא :ישימח םוי רקב-יהיו ברע-יהיו גכ 23 המהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24 :ןכ-יהיו הנימל ץרא-ותיחו שמרו המהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25 םיהלא אריו והנימל המדאה שמר-לכ תאו הנימל :בוט-יכ ונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26 המהבבו םימשה ףועבו םיה תגדב ודריו :ץראה-לע שמרה שמרה-לכבו ץראה-לכבו ארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27 :םתא ארב הבקנו רכז ותא וברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28 ףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו :ץראה-לע תשמרה היח-לכבו םימשה ערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29 וב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז :הלכאל היהי םכל ערז ערז ץע-ירפ שמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30 בשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע :ןכ-יהיו הלכאל דאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31 :יששה םוי רקב-יהיו בר -------------------------------------------------------------------------------- /src/base/matching.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Match utils 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (defmacro multiple-value-case ((values &key (test 'eql)) &body body) 9 | (setf values (ensure-list values)) 10 | (when (symbolp test) (setf test `(quote ,test))) 11 | (assert values () "Must provide at least one value to test") 12 | (let ((test-name (alexandria::extract-function-name test))) 13 | (labels ((%do-var (var val) 14 | (cond 15 | ((and (symbolp var) (member var '("_" "*") :test #'string=)) 16 | t) 17 | ((consp var) 18 | `(member ,val ',var :test ,test)) 19 | (t 20 | `(,test-name ,val ',var)))) 21 | (%do-clause (c gensyms) 22 | (destructuring-bind (vals &rest code) c 23 | (let* ((tests (remove t (mapcar #'%do-var (ensure-list vals) gensyms))) 24 | (clause-test (if (> 2 (length tests)) 25 | (first tests) 26 | `(and ,@tests)))) 27 | `(,clause-test ,@code)))) 28 | (%do-last-clause (c gensyms) 29 | (when c 30 | (destructuring-bind (test &rest code) c 31 | (if (member test '(otherwise t)) 32 | `((t ,@code)) 33 | `(,(%do-clause c gensyms))))))) 34 | (let ((gensyms (mapcar (lambda (v) (gensym (string v))) 35 | values))) 36 | `(let ,(mapcar #'list gensyms values) 37 | (declare (ignorable ,@gensyms)) 38 | (cond ,@(append (mapcar (lambda (c) (%do-clause c gensyms)) 39 | (butlast body)) 40 | (%do-last-clause (lastcar body) gensyms)))))))) 41 | 42 | (defmacro flags-case (mask &body clauses) 43 | (once-only (mask) 44 | `(progn ,@(mapcar (lambda (clause) 45 | `(when 46 | (logtest ,(let ((flags (first clause))) 47 | (if (listp flags) 48 | `(logior ,@flags) 49 | flags)) 50 | ,mask) 51 | ,@(rest clause))) 52 | clauses)))) 53 | -------------------------------------------------------------------------------- /src/streams/zeta/types.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Various types. 4 | ;;; 5 | 6 | (in-package :iolib/zstreams) 7 | 8 | (deftype octet () '(unsigned-byte 8)) 9 | (deftype ub8 () '(unsigned-byte 8)) 10 | (deftype ub16 () '(unsigned-byte 16)) 11 | (deftype ub32 () '(unsigned-byte 32)) 12 | (deftype ub64 () '(unsigned-byte 64)) 13 | (deftype sb8 () '(signed-byte 8)) 14 | (deftype sb16 () '(signed-byte 16)) 15 | (deftype sb32 () '(signed-byte 32)) 16 | (deftype sb64 () '(signed-byte 64)) 17 | 18 | (deftype ub8-vector (&optional (size '*)) 19 | `(array ub8 (,size))) 20 | 21 | (deftype ub8-simple-vector (&optional (size '*)) 22 | `(simple-array ub8 (,size))) 23 | 24 | (deftype ub8-complex-vector (&optional (size '*)) 25 | `(and (ub8-vector ,size) 26 | (not (ub8-simple-vector ,size)))) 27 | 28 | (deftype ub16-vector (&optional (size '*)) 29 | `(array ub16 (,size))) 30 | 31 | (deftype ub16-simple-vector (&optional (size '*)) 32 | `(simple-array ub16 (,size))) 33 | 34 | (deftype ub16-complex-vector (&optional (size '*)) 35 | `(and (ub16-vector ,size) 36 | (not (ub16-simple-vector ,size)))) 37 | 38 | (deftype ub32-vector (&optional (size '*)) 39 | `(array ub32 (,size))) 40 | 41 | (deftype ub32-simple-vector (&optional (size '*)) 42 | `(simple-array ub32 (,size))) 43 | 44 | (deftype ub32-complex-vector (&optional (size '*)) 45 | `(and (ub32-vector ,size) 46 | (not (ub32-simple-vector ,size)))) 47 | 48 | (deftype ub64-vector (&optional (size '*)) 49 | `(array ub64 (,size))) 50 | 51 | (deftype ub64-simple-vector (&optional (size '*)) 52 | `(simple-array ub64 (,size))) 53 | 54 | (deftype ub64-complex-vector (&optional (size '*)) 55 | `(and (ub64-vector ,size) 56 | (not (ub64-simple-vector ,size)))) 57 | 58 | ;;;------------------------------------------------------------------------- 59 | ;;; Argument Types 60 | ;;;------------------------------------------------------------------------- 61 | 62 | (deftype stream-buffering () 63 | '(member nil :line :full)) 64 | 65 | (deftype file-direction () 66 | '(member :input :output :io)) 67 | 68 | (deftype file-if-exists () 69 | '(member :default :error :error-if-symlink :delete :overwrite)) 70 | 71 | (deftype file-if-does-not-exist () 72 | '(member :default :error :create)) 73 | 74 | (deftype file-flags () 75 | '(unsigned-byte 32)) 76 | 77 | (deftype file-mode () 78 | '(unsigned-byte 32)) 79 | -------------------------------------------------------------------------------- /src/new-cl/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | (in-package :iolib/internal/conduits) 4 | 5 | (macrolet 6 | ((define-gray-streams-package () 7 | (let ((#1=gray-streams-package 8 | #+abcl :gray-streams 9 | #+allegro :excl 10 | #+(or cmu scl) :ext 11 | #+(or clisp ecl) :gray 12 | #+(or ccl openmcl) :ccl 13 | #+lispworks :stream 14 | #+sbcl :sb-gray 15 | #-(or abcl allegro cmu scl clisp ecl ccl openmcl lispworks sbcl) 16 | (cl:error "Your CL implementation isn't supported.")) 17 | (#2=gray-streams-symbols 18 | '(#:fundamental-stream #:fundamental-input-stream 19 | #:fundamental-output-stream #:fundamental-character-stream 20 | #:fundamental-binary-stream #:fundamental-character-input-stream 21 | #:fundamental-character-output-stream 22 | #:fundamental-binary-input-stream 23 | #:fundamental-binary-output-stream #:stream-read-char 24 | #:stream-unread-char #:stream-read-char-no-hang 25 | #:stream-peek-char #:stream-listen #:stream-read-line 26 | #:stream-clear-input #:stream-write-char #:stream-line-column 27 | #:stream-start-line-p #:stream-write-string #:stream-terpri 28 | #:stream-fresh-line #:stream-finish-output #:stream-force-output 29 | #:stream-clear-output #:stream-advance-to-column 30 | #:stream-read-byte #:stream-write-byte))) 31 | `(defpackage :iolib/common-lisp 32 | (:nicknames :iolib.cl :iolib.common-lisp) 33 | (:extend/excluding :common-lisp 34 | #:export #:unexport #:defpackage 35 | #:delete-package #:rename-package 36 | #:defconstant 37 | #:boolean) 38 | (:export #:defconstant #:boolean) 39 | (:extend/excluding :iolib/internal/conduits 40 | #:recompute-conduits) 41 | (:import-from ,#1# ,@#2#) 42 | (:export #:trivial-gray-stream-mixin 43 | #:stream-read-sequence 44 | #:stream-write-sequence 45 | #:stream-file-position 46 | ,@#2#))))) 47 | (define-gray-streams-package)) 48 | 49 | (defpackage :iolib/common-lisp-user 50 | (:nicknames :iolib/cl-user :iolib.cl-user) 51 | (:use :iolib/common-lisp)) 52 | -------------------------------------------------------------------------------- /tests/data/hebrew_utf-8_lf.txt: -------------------------------------------------------------------------------- 1 | :ץראה תאו םימשה תא םיהלא ארב תישארב א 1 2 | םוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2 3 | :םימה ינפ-לע תפחרמ םיהלא חורו 4 | :רוא-יהיו רוא יהי םיהלא רמאיו ג 3 5 | םיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4 6 | :ךשחה ןיבו רואה ןיב 7 | הליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5 8 | :דחא םוי רקב-יהיו ברע-יהיו 9 | יהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6 10 | :םימל םימ ןיב לידבמ 11 | רשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7 12 | עיקרל לעמ רשא םימה ןיבו עיקרל תחתמ 13 | :ןכ-יהיו 14 | רקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8 15 | :ינש םוי 16 | םוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9 17 | :ןכ-יהיו השביה הארתו דחא 18 | ארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10 19 | :בוט-יכ םיהלא אריו םימי 20 | ערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11 21 | ץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע 22 | :ןכ-יהיו 23 | ץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12 24 | םיהלא אריו והנימל וב-וערז רשא ירפ-השע 25 | :בוט-יכ 26 | :ישילש םוי רקב-יהיו ברע-יהיו גי 13 27 | לידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14 28 | םידעומלו תתאל ויהו הלילה ןיבו םויה ןיב 29 | :םינשו םימילו 30 | ץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15 31 | :ןכ-יהיו 32 | רואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16 33 | תלשממל ןטקה רואמה-תאו םויה תלשממל לדגה 34 | :םיבכוכה תאו הלילה 35 | ריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17 36 | :ץראה-לע 37 | ןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18 38 | :בוט-יכ םיהלא אריו ךשחה 39 | :יעיבר םוי רקב-יהיו ברע-יהיו טי 19 40 | ףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20 41 | :םימשה עיקר ינפ-לע ץראה-לע ףפועי 42 | שפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21 43 | תאו םהנימל םימה וצרש רשא תשמרה היחה 44 | :בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ 45 | ואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22 46 | :ץראב ברי ףועהו םימיב םימה-תא 47 | :ישימח םוי רקב-יהיו ברע-יהיו גכ 23 48 | המהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24 49 | :ןכ-יהיו הנימל ץרא-ותיחו שמרו 50 | המהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25 51 | םיהלא אריו והנימל המדאה שמר-לכ תאו הנימל 52 | :בוט-יכ 53 | ונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26 54 | המהבבו םימשה ףועבו םיה תגדב ודריו 55 | :ץראה-לע שמרה שמרה-לכבו ץראה-לכבו 56 | ארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27 57 | :םתא ארב הבקנו רכז ותא 58 | וברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28 59 | ףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו 60 | :ץראה-לע תשמרה היח-לכבו םימשה 61 | ערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29 62 | וב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז 63 | :הלכאל היהי םכל ערז ערז ץע-ירפ 64 | שמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30 65 | בשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע 66 | :ןכ-יהיו הלכאל 67 | דאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31 68 | :יששה םוי רקב-יהיו בר 69 | -------------------------------------------------------------------------------- /examples/ex2-server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This next example is a more common-lisp-like style, and when 7 | ;;;; appropriate it will be used for the rest of the examples. 8 | 9 | ;;;; It implements an IPV4 blocking i/o iterative server which serves 10 | ;;;; clients sequentially forever. There is no error handling of 11 | ;;;; client boundary conditions such as a client connection but then 12 | ;;;; immediately closing the connection. Handling errors will be in 13 | ;;;; later examples. 14 | 15 | (defun run-ex2-server (&key (port *port*)) 16 | 17 | ;; This is an appropriate use of with-open-socket since we are 18 | ;; synchronously and iteratively handling client connections. 19 | (with-open-socket 20 | (server :connect :passive 21 | :address-family :internet 22 | :type :stream 23 | :ipv6 nil 24 | :external-format '(:utf-8 :eol-style :crlf)) 25 | (format t "Created socket: ~A[fd=~A]~%" server (socket-os-fd server)) 26 | 27 | ;; Bind the socket to all interfaces with specified port. 28 | (bind-address server +ipv4-unspecified+ :port port :reuse-addr t) 29 | (format t "Bound socket: ~A~%" server) 30 | 31 | ;; Start listening on the server socket 32 | (listen-on server :backlog 5) 33 | (format t "Listening on socket bound to: ~A:~A~%" 34 | (local-host server) 35 | (local-port server)) 36 | 37 | ;; ex-0b 38 | ;; Keep accepting connections forever. 39 | (loop 40 | (format t "Waiting to accept a connection...~%") 41 | 42 | ;; Using with-accept-connection, when this form returns it will 43 | ;; automatically close the client connection. 44 | (with-accept-connection (client server :wait t) 45 | ;; When we get a new connection, show who it is from. 46 | (multiple-value-bind (who rport) 47 | (remote-name client) 48 | (format t "Got a connnection from ~A:~A!~%" who rport)) 49 | 50 | ;; Since we're using a internet TCP stream, we can use format 51 | ;; with it. However, we should be sure to finish-output in 52 | ;; order that all the data is sent. 53 | (multiple-value-bind (s m h d mon y) 54 | (get-decoded-time) 55 | (format t "Sending the time...") 56 | (format client "~A/~A/~A ~A:~A:~A~%" mon d y h m s) 57 | (finish-output client) 58 | (format t "Sent!~%") 59 | (finish-output) 60 | t))))) 61 | ;; ex-0e 62 | 63 | -------------------------------------------------------------------------------- /examples/ex4-client.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This program is a very simple echo client. After connecting to 7 | ;;;; the server it reads a line from the console, echos it to the 8 | ;;;; server, reads the response back, then echos it to 9 | ;;;; *standard-output*. We handle common conditions. Type "quit" on a 10 | ;;;; line by itself to exit the client. 11 | 12 | ;; ex-0b 13 | (defun run-ex4-client-helper (host port) 14 | 15 | ;; Create a internet TCP socket under IPV4 16 | (with-open-socket 17 | (socket :connect :active 18 | :address-family :internet 19 | :type :stream 20 | :external-format '(:utf-8 :eol-style :crlf) 21 | :ipv6 nil) 22 | 23 | ;; do a blocking connect to the daytime server on the port. 24 | (connect socket (lookup-hostname host) :port port :wait t) 25 | 26 | (format t "Connected to server ~A:~A from my local connection at ~A:~A!~%" 27 | (remote-host socket) (remote-port socket) 28 | (local-host socket) (local-port socket)) 29 | 30 | (handler-case 31 | (ex4-str-cli socket) 32 | 33 | (socket-connection-reset-error () 34 | (format t "Got connection reset. Server went away!")) 35 | 36 | (hangup () 37 | (format t "Got hangup. Server closed connection on write!~%")) 38 | 39 | (end-of-file () 40 | (format t "Got end-of-file. Server closed connection on read!~%"))))) 41 | ;; ex-0e 42 | 43 | ;; ex-1b 44 | ;; read a line from stdin, write it to the server, read the response, write 45 | ;; it to stdout. If we read 'quit' then echo it to the server which will 46 | ;; echo it back to us and then close its connection to us. 47 | (defun ex4-str-cli (socket) 48 | (loop 49 | (let ((line (read-line))) 50 | ;; send it to the server, get the response. 51 | (format socket "~A~%" line) 52 | (finish-output socket) 53 | (format t "~A~%" (read-line socket))))) 54 | ;; ex-1e 55 | 56 | ;; ex-2b 57 | ;; This is the entry point into this example 58 | (defun run-ex4-client (&key (host *host*) (port *port*)) 59 | (unwind-protect 60 | (handler-case 61 | 62 | (run-ex4-client-helper host port) 63 | 64 | ;; handle a commonly signaled error... 65 | (socket-connection-refused-error () 66 | (format t "Connection refused to ~A:~A. Maybe the server isn't running?~%" 67 | (lookup-hostname host) port))) 68 | 69 | ;; Cleanup form 70 | (format t "Client Exited.~%"))) 71 | ;; ex-2e -------------------------------------------------------------------------------- /src/syscalls/os-conditions-unix.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- *NIX syscall error conditions. 4 | ;;; 5 | 6 | (in-package :iolib/syscalls) 7 | 8 | ;;;------------------------------------------------------------------------- 9 | ;;; POSIX Syscall Errors 10 | ;;;------------------------------------------------------------------------- 11 | 12 | ;;; HASH TABLE mapping error codes to symbols denoting 13 | ;;; subtypes of SYSCALL-ERROR. 14 | (defparameter *syscall-error-map* (make-hash-table :test 'eql)) 15 | 16 | (declaim (inline get-syscall-error-condition)) 17 | (defun get-syscall-error-condition (errno) 18 | (gethash errno *syscall-error-map*)) 19 | 20 | ;;; Define an error condition for each ERRNO value defined in the 21 | ;;; ERRNO-VALUES enum type and populate *SYSCALL-ERROR-MAP*. 22 | (macrolet 23 | ((define-syscall-errors (keywords) 24 | `(progn 25 | ,@(loop :for kw :in keywords :collect 26 | (let ((cond-name (intern (symbol-name kw))) 27 | (code (foreign-enum-value 'errno-values kw))) 28 | `(progn 29 | (define-condition ,cond-name (syscall-error) () 30 | (:default-initargs :code ,code :identifier ,kw)) 31 | (setf (gethash ,code *syscall-error-map*) ',cond-name))))))) 32 | (define-syscall-errors 33 | #.(foreign-enum-keyword-list 'errno-values))) 34 | 35 | ;;; Instantiates a subclass of SYSCALL-ERROR matching ERR 36 | ;;; ERR must be either an integer denoting an ERRNO value. 37 | (defun make-syscall-error (errno syscall fd fd2) 38 | (debug-only* (assert (integerp errno))) 39 | (let ((error-keyword (foreign-enum-keyword 'errno-values errno :errorp nil))) 40 | (unless error-keyword 41 | (bug "A non-existent ~A syscall error has been signaled: ~A, ~A" 42 | 'errno-values (or error-keyword :unknown) errno)) 43 | (make-condition (get-syscall-error-condition errno) 44 | :syscall syscall :handle fd :handle2 fd2))) 45 | 46 | (declaim (inline signal-syscall-error)) 47 | (defun signal-syscall-error (&optional (errno (errno)) syscall fd fd2) 48 | (cond 49 | ((= errno eintr) 50 | (error 'eintr :syscall syscall :handle fd :handle2 fd2)) 51 | (t 52 | (error (make-syscall-error errno syscall fd fd2))))) 53 | 54 | (defun signal-syscall-error-kw (error-keyword &optional syscall fd fd2) 55 | (let ((errno (foreign-enum-value 'errno-values error-keyword :errorp nil))) 56 | (unless error-keyword 57 | (bug "A non-existent ~A syscall error has been signaled: ~A, ~A" 58 | 'errno-values error-keyword errno)) 59 | (signal-syscall-error errno syscall fd fd2))) 60 | -------------------------------------------------------------------------------- /src/base/pkgdcl.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Package definition. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/base 9 | (:nicknames :iolib.base) 10 | (:extend/excluding :iolib/common-lisp 11 | #:defun #:defmethod #:defmacro #:define-compiler-macro 12 | #:constantp) 13 | (:extend :alexandria :split-sequence) 14 | (:export 15 | ;; Conditions 16 | #:bug #:iolib-bug 17 | #:subtype-error #:subtype-error-datum #:subtype-error-expected-supertype 18 | ;; Debugging 19 | #:*safety-checks* 20 | #:debug-only #:debug-only* 21 | #:production-only #:production-only* 22 | ;; Types 23 | #:function-designator 24 | #:character-designator 25 | #:sb8 #:sb16 #:sb32 #:sb64 26 | #:ub8 #:ub16 #:ub32 #:ub64 27 | #:ub8-sarray #:ub16-sarray #:ub32-sarray #:ub64-sarray 28 | #:ub8-vector #:ub16-vector #:ub32-vector #:ub64-vector 29 | ;; RETURN* 30 | #:return* #:lambda* #:defun #:defmethod 31 | #:defmacro #:define-compiler-macro 32 | ;; DEFALIAS 33 | #:constantp 34 | #:defnamespace 35 | #:make-alias 36 | #:defalias 37 | ;; #:function is already in CL 38 | ;; #:compiler-macro is already in CL 39 | #:macro 40 | #:constant 41 | ;; #:special is already in CL 42 | ;; #:class is already in CL 43 | ;; DEFFOLDABLE 44 | #:deffoldable 45 | #:constant-form-value 46 | ;; DEFOBSOLETE 47 | #:defobsolete 48 | #:signal-obsolete 49 | #:deprecation-warning 50 | #:deprecation-warning-function-name 51 | #:deprecation-warning-type 52 | #:deprecation-warning-reason 53 | ;; Reader utils 54 | #:define-syntax 55 | #:define-literal-reader 56 | #:enable-literal-reader #:enable-literal-reader* 57 | #:unknown-literal-syntax #:unknown-literal-syntax-name 58 | #:fcase 59 | ;; Misc 60 | #:function-name #:function-name-p 61 | #:check-bounds #:join #:join* #:shrink-vector #:full-string 62 | ;; Matching 63 | #:multiple-value-case #:flags-case 64 | ;; Time 65 | #:timeout-designator #:positive-timeout-designator 66 | #:decode-timeout #:normalize-timeout #:clamp-timeout 67 | ;; Dynamic-buffer 68 | #:dynamic-buffer 69 | #:sequence-of 70 | #:read-cursor-of 71 | #:write-cursor-of 72 | #:growth-size-of 73 | #:write-ub8 74 | #:write-ub16 75 | #:write-ub32 76 | #:write-vector 77 | #:read-ub8 78 | #:read-ub16 79 | #:read-ub32 80 | #:read-vector 81 | #:read-ub16-from-vector 82 | #:read-ub32-from-vector 83 | #:ub16-to-vector 84 | #:seek-read-cursor 85 | #:dynamic-buffer-input-error 86 | #:dynamic-buffer-eof 87 | #:dynamic-buffer-index-out-of-bounds 88 | )) 89 | -------------------------------------------------------------------------------- /tests/data/hebrew_utf-8_crlf.txt: -------------------------------------------------------------------------------- 1 | :ץראה תאו םימשה תא םיהלא ארב תישארב א 1 2 | םוהת ינפ-לע ךשחו והבו והת התיה ץראהו ב 2 3 | :םימה ינפ-לע תפחרמ םיהלא חורו 4 | :רוא-יהיו רוא יהי םיהלא רמאיו ג 3 5 | םיהלא לדביו בוט-יכ רואה-תא םיהלא אריו ד 4 6 | :ךשחה ןיבו רואה ןיב 7 | הליל ארק ךשחלו םוי רואל םיהלא ארקיו ה 5 8 | :דחא םוי רקב-יהיו ברע-יהיו 9 | יהיו םימה ךותב עיקר יהי םיהלא רמאיו ו 6 10 | :םימל םימ ןיב לידבמ 11 | רשא םימה ןיב לדביו עיקרה-תא םיהלא שעיו ז 7 12 | עיקרל לעמ רשא םימה ןיבו עיקרל תחתמ 13 | :ןכ-יהיו 14 | רקב-יהיו ברע-יהיו םימש עיקרל םיהלא ארקיו ח 8 15 | :ינש םוי 16 | םוקמ-לא םימשה תחתמ םימה ווקי םיהלא רמאיו ט 9 17 | :ןכ-יהיו השביה הארתו דחא 18 | ארק םימה הוקמלו ץרא השביל םיהלא ארקיו י 10 19 | :בוט-יכ םיהלא אריו םימי 20 | ערז עירזמ בשע אשד ץראה אשדת םיהלא רמאיו אי 11 21 | ץראה-לע וב-וערז רשא ונימל ירפ השע ירפ ץע 22 | :ןכ-יהיו 23 | ץעו והנימל ערז עירזמ בשע אשד ץראה אצותו בי 12 24 | םיהלא אריו והנימל וב-וערז רשא ירפ-השע 25 | :בוט-יכ 26 | :ישילש םוי רקב-יהיו ברע-יהיו גי 13 27 | לידבהל םימשה עיקרב תראמ יהי םיהלא רמאיו די 14 28 | םידעומלו תתאל ויהו הלילה ןיבו םויה ןיב 29 | :םינשו םימילו 30 | ץראה-לע ריאהל םימשה עיקרב תרואמל ויהו וט 15 31 | :ןכ-יהיו 32 | רואמה-תא םילדגה תראמה ינש-תא םיהלא שעיו זט 16 33 | תלשממל ןטקה רואמה-תאו םויה תלשממל לדגה 34 | :םיבכוכה תאו הלילה 35 | ריאהל םימשה עיקרב םיהלא םתא ןתיו זי 17 36 | :ץראה-לע 37 | ןיבו רואה ןיב לידבהלו הלילבו םויב לשמלו חי 18 38 | :בוט-יכ םיהלא אריו ךשחה 39 | :יעיבר םוי רקב-יהיו ברע-יהיו טי 19 40 | ףועו היח שפנ ץרש םימה וצרשי םיהלא רמאיו כ 20 41 | :םימשה עיקר ינפ-לע ץראה-לע ףפועי 42 | שפנ-לכ תאו םילדגה םנינתה-תא םיהלא ארביו אכ 21 43 | תאו םהנימל םימה וצרש רשא תשמרה היחה 44 | :בוט-יכ םיהלא אריו והנימל ףנכ ףוע-לכ 45 | ואלמו וברו ורפ רמאל םיהלא םתא ךרביו בכ 22 46 | :ץראב ברי ףועהו םימיב םימה-תא 47 | :ישימח םוי רקב-יהיו ברע-יהיו גכ 23 48 | המהב הנימל היח שפנ ץראה אצות םיהלא רמאיו דכ 24 49 | :ןכ-יהיו הנימל ץרא-ותיחו שמרו 50 | המהבה-תאו הנימל ץראה תיח-תא םיהלא שעיו הכ 25 51 | םיהלא אריו והנימל המדאה שמר-לכ תאו הנימל 52 | :בוט-יכ 53 | ונתומדכ ונמלצב םדא השענ םיהלא רמאיו וכ 26 54 | המהבבו םימשה ףועבו םיה תגדב ודריו 55 | :ץראה-לע שמרה שמרה-לכבו ץראה-לכבו 56 | ארב םיהלא םלצב ומלצב םדאה-תא םיהלא ארביו זכ 27 57 | :םתא ארב הבקנו רכז ותא 58 | וברו ורפ םיהלא םהל רמאיו םיהלא םתא ךרביו חכ 28 59 | ףועבו םיה תגדב ודרו השבכו ץראה-תא ואלמו 60 | :ץראה-לע תשמרה היח-לכבו םימשה 61 | ערז בשע-לכ-תא םכל יתתנ הנה םיהלא רמאיו טכ 29 62 | וב-רשא ץעה-לכ-תאו ץראה-לכ ינפ-לע רשא ערז 63 | :הלכאל היהי םכל ערז ערז ץע-ירפ 64 | שמור לכלו םימשה ףוע-לכלו ץראה תיח-לכלו ל 30 65 | בשע קרי-לכ-תא היח שפנ וב-רשא ץראה-לע 66 | :ןכ-יהיו הלכאל 67 | דאמ בוט-הנהו השע רשא-לכ-תא םיהלא אריו אל 31 68 | :יששה םוי רקב-יהיו בר 69 | -------------------------------------------------------------------------------- /src/base/defobsolete.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Declaring forms as obsolete. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (define-condition deprecation-warning (style-warning) 9 | ((function-name :initarg :function-name :reader deprecation-warning-function-name) 10 | (type :initarg :type :reader deprecation-warning-type) 11 | (reason :initarg :reason :reader deprecation-warning-reason)) 12 | (:report (lambda (condition stream) 13 | (format stream "~A is an obsolete ~A~@[; ~A~]" 14 | (deprecation-warning-function-name condition) 15 | (deprecation-warning-type condition) 16 | (deprecation-warning-reason condition)))) 17 | (:documentation "Warning signaled at compile-time indicating that a certain function has been deprecated.")) 18 | 19 | (defun setf-function-name-p (function-name) 20 | ;; FIXME: This would be better written using pattern matching 21 | (and (consp function-name) 22 | (eql 'setf (first function-name)) 23 | (symbolp (second function-name)) 24 | (null (cddr function-name)))) 25 | 26 | (defun function-name-p (function-name) 27 | "Returns T if FUNCTION-NAME is a legal function name: 28 | a symbol or a list (CL:SETF symbol)." 29 | (or (symbolp function-name) 30 | (setf-function-name-p function-name))) 31 | 32 | (deftype function-name () 33 | "A legal function name: a symbol or a list (CL:SETF symbol)." 34 | `(or symbol (and cons (satisfies setf-function-name-p)))) 35 | 36 | (defun signal-obsolete (function-name reason type action) 37 | (funcall (ecase action 38 | (:warn #'warn) 39 | (:error #'error)) 40 | 'deprecation-warning :function-name function-name 41 | :type type :reason reason)) 42 | 43 | (defmacro defobsolete (function-name reason &key (type "function") (action :warn)) 44 | "Declare the function denoted by FUNCTION-NAME as obsolete. REASON must 45 | either be a string or the name of a function to be used as alternative. 46 | ACTION chooses the function used to signal the deprecation warning: 47 | if :WARN then CL:WARN will be used, if :ERROR then CL:ERROR." 48 | (check-type function-name function-name "a legal function name") 49 | (check-type reason (or function-name string) "a legal function name or a string") 50 | (check-type type (or symbol string)) 51 | (check-type action (member :warn :error)) 52 | (when (function-name-p reason) 53 | (setf reason (format nil "use ~A instead." reason))) 54 | `(define-compiler-macro ,function-name (&whole whole &rest args) 55 | (declare (ignore args)) 56 | (signal-obsolete ',function-name ,reason ',type ,action) 57 | whole)) 58 | -------------------------------------------------------------------------------- /extras/ping.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.sockets) 2 | 3 | (defcstruct ip-header 4 | (ver-ihl :uint8) 5 | (tos :uint8) 6 | (length :uint16) 7 | (id :uint16) 8 | (offset :uint16) 9 | (ttl :uint8) 10 | (protocol :uint8) 11 | (checksum :uint16) 12 | (saddr :uint32) 13 | (daddr :uint32)) 14 | 15 | (defcstruct icmp-header 16 | (type :uint8) 17 | (code :uint8) 18 | (checksum :uint16) 19 | (quench :uint32)) 20 | 21 | (defun write-ip-header (ip-header total-length target-ip) 22 | (with-foreign-slots ((ver-ihl length id offset ttl protocol daddr) 23 | ip-header (:struct ip-header)) 24 | (setf ver-ihl #x45 ; Version 4, header length 5 words(20 bytes) 25 | length total-length 26 | offset #b01000000 ; Don't fragment 27 | ttl 64 28 | protocol ipproto-icmp 29 | daddr (htonl target-ip)))) 30 | 31 | (defun compute-icmp-checksum (icmp-header packet-size) 32 | (let* ((sum1 33 | (loop :for offset :from 0 :below (/ packet-size 2) 34 | :sum (mem-aref icmp-header :uint16 offset))) 35 | (sum2 (+ (ash sum1 -16) 36 | (logand sum1 #xFFFF)))) 37 | (logand #xFFFF (lognot (+ sum2 (ash sum2 -16)))))) 38 | 39 | (defun write-icmp-header (icmp-header packet-size id seqno) 40 | (with-foreign-slots ((type quench checksum) 41 | icmp-header (:struct icmp-header)) 42 | (let ((new-quench 43 | (+ (ash id 16) seqno))) 44 | (setf type icmp-echo-request 45 | quench (htonl new-quench)) 46 | (setf checksum (compute-icmp-checksum icmp-header packet-size))))) 47 | 48 | (defun ping (target &key (id #xFF) (seqno 1)) 49 | (with-open-socket (socket :address-family :ipv4 :type :raw :protocol ipproto-icmp 50 | :include-headers t) 51 | (let* ((payload-size 4) 52 | (icmp-packet-size (+ (isys:sizeof '(:struct icmp-header)) payload-size)) 53 | (frame-size (+ (isys:sizeof '(:struct ip-header)) icmp-packet-size))) 54 | (with-foreign-object (frame :uint8 frame-size) 55 | (isys:bzero frame frame-size) 56 | (let* ((ip-header frame) 57 | (icmp-header (cffi:inc-pointer ip-header (isys:sizeof '(:struct ip-header)))) 58 | (payload (cffi:inc-pointer icmp-header (isys:sizeof '(:struct icmp-header))))) 59 | (write-ip-header ip-header frame-size (dotted-to-integer target)) 60 | (setf (mem-ref payload :uint32) (htonl #x1A2B3C4D)) 61 | (write-icmp-header icmp-header icmp-packet-size id seqno) 62 | (send-to socket frame :end frame-size :remote-host target) 63 | (iolib/multiplex:wait-until-fd-ready (socket-os-fd socket) :input) 64 | (receive-from socket :size (* 64 1024))))))) 65 | -------------------------------------------------------------------------------- /src/sockets/iface.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Network interface lookup. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defun make-interface (name index) 9 | "Constructor for INTERFACE objects." 10 | (cons name index)) 11 | 12 | (define-condition unknown-interface (isys:enxio) 13 | ((datum :initarg :datum :initform nil :reader unknown-interface-datum)) 14 | (:report (lambda (condition stream) 15 | (format stream "Unknown interface: ~A" 16 | (unknown-interface-datum condition)))) 17 | (:documentation "Condition raised when a network interface is not found.")) 18 | (setf (documentation 'unknown-interface-datum 'function) 19 | "Return the datum that caused the signalling of an UNKNOWN-INTERFACE condition.") 20 | 21 | (defun signal-unknown-interface-error (syscall datum) 22 | (error 'unknown-interface :syscall syscall :datum datum)) 23 | 24 | (defun list-network-interfaces () 25 | "Returns a list of network interfaces currently available." 26 | (let ((ifptr (null-pointer))) 27 | (unwind-protect 28 | (progn 29 | (setf ifptr (%if-nameindex)) 30 | (loop :for p := ifptr :then (inc-pointer p (isys:sizeof '(:struct if-nameindex))) 31 | :for name := (foreign-slot-value p '(:struct if-nameindex) 'name) 32 | :for index := (foreign-slot-value p '(:struct if-nameindex) 'index) 33 | :while (plusp index) :collect (make-interface name index))) 34 | (unless (null-pointer-p ifptr) (%if-freenameindex ifptr))))) 35 | 36 | (defun get-interface-by-index (index) 37 | (with-foreign-object (buffer :uint8 ifnamesize) 38 | (handler-case 39 | (%if-indextoname index buffer) 40 | (isys:enxio () 41 | (signal-unknown-interface-error "if_indextoname" index)) 42 | (:no-error (name) 43 | (make-interface name index))))) 44 | 45 | (defun get-interface-by-name (name) 46 | (handler-case 47 | (%if-nametoindex name) 48 | (isys:enxio () 49 | (signal-unknown-interface-error "if_nametoindex" name)) 50 | (:no-error (index) 51 | (make-interface (copy-seq name) index)))) 52 | 53 | (defun interface-name (interface) 54 | "Return the name of an network interface." 55 | (car interface)) 56 | 57 | (defun interface-index (interface) 58 | "Return the OS index of a network interface." 59 | (cdr interface)) 60 | 61 | (defun lookup-interface (interface) 62 | "Lookup an interface by name or index. UNKNOWN-INTERFACE is 63 | signalled if an interface is not found." 64 | (check-type interface (or unsigned-byte string symbol) "non-negative integer, a string or a symbol") 65 | (let ((parsed (ensure-string-or-unsigned-byte interface :errorp t))) 66 | (typecase parsed 67 | (unsigned-byte (get-interface-by-index parsed)) 68 | (string (get-interface-by-name parsed))))) 69 | -------------------------------------------------------------------------------- /src/multiplex/timers.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Creating and manipulating timer structures. 4 | ;;; 5 | ;;; Copyright (C) 2003 Zach Beane 6 | ;;; 7 | ;;; Permission is hereby granted, free of charge, to any person obtaining 8 | ;;; a copy of this software and associated documentation files (the 9 | ;;; "Software"), to deal in the Software without restriction, including 10 | ;;; without limitation the rights to use, copy, modify, merge,publish, 11 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 12 | ;;; permit persons to whom the Software is furnished to do so, subject to 13 | ;;; the following conditions: 14 | ;;; 15 | ;;; The above copyright notice and this permission notice shall be 16 | ;;; included in all copies or substantial portions of the Software. 17 | ;;; 18 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 22 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 23 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 24 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :iolib/multiplex) 27 | 28 | ;;; 29 | ;;; Timer 30 | ;;; 31 | 32 | (defstruct (timer 33 | (:conc-name %timer-) 34 | (:constructor %make-timer (name function expire-time 35 | relative-time one-shot))) 36 | name 37 | ;; to call when the timer expires 38 | function 39 | ;; absolute expiry time 40 | expire-time 41 | ;; relative expiry time 42 | relative-time 43 | ;; when NIL, the timer is automatically rescheduled 44 | ;; when triggered 45 | one-shot) 46 | 47 | (defmethod print-object ((object timer) stream) 48 | (print-unreadable-object (object stream) 49 | (format stream "TIMER ~S, Timeout: [ ~A , ~A ], ~:[persistent~;one-shot~]" 50 | (%timer-name object) 51 | (%timer-relative-time object) 52 | (%timer-expire-time object) 53 | (%timer-one-shot object)))) 54 | 55 | (defun make-timer (function delay &key name one-shot) 56 | (flet ((abs-timeout (timeout) 57 | (+ (isys:get-monotonic-time) 58 | (normalize-timeout timeout)))) 59 | (let ((name (or name "(unnamed)"))) 60 | (%make-timer name function (abs-timeout delay) delay one-shot)))) 61 | 62 | (defun timer-name (timer) 63 | (%timer-name timer)) 64 | 65 | (defun timer-expired-p (timer now &optional (delta 0.0d0)) 66 | (assert (%timer-expire-time timer) ((%timer-expire-time timer)) 67 | "Timer ~A must have an expiry time set." timer) 68 | (let ((compare-time (+ now delta))) 69 | (> compare-time (%timer-expire-time timer)))) 70 | 71 | (defun reset-timer (timer) 72 | (setf (%timer-expire-time timer) 0)) 73 | -------------------------------------------------------------------------------- /src/multiplex/multiplexer.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Base class for multiplexers. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | (defvar *available-multiplexers* nil 9 | "An alist of (PRIORITY . MULTIPLEXER). Smaller values mean higher priority.") 10 | 11 | (defvar *default-multiplexer* nil 12 | "The default multiplexer for the current OS.") 13 | 14 | (defun get-fd-limit () 15 | "Return the maximum number of FDs available for the current process." 16 | (let ((fd-limit (isys:getrlimit isys:rlimit-nofile))) 17 | (if (= fd-limit isys:rlim-infinity) 18 | 65536 ; 64K should be enough for anybody 19 | fd-limit))) 20 | 21 | (defclass multiplexer () 22 | ((fd :reader fd-of) 23 | (fd-limit :initform (get-fd-limit) 24 | :initarg :fd-limit 25 | :reader fd-limit-of) 26 | (closedp :accessor multiplexer-closedp 27 | :initform nil)) 28 | (:documentation "Base class for I/O multiplexers.")) 29 | 30 | (defgeneric close-multiplexer (mux) 31 | (:method-combination progn :most-specific-last) 32 | (:documentation "Close multiplexer MUX, calling close() on the multiplexer's FD if bound.")) 33 | 34 | (defgeneric monitor-fd (mux fd-entry) 35 | (:documentation "Add the descriptor represented by FD-ENTRY to multiplexer MUX. 36 | Must return NIL on failure, T otherwise.")) 37 | 38 | (defgeneric update-fd (mux fd-entry event-type edge-change) 39 | (:documentation "Update the status of the descriptor represented by FD-ENTRY in multiplexer MUX. 40 | Must return NIL on failure, T otherwise.")) 41 | 42 | (defgeneric unmonitor-fd (mux fd-entry) 43 | (:documentation "Remove the descriptor represented by FD-ENTRY from multiplexer MUX. 44 | Must return NIL on failure, T otherwise.")) 45 | 46 | (defgeneric harvest-events (mux timeout) 47 | (:documentation "Wait for events on multiplexer MUX for a maximum time of TIMEOUT seconds. 48 | Returns a list of fd/result pairs which have one of these forms: 49 | (fd (:read)) 50 | (fd (:write)) 51 | (fd (:read :write)) 52 | (fd . :error)")) 53 | 54 | (defmethod close-multiplexer :around ((mux multiplexer)) 55 | (unless (multiplexer-closedp mux) 56 | (call-next-method) 57 | (setf (multiplexer-closedp mux) t))) 58 | 59 | (defmethod close-multiplexer progn ((mux multiplexer)) 60 | (when (and (slot-boundp mux 'fd) (not (null (fd-of mux)))) 61 | (isys:close (fd-of mux)) 62 | (setf (slot-value mux 'fd) nil)) 63 | (values mux)) 64 | 65 | (defmethod monitor-fd :before ((mux multiplexer) fd-entry) 66 | (with-accessors ((fd-limit fd-limit-of)) 67 | mux 68 | (let ((fd (fd-entry-fd fd-entry))) 69 | (when (and fd-limit (> fd fd-limit)) 70 | (error "Cannot add such a large FD: ~A" fd))))) 71 | 72 | (defmacro define-multiplexer (name priority superclasses slots &rest options) 73 | `(progn 74 | (defclass ,name ,superclasses ,slots ,@options) 75 | (pushnew (cons ,priority ',name) *available-multiplexers* 76 | :test #'equal))) 77 | -------------------------------------------------------------------------------- /src/streams/gray/classes.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- fd-streams classes. 4 | ;;; 5 | 6 | (in-package :iolib/streams) 7 | 8 | ;;;; Stream Buffers 9 | 10 | (deftype stream-buffer () 'foreign-pointer) 11 | (deftype buffer-index () '(unsigned-byte 24)) 12 | 13 | (defstruct (iobuf (:constructor %make-iobuf ())) 14 | (data (null-pointer) :type stream-buffer) 15 | (size 0 :type buffer-index) 16 | (start 0 :type buffer-index) 17 | (end 0 :type buffer-index)) 18 | 19 | ;;;; File-Descriptor Mixins 20 | 21 | (deftype stream-position () '(unsigned-byte 64)) 22 | 23 | (defun default-read-fn (fd buf nbytes) 24 | (isys:read fd buf nbytes)) 25 | 26 | (defun default-write-fn (fd buf nbytes) 27 | (isys:write fd buf nbytes)) 28 | 29 | (defclass dual-channel-fd-mixin () 30 | ((fd :initform nil :initarg :fd :accessor fd-of 31 | :documentation "placeholder") 32 | (read-fn :initform #'default-read-fn :initarg :read-fn :accessor read-fn-of) 33 | (write-fn :initform #'default-write-fn :initarg :write-fn :accessor write-fn-of)) 34 | (:documentation "placeholder")) 35 | 36 | (defgeneric fd-non-blocking (fd-mixin)) 37 | (defgeneric (setf fd-non-blocking) (mode fd-mixin)) 38 | 39 | ;;;; Bivalent Socket Gray Stream 40 | 41 | (defclass dual-channel-gray-stream (trivial-gray-stream-mixin 42 | dual-channel-fd-mixin 43 | fundamental-binary-input-stream 44 | fundamental-binary-output-stream 45 | fundamental-character-input-stream 46 | fundamental-character-output-stream) 47 | ((external-format :initform :default :initarg :external-format 48 | :reader external-format-of 49 | :documentation "placehold") 50 | (eol-writer :reader eol-writer-of) 51 | (eol-finder :reader eol-finder-of) 52 | (eol-finder/no-hang :reader eol-finder/no-hang-of) 53 | (input-buffer :initform nil :type (or iobuf null) 54 | :accessor input-buffer-of) 55 | (output-buffer :initform nil :type (or iobuf null) 56 | :accessor output-buffer-of) 57 | ;; Flag used by stream-force-output. 58 | (dirty :initform nil :type boolean :accessor dirtyp) 59 | ;; Last read char buffer index. 60 | (unread-index :initform 0 :type buffer-index 61 | :accessor unread-index-of)) 62 | (:documentation "placeholder")) 63 | 64 | (defgeneric (setf external-format-of) (external-format stream) 65 | (:documentation "placeholder")) 66 | 67 | (defgeneric drain-input-buffer (stream sequence &key start end) 68 | (:documentation "")) 69 | 70 | (defgeneric input-buffer-size (stream) 71 | (:documentation "")) 72 | 73 | (defgeneric input-buffer-empty-p (stream) 74 | (:documentation "")) 75 | 76 | (defgeneric output-buffer-size (stream) 77 | (:documentation "")) 78 | 79 | (defgeneric output-buffer-empty-p (stream) 80 | (:documentation "")) 81 | -------------------------------------------------------------------------------- /src/base/defalias.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Creating aliases in CL namespaces 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (defvar *namespaces* nil) 9 | 10 | (defmacro defalias (alias original) 11 | (destructuring-bind (namespace new-name) 12 | alias 13 | (assert (member namespace *namespaces*) (namespace) 14 | "Namespace ~A does not exist" namespace) 15 | `(progn 16 | ,@(make-alias namespace original new-name) 17 | ',new-name))) 18 | 19 | (defmacro defnamespace (namespace &optional docstring) 20 | (check-type namespace symbol) 21 | (check-type docstring (or null string)) 22 | `(progn 23 | (pushnew ',namespace *namespaces*) 24 | ,@(when docstring 25 | `((handler-bind ((warning #'muffle-warning)) 26 | (setf (documentation ',namespace 'namespace) ,docstring)))) 27 | ',namespace)) 28 | 29 | (defgeneric make-alias (namespace original alias)) 30 | 31 | (defnamespace function 32 | "The namespace of ordinary and generic functions.") 33 | 34 | (defmethod make-alias ((namespace (eql 'function)) 35 | original alias) 36 | `((setf (fdefinition ',alias) 37 | (fdefinition ',original)) 38 | (setf (documentation ',alias 'function) 39 | (documentation ',original 'function)) 40 | (defalias (compiler-macro ,alias) ,original))) 41 | 42 | (defnamespace macro 43 | "The namespace of macros.") 44 | 45 | (defmethod make-alias ((namespace (eql 'macro)) 46 | original alias) 47 | `((setf (macro-function ',alias) 48 | (macro-function ',original)) 49 | (setf (documentation ',alias 'function) 50 | (documentation ',original 'function)))) 51 | 52 | (defnamespace compiler-macro 53 | "The namespace of compiler macros.") 54 | 55 | (defmethod make-alias ((namespace (eql 'compiler-macro)) 56 | original alias) 57 | `((setf (compiler-macro-function ',alias) 58 | (compiler-macro-function ',original)) 59 | (setf (documentation ',alias 'compiler-macro) 60 | (documentation ',original 'compiler-macro)))) 61 | 62 | (defnamespace special 63 | "The namespace of special variables.") 64 | 65 | (defmethod make-alias ((namespace (eql 'special)) 66 | original alias) 67 | `((define-symbol-macro ,alias ,original) 68 | (setf (documentation ',alias 'variable) 69 | (documentation ',original 'variable)))) 70 | 71 | (defnamespace constant 72 | "The namespace of constant variables.") 73 | 74 | (defmethod make-alias ((namespace (eql 'constant)) 75 | original alias) 76 | `((define-symbol-macro ,alias ,original) 77 | (setf (documentation ',alias 'variable) 78 | (documentation ',original 'variable)))) 79 | 80 | (defnamespace class 81 | "The namespace of classes.") 82 | 83 | (defmethod make-alias ((namespace (eql 'class)) 84 | original alias) 85 | `((setf (find-class ,alias) 86 | (find-class ,original)) 87 | (setf (documentation ',alias 'type) 88 | (documentation ',original 'type)))) 89 | -------------------------------------------------------------------------------- /src/base/return-star.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- RETURN* wrappers. 4 | ;;; 5 | 6 | (in-package :iolib/base) 7 | 8 | (cl:defmacro defun (name args &body body) 9 | `(,(find-right-symbol :defun :series) 10 | ,name ,args ,@(wrap-body-for-return-star body name))) 11 | 12 | (cl:defmacro defmethod (name args &body body) 13 | (cond 14 | ;; no method qualifier, this is actually the lambda-list 15 | ((listp args) 16 | `(,(find-right-symbol :defmethod) 17 | ,name ,args ,@(wrap-body-for-return-star body name))) 18 | ;; args is the method qualifier 19 | (t 20 | `(,(find-right-symbol :defmethod) ,name 21 | ,args ,(car body) ,@(wrap-body-for-return-star (cdr body) name))))) 22 | 23 | (cl:defmacro lambda* (args &body body) 24 | `(,(find-right-symbol :lambda) 25 | ,args ,@(wrap-body-for-return-star body))) 26 | 27 | (cl:defmacro defmacro (name args &body body) 28 | `(,(find-right-symbol :defmacro) 29 | ,name ,args ,@(wrap-body-for-return-star body name))) 30 | 31 | (cl:defmacro define-compiler-macro (name args &body body) 32 | `(,(find-right-symbol :define-compiler-macro) 33 | ,name ,args ,@(wrap-body-for-return-star body name))) 34 | 35 | (cl:defun find-right-symbol (name &rest packages) 36 | (multiple-value-bind (symbol foundp) 37 | (if (eql (find-symbol (string name) *package*) 38 | (find-symbol (string name) :iolib/base)) 39 | ;; NAME has been imported from IOLIB.UTILS, so we must 40 | ;; find a default somewhere else, defaulting to the CL package 41 | (find-symbol (string name) (find-right-package packages)) 42 | ;; use the symbol named NAME from the *PACKAGE* or CL 43 | (find-symbol (string name) (find-right-package (package-name *package*)))) 44 | (assert foundp (symbol) "Couldn't find any symbol as default for ~S" name) 45 | (values symbol))) 46 | 47 | (cl:defun find-right-package (packages) 48 | (dolist (pkg (ensure-list packages) :common-lisp) 49 | (when (member pkg (package-use-list *package*) 50 | :key #'package-name 51 | :test #'string-equal) 52 | (return pkg)))) 53 | 54 | (cl:defun wrap-body-for-return-star (body &optional block-name) 55 | (flet ((block-name (block) 56 | (etypecase block 57 | (cons (destructuring-bind (kind block-name) block 58 | (assert (eql 'setf kind)) 59 | (check-type block-name symbol) 60 | block-name)) 61 | (symbol block)))) 62 | (multiple-value-bind (body declarations docstring) 63 | (parse-body body :documentation t) 64 | (with-gensyms (value) 65 | (remove-if 66 | #'null 67 | `(,docstring 68 | ,@declarations 69 | ,(if block-name 70 | `(macrolet ((return* (,value) `(return-from ,',(block-name block-name) ,,value))) 71 | ,@body) 72 | (with-gensyms (block) 73 | `(block ,block 74 | (macrolet ((return* (value) `(return-from ,',block ,value))) 75 | ,@body)))))))))) 76 | -------------------------------------------------------------------------------- /examples/ex1-server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This example implements an IPV4 TCP blocking i/o iterative date 7 | ;;;; server which handles one connection and then exits. 8 | 9 | ;;;; This example is written in a non-conventional style resembling 10 | ;;;; that of C. Later programs will deviate from this style and move 11 | ;;;; more towards the Common Lisp style. 12 | 13 | ;;;; This server as it stands has more than a few problems especially 14 | ;;;; due to not cleaning up the server socket if the code exits 15 | ;;;; poorly, suppose returning to the toplevel when you break into the 16 | ;;;; debugger while the server is running. 17 | 18 | ;; ex-0b 19 | (defun run-ex1-server (&key (port *port*)) 20 | ;; Create a passive (server) TCP socket under IPV4 Sockets meant to 21 | ;; be listened upon *must* be created passively. This is a minor 22 | ;; deviation from the Berkeley socket interface. 23 | (let ((socket 24 | (make-socket 25 | :connect :passive 26 | :address-family :internet 27 | :type :stream 28 | :external-format '(:utf-8 :eol-style :crlf) 29 | :ipv6 nil))) 30 | (format t "Created socket: ~A[fd=~A]~%" socket (socket-os-fd socket)) 31 | ;; ex-0e 32 | 33 | ;; ex-1b 34 | ;; Bind the socket to all interfaces with specified port. 35 | (bind-address socket 36 | +ipv4-unspecified+ ; which means INADDR_ANY or 0.0.0.0 37 | :port port 38 | :reuse-addr t) 39 | (format t "Bound socket: ~A~%" socket) 40 | ;; ex-1e 41 | 42 | ;; ex-2b 43 | ;; Convert the sockxet to a listening socket 44 | (listen-on socket :backlog 5) 45 | (format t "Listening on socket bound to: ~A:~A~%" 46 | (local-host socket) (local-port socket)) 47 | ;; ex-2e 48 | 49 | ;; ex-3b 50 | ;; Block on accepting a connection 51 | (format t "Waiting to accept a connection...~%") 52 | (let ((client (accept-connection socket :wait t))) 53 | (when client 54 | ;; When we get a new connection, show who it is from. 55 | (multiple-value-bind (who rport) 56 | (remote-name client) 57 | (format t "Got a connection from ~A:~A!~%" who rport)) 58 | ;; ex-3e 59 | 60 | ;; ex-4b 61 | ;; Since we're using a internet TCP stream, we can use format 62 | ;; with it. However, we should be sure to call finish-output on 63 | ;; the socket in order that all the data is sent. Also, this is 64 | ;; a blocking write. 65 | (multiple-value-bind (s m h d mon y) 66 | (get-decoded-time) 67 | (format t "Sending the time...") 68 | (format client "~A/~A/~A ~A:~A:~A~%" mon d y h m s) 69 | (finish-output client)) 70 | ;; ex-4e 71 | 72 | ;; ex-5b 73 | ;; We're done talking to the client. 74 | (close client) 75 | (format t "Sent!~%")) 76 | ;; ex-5e 77 | 78 | ;; ex-6b 79 | ;; We're done with the server socket too. 80 | (close socket) 81 | (finish-output) 82 | t))) 83 | ;; ex-6e 84 | 85 | -------------------------------------------------------------------------------- /src/multiplex/scheduler.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Controlling the queue of scheduled events and running expired timers. 4 | ;;; 5 | ;;; Copyright (C) 2003 Zach Beane 6 | ;;; 7 | ;;; Permission is hereby granted, free of charge, to any person obtaining 8 | ;;; a copy of this software and associated documentation files (the 9 | ;;; "Software"), to deal in the Software without restriction, including 10 | ;;; without limitation the rights to use, copy, modify, merge,publish, 11 | ;;; distribute, sublicense, and/or sell copies of the Software, and to 12 | ;;; permit persons to whom the Software is furnished to do so, subject to 13 | ;;; the following conditions: 14 | ;;; 15 | ;;; The above copyright notice and this permission notice shall be 16 | ;;; included in all copies or substantial portions of the Software. 17 | ;;; 18 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 19 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 20 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 21 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 22 | ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 23 | ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 24 | ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 25 | 26 | (in-package :iolib/multiplex) 27 | 28 | ;;; 29 | ;;; Public interface 30 | ;;; 31 | 32 | (defun schedule-timer (schedule timer) 33 | (priority-queue-insert schedule timer) 34 | (values timer)) 35 | 36 | (defun unschedule-timer (schedule timer) 37 | (priority-queue-remove schedule timer) 38 | (values timer)) 39 | 40 | (defun reschedule-timer (schedule timer) 41 | (incf (%timer-expire-time timer) (%timer-relative-time timer)) 42 | (priority-queue-insert schedule timer)) 43 | 44 | (defun reschedule-timer-relative-to-now (timer now) 45 | (setf (%timer-expire-time timer) 46 | (+ now (%timer-relative-time timer)))) 47 | 48 | ;;; 49 | ;;; The scheduler 50 | ;;; 51 | 52 | (defun peek-schedule (schedule) 53 | (priority-queue-maximum schedule)) 54 | 55 | (defun time-to-next-timer (schedule) 56 | (when-let ((timer (peek-schedule schedule))) 57 | (%timer-expire-time timer))) 58 | 59 | ;;; 60 | ;;; Expiring timers 61 | ;;; 62 | 63 | (defun dispatch-timer (timer) 64 | (funcall (%timer-function timer))) 65 | 66 | (defun timer-reschedulable-p (timer) 67 | (symbol-macrolet ((relative-time (%timer-relative-time timer)) 68 | (one-shot (%timer-one-shot timer))) 69 | (and relative-time (not one-shot)))) 70 | 71 | (defun expire-pending-timers (schedule now) 72 | (let ((expired-p nil) 73 | (timers-to-reschedule ())) 74 | (flet ((handle-expired-timer (timer) 75 | (when (timer-reschedulable-p timer) 76 | (push timer timers-to-reschedule)) 77 | (dispatch-timer timer)) 78 | (%return () 79 | (dolist (timer timers-to-reschedule) 80 | (reschedule-timer schedule timer)) 81 | (return* expired-p))) 82 | (loop 83 | (let ((next-timer (peek-schedule schedule))) 84 | (unless next-timer (%return)) 85 | (cond ((timer-expired-p next-timer now) 86 | (setf expired-p t) 87 | (handle-expired-timer (priority-queue-extract-maximum schedule))) 88 | (t 89 | (%return)))))))) 90 | -------------------------------------------------------------------------------- /tests/data/tilton_ascii_cr.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of contradictory new information -- well, that's almost everyone in my experience, so I better not say what I think of them or people will start saying bad things about me on c.l.l. -- Ken Tilton % This reminds me of the NYC cabby who accepted a fare to Chicago. When they got there and could not find the friend who was supposed to pay the fare he just laughed and said he should have known. -- Ken Tilton % >> Actually, I believe that Aikido, Jazz and Lisp are different appearances >> of the same thing. Yes, the Tao. /Everything/ is a different appearance of the tao. -- Ken Tilton "Ken, I went to the library and read up on Buddhism, and believe me, you are no Buddhist." -- Kenny's mom % That absolutely terrifies the herd-following, lockstep-marching, mainstream-saluting cowards that obediently dash out or online to scoop up books on The Latest Thing. They learn and use atrocities like Java, C++, XML, and even Python for the security it gives them and then sit there slaving away miserably, tediously, joylously paying off mortgages and supporting ungrateful teenagers who despise them, only to look out the double-sealed thermo-pane windows of their central-heated, sound-proofed, dead-bolted, suffocating little nests into the howling gale thinking "what do they know that I do not know?" when they see us under a lean-to hunched over our laptops to shield them from the rain laughing our asses off as we write great code between bong hits.... what was the question? -- Ken Tilton % Shut up! (That last phrase has four or more syllables if pronounced as intended.) -- Ken Tilton % Nonsense. You'll be using it for the GUI, not protein-folding. -- Ken Tilton (responding to a comment that LTK was slow because it was based on TK) % Continuations certainly are clever, but if we learned anything from the rejection of the cover art for "Smell the Glove", it is that "there is a fine line between stupid... and clever". -- Ken Tilton % Ah, there's no place like academia for dispassionate, intellectually honest discussion of new ideas on their merits. Thank god for tenure giving your bold antagonist the protection they needed to shout down your iconoclastic..... hang on... -- Ken Tilton % Whoever objected must be in my killfile, ... -- Ken Tilton % From memory (but I think I have it right): "But Jesus said, Suffer captured variables, and forbid them not, to come unto thine macro bodies: for of such is are DSLs made." -- Ken Tilton Can I get an Amen? % Awareness of defect is the first step to recovery. -- Ken Tilton % You made a bad analogy (there are no good ones, but you found a new low) ... -- Ken Tilton % Yes, it is true that Kent Pitman was raised by a closet full of Lisp Machines, but the exception only proves the rule. -- Ken Tilton (in a postscript after positing that computer languages are not learned in infancy) % I suggest you try bartender's school to support yourself, start programming for fun again. -- Ken Tilton (responding to a comment that 98% of anything to do with computers was not interesting code) % You could add four lanes to my carpal tunnel and I still could not write all the code I am dying to write. -- Ken Tilton % Neutrality? I want to bury other languages, not have a gateway to them. -- Ken Tilton % Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" Simon: "Hunh? My puppy /always/ gives me companionship." -- Ken Tilton (on how he was understood by a native english speaker) % -------------------------------------------------------------------------------- /tests/data/tilton_utf-8_cr.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of contradictory new information -- well, that's almost everyone in my experience, so I better not say what I think of them or people will start saying bad things about me on c.l.l. -- Ken Tilton % This reminds me of the NYC cabby who accepted a fare to Chicago. When they got there and could not find the friend who was supposed to pay the fare he just laughed and said he should have known. -- Ken Tilton % >> Actually, I believe that Aikido, Jazz and Lisp are different appearances >> of the same thing. Yes, the Tao. /Everything/ is a different appearance of the tao. -- Ken Tilton "Ken, I went to the library and read up on Buddhism, and believe me, you are no Buddhist." -- Kenny's mom % That absolutely terrifies the herd-following, lockstep-marching, mainstream-saluting cowards that obediently dash out or online to scoop up books on The Latest Thing. They learn and use atrocities like Java, C++, XML, and even Python for the security it gives them and then sit there slaving away miserably, tediously, joylously paying off mortgages and supporting ungrateful teenagers who despise them, only to look out the double-sealed thermo-pane windows of their central-heated, sound-proofed, dead-bolted, suffocating little nests into the howling gale thinking "what do they know that I do not know?" when they see us under a lean-to hunched over our laptops to shield them from the rain laughing our asses off as we write great code between bong hits.... what was the question? -- Ken Tilton % Shut up! (That last phrase has four or more syllables if pronounced as intended.) -- Ken Tilton % Nonsense. You'll be using it for the GUI, not protein-folding. -- Ken Tilton (responding to a comment that LTK was slow because it was based on TK) % Continuations certainly are clever, but if we learned anything from the rejection of the cover art for "Smell the Glove", it is that "there is a fine line between stupid... and clever". -- Ken Tilton % Ah, there's no place like academia for dispassionate, intellectually honest discussion of new ideas on their merits. Thank god for tenure giving your bold antagonist the protection they needed to shout down your iconoclastic..... hang on... -- Ken Tilton % Whoever objected must be in my killfile, ... -- Ken Tilton % From memory (but I think I have it right): "But Jesus said, Suffer captured variables, and forbid them not, to come unto thine macro bodies: for of such is are DSLs made." -- Ken Tilton Can I get an Amen? % Awareness of defect is the first step to recovery. -- Ken Tilton % You made a bad analogy (there are no good ones, but you found a new low) ... -- Ken Tilton % Yes, it is true that Kent Pitman was raised by a closet full of Lisp Machines, but the exception only proves the rule. -- Ken Tilton (in a postscript after positing that computer languages are not learned in infancy) % I suggest you try bartender's school to support yourself, start programming for fun again. -- Ken Tilton (responding to a comment that 98% of anything to do with computers was not interesting code) % You could add four lanes to my carpal tunnel and I still could not write all the code I am dying to write. -- Ken Tilton % Neutrality? I want to bury other languages, not have a gateway to them. -- Ken Tilton % Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" Simon: "Hunh? My puppy /always/ gives me companionship." -- Ken Tilton (on how he was understood by a native english speaker) % -------------------------------------------------------------------------------- /tests/multiplex.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- iolib/multiplex test suite. 4 | ;;; 5 | 6 | (in-package :iolib/tests) 7 | 8 | (in-suite :iolib/multiplex) 9 | 10 | (defmacro with-event-base/for-each-mux ((base &rest initargs) &body body) 11 | `(let ((failed-list)) 12 | (dolist (mux (mapcar #'cdr *available-multiplexers*) failed-list) 13 | (handler-case 14 | (with-event-base (,base :mux mux ,@initargs) 15 | ,@body) 16 | (error (err) 17 | (push (cons mux err) failed-list)))))) 18 | 19 | (test (timeout.1 :compile-at :definition-time) 20 | (is-false 21 | (with-event-base/for-each-mux (base) 22 | (event-dispatch base :timeout 0)))) 23 | 24 | (test (timeout.2 :compile-at :definition-time) 25 | (is-false 26 | (with-event-base/for-each-mux (base) 27 | (let ((cb nil)) 28 | (add-timer base (lambda () (setq cb :timeout)) 30) 29 | (event-dispatch base :timeout 0) 30 | (assert (null cb)))))) 31 | 32 | (test (timeout.3 :compile-at :definition-time) 33 | (is-false 34 | (with-event-base/for-each-mux (base) 35 | (let ((cb nil)) 36 | (add-timer base (lambda () (setq cb :timeout)) 0) 37 | (event-dispatch base :one-shot t) 38 | (assert (eq cb :timeout)))))) 39 | 40 | ;;; regression test: timeouts' absolute times used used to be 41 | ;;; incremented with the relative time ad infinitum. 42 | (test (timeout.4 :compile-at :definition-time) 43 | (is-false 44 | (with-event-base/for-each-mux (base) 45 | (let ((cb nil)) 46 | (add-timer base (lambda () (setq cb :timeout)) 1.5) 47 | (event-dispatch base :timeout 2) 48 | (assert (eq cb :timeout)))))) 49 | 50 | (defun timeout-cb (fd event) 51 | (declare (ignore fd event)) 52 | (error "timeout")) 53 | 54 | (defmacro waiting-for-event ((base fd event-type) &body body) 55 | (with-gensyms (fd-arg event-arg error-arg) 56 | (once-only (base) 57 | `(progn 58 | (set-io-handler ,base ,fd ,event-type 59 | (lambda (,fd-arg ,event-arg ,error-arg) 60 | (declare (ignore ,error-arg)) 61 | (when (eq ,event-arg :error) 62 | (error "error with ~A" ,fd-arg)) 63 | ,@body) 64 | :one-shot t) 65 | (event-dispatch ,base :one-shot t))))) 66 | 67 | ;;; FIXME: doesn't work with SELECT. 68 | ;;; where ? it works here, on Linux. SIONESCU 2007.12.02 69 | (test (event-base-with-open-sockets :compile-at :definition-time) 70 | (is-true 71 | (block test 72 | (with-event-base (base) 73 | (with-open-socket (passive :address-family :ipv4 :connect :passive 74 | :local-host +ipv4-unspecified+) 75 | (with-open-socket (active :address-family :ipv4 76 | :remote-port (local-port passive) 77 | :remote-host +ipv4-unspecified+) 78 | (add-timer base #'timeout-cb 5) 79 | (let (peer) 80 | (waiting-for-event (base (fd-of passive) :read) 81 | (setq peer (accept-connection passive))) 82 | (assert (socket-open-p peer)) 83 | (send-to active #(1 2 3 4)) 84 | (waiting-for-event (base (fd-of peer) :read) 85 | (multiple-value-bind (v n) 86 | (receive-from peer :size 5) 87 | (assert (= n 4)) 88 | (assert (equalp v #(1 2 3 4 0)))) 89 | (return-from test t))))) 90 | nil)))) 91 | -------------------------------------------------------------------------------- /examples/ex3-server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :iolib.examples) 2 | 3 | ;;;; This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | ;;;; and this code is released under the same license as IOLib. 5 | 6 | ;;;; This is a more common-lisp-like style of ex2-server, and to be 7 | ;;;; used for the rest of the examples as appropriate. We introduce 8 | ;;;; with-open-socket, which does a lot of cleanup on the created 9 | ;;;; socket and ensures it is closed. This is usually the recommended 10 | ;;;; idiom for simple clients. 11 | 12 | ;;;; Also in this example we start to handle some of the more common 13 | ;;;; conditions which can be signaled by IOLib. 14 | 15 | ;; ex-0b 16 | (defun run-ex3-server-helper (port) 17 | (with-open-socket 18 | (server :connect :passive 19 | :address-family :internet 20 | :type :stream 21 | :ipv6 nil 22 | :external-format '(:utf-8 :eol-style :crlf)) 23 | 24 | (format t "Created socket: ~A[fd=~A]~%" server (socket-os-fd server)) 25 | 26 | ;; Bind the socket to all interfaces with specified port. 27 | (bind-address server +ipv4-unspecified+ :port port :reuse-addr t) 28 | (format t "Bound socket: ~A~%" server) 29 | 30 | ;; start listening on the server socket 31 | (listen-on server :backlog 5) 32 | (format t "Listening on socket bound to: ~A:~A~%" 33 | (local-host server) 34 | (local-port server)) 35 | ;; ex-0e 36 | 37 | ;; ex-1b 38 | ;; keep accepting connections forever. 39 | (loop 40 | (format t "Waiting to accept a connection...~%") 41 | 42 | ;; Here we see with-accept-connection which simplifies closing 43 | ;; the client socket when are done with it. 44 | (with-accept-connection (client server :wait t) 45 | ;; When we get a new connection, show who it 46 | ;; is from. 47 | (multiple-value-bind (who rport) 48 | (remote-name client) 49 | (format t "Got a connnection from ~A:~A!~%" who rport)) 50 | 51 | ;; Since we're using an internet TCP stream, we can use format 52 | ;; with it. However, we should be sure to finish-output in 53 | ;; order that all the data is sent. 54 | (multiple-value-bind (s m h d mon y) 55 | (get-decoded-time) 56 | (format t "Sending the time...") 57 | 58 | ;; Catch the condition of the client closing the connection. 59 | ;; Since we exist inside a with-accept-connection, the 60 | ;; socket will be automatically closed. 61 | (handler-case 62 | (progn 63 | (format client "~A/~A/~A ~A:~A:~A~%" mon d y h m s) 64 | (finish-output client)) 65 | 66 | (socket-connection-reset-error () 67 | (format t "Client reset connection!~%")) 68 | 69 | (hangup () 70 | (format t "Client closed conection!~%"))) 71 | 72 | (format t "Sent!~%")))) 73 | ;; ex-1e 74 | 75 | ;; ex-2b 76 | t)) 77 | ;; ex-2e 78 | 79 | ;; ex-3b 80 | ;; This is the main entry point into the example 3 server. 81 | (defun run-ex3-server (&key (port *port*)) 82 | (handler-case 83 | 84 | (run-ex3-server-helper port) 85 | 86 | (socket-address-in-use-error () 87 | ;; Here we catch a condition which represents trying to bind to 88 | ;; the same port before the first one has been released by the 89 | ;; kernel. Generally this means you forgot to put ':reuse-addr 90 | ;; t' as an argument to bind address. 91 | (format t "Bind: Address already in use, forget :reuse-addr t?"))) 92 | 93 | (finish-output)) 94 | ;; ex-3e -------------------------------------------------------------------------------- /examples/gen-tutorial: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env perl 2 | 3 | # This file was originally written by Peter Keller (psilord@cs.wisc.edu) 4 | # and this code is released under the same license as IOLib. 5 | 6 | # The purpose of this program is to parse out the ex-NNNb / ex-NNNe sections 7 | # from all of the ex*.lisp files, and then shove them into the template 8 | # tutorial file at lines. This greatly simplifies 9 | # changing the codes and keeping it current to the tutorial. 10 | 11 | # This script is a simple hack and can be fooled by incorrect sentinel markers 12 | # in the codebase or by out of bounds example numbers in the tutorial.tmpl 13 | # file. My advice is: don't do that. 14 | 15 | use strict; 16 | use warnings; 17 | 18 | sub main 19 | { 20 | my $exref; 21 | 22 | $exref = load_examples(); 23 | gen_tutorial($exref); 24 | 25 | return 0; 26 | } 27 | 28 | sub load_examples 29 | { 30 | my @files = `ls ex*.lisp`; 31 | my $file; 32 | my ($line, $location, $example, $edge); 33 | my $recording; 34 | my %ex; 35 | 36 | map {chomp $_;} @files; 37 | 38 | foreach $file (@files) { 39 | # print "Processing file: $file\n"; 40 | 41 | # open each file in turn, each file's prefix is the key to a hash of 42 | # examples found in the file, and each example is keyed by ex-NNN as 43 | # dictated in the file. 44 | 45 | open(FIN, "<$file") or die "Can't open file $file: $!"; 46 | ($location) = ($file =~ m/^(.*)\.lisp$/); 47 | 48 | # read the examples out of the source itself. 49 | $recording = 0; 50 | while(defined($line = )) { 51 | chomp $line; 52 | if ($line =~ /;\s*ex-/) { 53 | # we either start recording an example, or are just finishing 54 | # one. 55 | ($example, $edge) = ($line =~ /(ex-\d+)(.)/); 56 | if ($edge =~ /b/) { 57 | $recording = 1; 58 | die "Premature EOF!" if (!defined($line = )); 59 | chomp $line; 60 | } else { 61 | $recording = 0; 62 | } 63 | } 64 | 65 | if ($recording == 1) { 66 | push @{$ex{$location}{$example}}, $line; 67 | # print "Recorded: $location:$example <- $line\n"; 68 | } 69 | } 70 | 71 | close(FIN); 72 | } 73 | 74 | return \%ex; 75 | } 76 | 77 | sub gen_tutorial 78 | { 79 | my ($exref) = @_; 80 | my $tmpl = "tutorial.tmpl"; 81 | my $out = "tutorial"; 82 | my $line; 83 | my ($location, $example); 84 | my $exline; 85 | 86 | open(FIN, "<$tmpl") or die "Can't open tutorial template $tmpl: $!"; 87 | open(FOUT, ">$out") or die "Can't open generated tutorial $out: $!"; 88 | 89 | # read each line of the template, and if I see the magical 90 | # format, then shove in the example code lines 91 | # from the hash table. 92 | while(defined($line = )) { 93 | if ($line =~ m//) { 94 | $line =~ s/^\s+//; 95 | $line =~ s/\s+$//; 96 | # if I asked for an example, then shove the block into the tutorial 97 | # right here. 98 | ($location, $example) = ($line =~ m//); 99 | if (!exists($exref->{$location}{$example})) { 100 | close(FOUT); 101 | unlink $out; 102 | die "Tried to include nonexistant example: $location:$example"; 103 | } 104 | print FOUT "+" . "-" x 78 . "+\n"; 105 | print FOUT "|" . " " x 78 . "|\n"; 106 | foreach $exline (@{$exref->{$location}{$example}}) { 107 | print FOUT "$exline\n"; 108 | } 109 | print FOUT "|" . " " x 78 . "|\n"; 110 | print FOUT "+" . "-" x 78 . "+\n"; 111 | } else { 112 | # otherwise just copy the line over. 113 | print FOUT $line; 114 | } 115 | } 116 | 117 | close(FOUT); 118 | close(FIN); 119 | } 120 | 121 | exit main(); 122 | 123 | 124 | -------------------------------------------------------------------------------- /tests/data/tilton_ascii_lf.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of 2 | contradictory new information -- well, that's almost everyone in my 3 | experience, so I better not say what I think of them or people will start 4 | saying bad things about me on c.l.l. 5 | -- Ken Tilton 6 | % 7 | This reminds me of the NYC cabby who accepted a fare to Chicago. When 8 | they got there and could not find the friend who was supposed to pay the 9 | fare he just laughed and said he should have known. 10 | -- Ken Tilton 11 | % 12 | >> Actually, I believe that Aikido, Jazz and Lisp are different appearances 13 | >> of the same thing. 14 | Yes, the Tao. /Everything/ is a different appearance of the tao. 15 | -- Ken Tilton 16 | 17 | "Ken, I went to the library and read up on Buddhism, and believe me, you 18 | are no Buddhist." 19 | -- Kenny's mom 20 | % 21 | That absolutely terrifies the herd-following, lockstep-marching, 22 | mainstream-saluting cowards that obediently dash out or online to 23 | scoop up books on The Latest Thing. They learn and use atrocities like 24 | Java, C++, XML, and even Python for the security it gives them and 25 | then sit there slaving away miserably, tediously, joylously paying off 26 | mortgages and supporting ungrateful teenagers who despise them, only 27 | to look out the double-sealed thermo-pane windows of their 28 | central-heated, sound-proofed, dead-bolted, suffocating little nests 29 | into the howling gale thinking "what do they know that I do not know?" 30 | when they see us under a lean-to hunched over our laptops to shield 31 | them from the rain laughing our asses off as we write great code 32 | between bong hits.... what was the question? 33 | -- Ken Tilton 34 | % 35 | Shut up! (That last phrase has four or more syllables if pronounced as 36 | intended.) 37 | -- Ken Tilton 38 | % 39 | Nonsense. You'll be using it for the GUI, not protein-folding. 40 | -- Ken Tilton 41 | (responding to a comment that LTK was slow because it 42 | was based on TK) 43 | % 44 | Continuations certainly are clever, but if we learned anything from the 45 | rejection of the cover art for "Smell the Glove", it is that "there is a 46 | fine line between stupid... and clever". 47 | -- Ken Tilton 48 | % 49 | Ah, there's no place like academia for dispassionate, intellectually 50 | honest discussion of new ideas on their merits. Thank god for tenure 51 | giving your bold antagonist the protection they needed to shout down 52 | your iconoclastic..... hang on... 53 | -- Ken Tilton 54 | % 55 | Whoever objected must be in my killfile, ... 56 | -- Ken Tilton 57 | % 58 | From memory (but I think I have it right): 59 | 60 | "But Jesus said, Suffer captured variables, and forbid them not, to come 61 | unto thine macro bodies: for of such is are DSLs made." 62 | -- Ken Tilton 63 | 64 | Can I get an Amen? 65 | % 66 | Awareness of defect is the first step to recovery. 67 | -- Ken Tilton 68 | % 69 | You made a bad analogy (there are no good ones, but you found a new 70 | low) ... 71 | -- Ken Tilton 72 | % 73 | Yes, it is true that Kent Pitman was raised by a closet full of Lisp 74 | Machines, but the exception only proves the rule. 75 | -- Ken Tilton 76 | (in a postscript after positing that computer 77 | languages are not learned in infancy) 78 | % 79 | I suggest you try bartender's school to support yourself, start 80 | programming for fun again. 81 | -- Ken Tilton 82 | (responding to a comment that 98% of anything to do 83 | with computers was not interesting code) 84 | % 85 | You could add four lanes to my carpal tunnel and I still could not 86 | write all the code I am dying to write. 87 | -- Ken Tilton 88 | % 89 | Neutrality? I want to bury other languages, not have a gateway to them. 90 | -- Ken Tilton 91 | % 92 | Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" 93 | Simon: "Hunh? My puppy /always/ gives me companionship." 94 | -- Ken Tilton 95 | (on how he was understood by a native english speaker) 96 | % 97 | -------------------------------------------------------------------------------- /tests/data/tilton_utf-8_lf.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of 2 | contradictory new information -- well, that's almost everyone in my 3 | experience, so I better not say what I think of them or people will start 4 | saying bad things about me on c.l.l. 5 | -- Ken Tilton 6 | % 7 | This reminds me of the NYC cabby who accepted a fare to Chicago. When 8 | they got there and could not find the friend who was supposed to pay the 9 | fare he just laughed and said he should have known. 10 | -- Ken Tilton 11 | % 12 | >> Actually, I believe that Aikido, Jazz and Lisp are different appearances 13 | >> of the same thing. 14 | Yes, the Tao. /Everything/ is a different appearance of the tao. 15 | -- Ken Tilton 16 | 17 | "Ken, I went to the library and read up on Buddhism, and believe me, you 18 | are no Buddhist." 19 | -- Kenny's mom 20 | % 21 | That absolutely terrifies the herd-following, lockstep-marching, 22 | mainstream-saluting cowards that obediently dash out or online to 23 | scoop up books on The Latest Thing. They learn and use atrocities like 24 | Java, C++, XML, and even Python for the security it gives them and 25 | then sit there slaving away miserably, tediously, joylously paying off 26 | mortgages and supporting ungrateful teenagers who despise them, only 27 | to look out the double-sealed thermo-pane windows of their 28 | central-heated, sound-proofed, dead-bolted, suffocating little nests 29 | into the howling gale thinking "what do they know that I do not know?" 30 | when they see us under a lean-to hunched over our laptops to shield 31 | them from the rain laughing our asses off as we write great code 32 | between bong hits.... what was the question? 33 | -- Ken Tilton 34 | % 35 | Shut up! (That last phrase has four or more syllables if pronounced as 36 | intended.) 37 | -- Ken Tilton 38 | % 39 | Nonsense. You'll be using it for the GUI, not protein-folding. 40 | -- Ken Tilton 41 | (responding to a comment that LTK was slow because it 42 | was based on TK) 43 | % 44 | Continuations certainly are clever, but if we learned anything from the 45 | rejection of the cover art for "Smell the Glove", it is that "there is a 46 | fine line between stupid... and clever". 47 | -- Ken Tilton 48 | % 49 | Ah, there's no place like academia for dispassionate, intellectually 50 | honest discussion of new ideas on their merits. Thank god for tenure 51 | giving your bold antagonist the protection they needed to shout down 52 | your iconoclastic..... hang on... 53 | -- Ken Tilton 54 | % 55 | Whoever objected must be in my killfile, ... 56 | -- Ken Tilton 57 | % 58 | From memory (but I think I have it right): 59 | 60 | "But Jesus said, Suffer captured variables, and forbid them not, to come 61 | unto thine macro bodies: for of such is are DSLs made." 62 | -- Ken Tilton 63 | 64 | Can I get an Amen? 65 | % 66 | Awareness of defect is the first step to recovery. 67 | -- Ken Tilton 68 | % 69 | You made a bad analogy (there are no good ones, but you found a new 70 | low) ... 71 | -- Ken Tilton 72 | % 73 | Yes, it is true that Kent Pitman was raised by a closet full of Lisp 74 | Machines, but the exception only proves the rule. 75 | -- Ken Tilton 76 | (in a postscript after positing that computer 77 | languages are not learned in infancy) 78 | % 79 | I suggest you try bartender's school to support yourself, start 80 | programming for fun again. 81 | -- Ken Tilton 82 | (responding to a comment that 98% of anything to do 83 | with computers was not interesting code) 84 | % 85 | You could add four lanes to my carpal tunnel and I still could not 86 | write all the code I am dying to write. 87 | -- Ken Tilton 88 | % 89 | Neutrality? I want to bury other languages, not have a gateway to them. 90 | -- Ken Tilton 91 | % 92 | Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" 93 | Simon: "Hunh? My puppy /always/ gives me companionship." 94 | -- Ken Tilton 95 | (on how he was understood by a native english speaker) 96 | % 97 | -------------------------------------------------------------------------------- /src/sockets/trivial-sockets.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Main socket methods. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp-user) 7 | 8 | (defpackage :iolib/trivial-sockets 9 | (:nicknames :iolib.trivial-sockets) 10 | (:use :iolib/base :iolib/sockets) 11 | (:shadow #:socket-error #:accept-connection) 12 | (:export #:open-stream #:socket-error #:socket-nested-error 13 | #:unsupported #:unsupported-feature 14 | #:open-server #:close-server #:accept-connection 15 | #:with-server)) 16 | 17 | (in-package :iolib/trivial-sockets) 18 | 19 | ;;;; 20 | ;;;; ERRORS 21 | ;;;; 22 | 23 | ;; you're using a part of the interface that the implementation doesn't do 24 | (define-condition unsupported (error) 25 | ((feature :initarg :feature :reader unsupported-feature)) 26 | (:report (lambda (c s) 27 | (format s "~S does not support trivial-socket feature ~S." 28 | (lisp-implementation-type) (unsupported-feature c))))) 29 | 30 | ;; all-purpose error: host not found, host not responding, 31 | ;; no service on that port, etc 32 | (define-condition socket-error (error) 33 | ((nested-error :initarg :nested-error :reader socket-nested-error))) 34 | 35 | ;;;; 36 | ;;;; Main implementation 37 | ;;;; 38 | 39 | (defun resolve-hostname (name) 40 | (let ((*ipv6* nil)) 41 | (cond 42 | ((eql :any name) +ipv4-unspecified+) 43 | (t (nth-value 0 (ensure-hostname name)))))) 44 | 45 | (defun open-stream (peer-host peer-port &key 46 | (local-host :any) (local-port 0) 47 | (external-format :default) 48 | (element-type 'character) 49 | (protocol :tcp)) 50 | (declare (ignore element-type)) 51 | (unless (eql :tcp protocol) 52 | (error 'unsupported :feature `(:protocol ,protocol))) 53 | (let ((*ipv6* nil)) 54 | (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) 55 | (make-socket :address-family :internet 56 | :connect :active 57 | :type :stream 58 | :remote-host (resolve-hostname peer-host) 59 | :remote-port peer-port 60 | :local-host (resolve-hostname local-host) 61 | :local-port local-port 62 | :external-format external-format)))) 63 | 64 | (defun open-server (&key (host :any) (port 0) 65 | (reuse-address t) 66 | (backlog 1) 67 | (protocol :tcp)) 68 | "Returns a SERVER object and the port that was bound, as multiple values." 69 | (unless (eql :tcp protocol) 70 | (error 'unsupported :feature `(:protocol ,protocol))) 71 | (let ((*ipv6* nil)) 72 | (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) 73 | (let* ((host (if (eql :any host) +ipv4-unspecified+ host)) 74 | (socket (make-socket :address-family :internet 75 | :type :stream 76 | :connect :passive 77 | :local-host host 78 | :local-port port 79 | :reuse-address reuse-address 80 | :backlog backlog))) 81 | (values socket (local-port socket)))))) 82 | 83 | (defun close-server (server) 84 | (close server)) 85 | 86 | (defun accept-connection (socket &key 87 | (external-format :default) 88 | (element-type 'character)) 89 | (declare (ignore element-type)) ; bivalent streams 90 | (let ((*ipv6* nil)) 91 | (handler-bind ((error (lambda (c) (error 'socket-error :nested-error c)))) 92 | (iolib.sockets:accept-connection socket :external-format external-format)))) 93 | 94 | ;;;; 95 | ;;;; Utilities 96 | ;;;; 97 | 98 | (defmacro with-server ((name arguments) &body forms) 99 | `(with-open-stream (,name (open-server ,@arguments)) 100 | (locally ,@forms))) 101 | -------------------------------------------------------------------------------- /src/os/ffi-functions-unix.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- lfp_spawn(3) and its minions 4 | ;;; 5 | 6 | (in-package :iolib/os) 7 | 8 | (defsyscall (lfp-spawn "lfp_spawn") 9 | (:int :restart t) 10 | (pid :pointer) 11 | (path :string) 12 | (arguments :pointer) 13 | (environment :pointer) 14 | (file-actions :pointer) 15 | (attributes :pointer)) 16 | 17 | (defsyscall (lfp-spawnp "lfp_spawnp") 18 | (:int :restart t) 19 | (pid :pointer) 20 | (file :string) 21 | (arguments :pointer) 22 | (environment :pointer) 23 | (file-actions :pointer) 24 | (attributes :pointer)) 25 | 26 | (defsyscall (lfp-spawnattr-init 27 | "lfp_spawnattr_init") 28 | :int 29 | (attributes :pointer)) 30 | 31 | (defsyscall (lfp-spawnattr-destroy 32 | "lfp_spawnattr_destroy") 33 | :int 34 | (attributes :pointer)) 35 | 36 | (defsyscall (lfp-spawnattr-setflags 37 | "lfp_spawnattr_setflags") 38 | :int 39 | (attributes :pointer) 40 | (flags :uint32)) 41 | 42 | (defsyscall (lfp-spawnattr-setsigmask 43 | "lfp_spawnattr_setsigmask") 44 | :int 45 | (attributes :pointer) 46 | (sigmask :pointer)) 47 | 48 | (defsyscall (lfp-spawnattr-setsigdefault 49 | "lfp_spawnattr_setsigdefault") 50 | :int 51 | (attributes :pointer) 52 | (sigdefault :pointer)) 53 | 54 | (defsyscall (lfp-spawnattr-setpgroup 55 | "lfp_spawnattr_setpgroup") 56 | :int 57 | (attributes :pointer) 58 | (pgroup pid-t)) 59 | 60 | (defsyscall (lfp-spawnattr-setsid 61 | "lfp_spawnattr_setsid") 62 | :int 63 | (attributes :pointer)) 64 | 65 | (defsyscall (lfp-spawnattr-setctty 66 | "lfp_spawnattr_setctty") 67 | :int 68 | (attributes :pointer) 69 | (pts sstring)) 70 | 71 | (defsyscall (lfp-spawnattr-setcwd 72 | "lfp_spawnattr_setcwd") 73 | :int 74 | (attributes :pointer) 75 | (path sstring)) 76 | 77 | (defsyscall (lfp-spawnattr-setuid 78 | "lfp_spawnattr_setuid") 79 | :int 80 | (attributes :pointer) 81 | (uid uid-t)) 82 | 83 | (defsyscall (lfp-spawnattr-setgid 84 | "lfp_spawnattr_setgid") 85 | :int 86 | (attributes :pointer) 87 | (gid gid-t)) 88 | 89 | ;; (defsyscall (lfp-spawnattr-getschedpolicy 90 | ;; "lfp_spawnattr_getschedpolicy") 91 | ;; :int 92 | ;; (attributes :pointer) 93 | ;; (schedpolicy :pointer)) 94 | 95 | ;; (defsyscall (lfp-spawnattr-setschedpolicy 96 | ;; "lfp_spawnattr_setschedpolicy") 97 | ;; :int 98 | ;; (attributes :pointer) 99 | ;; (schedpolicy :pointer)) 100 | 101 | ;; (defsyscall (lfp-spawnattr-getschedparam 102 | ;; "lfp_spawnattr_getschedparam") 103 | ;; :int 104 | ;; (attributes :pointer) 105 | ;; (schedparam :pointer)) 106 | 107 | ;; (defsyscall (lfp-spawnattr-setschedparam 108 | ;; "lfp_spawnattr_setschedparam") 109 | ;; :int 110 | ;; (attributes :pointer) 111 | ;; (schedparam :pointer)) 112 | 113 | (defsyscall (lfp-spawn-file-actions-init 114 | "lfp_spawn_file_actions_init") 115 | :int 116 | (file-actions :pointer)) 117 | 118 | (defsyscall (lfp-spawn-file-actions-destroy 119 | "lfp_spawn_file_actions_destroy") 120 | :int 121 | (file-actions :pointer)) 122 | 123 | (defsyscall (lfp-spawn-file-actions-addopen 124 | "lfp_spawn_file_actions_addopen") 125 | :int 126 | (file-actions :pointer) 127 | (fd :int) 128 | (path :string) 129 | (flags :int) 130 | (mode mode-t)) 131 | 132 | (defsyscall (lfp-spawn-file-actions-addclose 133 | "lfp_spawn_file_actions_addclose") 134 | :int 135 | (file-actions :pointer) 136 | (fd :int)) 137 | 138 | (defsyscall (lfp-spawn-file-actions-adddup2 139 | "lfp_spawn_file_actions_adddup2") 140 | :int 141 | (file-actions :pointer) 142 | (fd :int) 143 | (newfd :int)) 144 | -------------------------------------------------------------------------------- /tests/data/tilton_ascii_crlf.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of 2 | contradictory new information -- well, that's almost everyone in my 3 | experience, so I better not say what I think of them or people will start 4 | saying bad things about me on c.l.l. 5 | -- Ken Tilton 6 | % 7 | This reminds me of the NYC cabby who accepted a fare to Chicago. When 8 | they got there and could not find the friend who was supposed to pay the 9 | fare he just laughed and said he should have known. 10 | -- Ken Tilton 11 | % 12 | >> Actually, I believe that Aikido, Jazz and Lisp are different appearances 13 | >> of the same thing. 14 | Yes, the Tao. /Everything/ is a different appearance of the tao. 15 | -- Ken Tilton 16 | 17 | "Ken, I went to the library and read up on Buddhism, and believe me, you 18 | are no Buddhist." 19 | -- Kenny's mom 20 | % 21 | That absolutely terrifies the herd-following, lockstep-marching, 22 | mainstream-saluting cowards that obediently dash out or online to 23 | scoop up books on The Latest Thing. They learn and use atrocities like 24 | Java, C++, XML, and even Python for the security it gives them and 25 | then sit there slaving away miserably, tediously, joylously paying off 26 | mortgages and supporting ungrateful teenagers who despise them, only 27 | to look out the double-sealed thermo-pane windows of their 28 | central-heated, sound-proofed, dead-bolted, suffocating little nests 29 | into the howling gale thinking "what do they know that I do not know?" 30 | when they see us under a lean-to hunched over our laptops to shield 31 | them from the rain laughing our asses off as we write great code 32 | between bong hits.... what was the question? 33 | -- Ken Tilton 34 | % 35 | Shut up! (That last phrase has four or more syllables if pronounced as 36 | intended.) 37 | -- Ken Tilton 38 | % 39 | Nonsense. You'll be using it for the GUI, not protein-folding. 40 | -- Ken Tilton 41 | (responding to a comment that LTK was slow because it 42 | was based on TK) 43 | % 44 | Continuations certainly are clever, but if we learned anything from the 45 | rejection of the cover art for "Smell the Glove", it is that "there is a 46 | fine line between stupid... and clever". 47 | -- Ken Tilton 48 | % 49 | Ah, there's no place like academia for dispassionate, intellectually 50 | honest discussion of new ideas on their merits. Thank god for tenure 51 | giving your bold antagonist the protection they needed to shout down 52 | your iconoclastic..... hang on... 53 | -- Ken Tilton 54 | % 55 | Whoever objected must be in my killfile, ... 56 | -- Ken Tilton 57 | % 58 | From memory (but I think I have it right): 59 | 60 | "But Jesus said, Suffer captured variables, and forbid them not, to come 61 | unto thine macro bodies: for of such is are DSLs made." 62 | -- Ken Tilton 63 | 64 | Can I get an Amen? 65 | % 66 | Awareness of defect is the first step to recovery. 67 | -- Ken Tilton 68 | % 69 | You made a bad analogy (there are no good ones, but you found a new 70 | low) ... 71 | -- Ken Tilton 72 | % 73 | Yes, it is true that Kent Pitman was raised by a closet full of Lisp 74 | Machines, but the exception only proves the rule. 75 | -- Ken Tilton 76 | (in a postscript after positing that computer 77 | languages are not learned in infancy) 78 | % 79 | I suggest you try bartender's school to support yourself, start 80 | programming for fun again. 81 | -- Ken Tilton 82 | (responding to a comment that 98% of anything to do 83 | with computers was not interesting code) 84 | % 85 | You could add four lanes to my carpal tunnel and I still could not 86 | write all the code I am dying to write. 87 | -- Ken Tilton 88 | % 89 | Neutrality? I want to bury other languages, not have a gateway to them. 90 | -- Ken Tilton 91 | % 92 | Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" 93 | Simon: "Hunh? My puppy /always/ gives me companionship." 94 | -- Ken Tilton 95 | (on how he was understood by a native english speaker) 96 | % 97 | -------------------------------------------------------------------------------- /tests/data/tilton_utf-8_crlf.txt: -------------------------------------------------------------------------------- 1 | Programmers who lock onto a design decision and cling to it in the face of 2 | contradictory new information -- well, that's almost everyone in my 3 | experience, so I better not say what I think of them or people will start 4 | saying bad things about me on c.l.l. 5 | -- Ken Tilton 6 | % 7 | This reminds me of the NYC cabby who accepted a fare to Chicago. When 8 | they got there and could not find the friend who was supposed to pay the 9 | fare he just laughed and said he should have known. 10 | -- Ken Tilton 11 | % 12 | >> Actually, I believe that Aikido, Jazz and Lisp are different appearances 13 | >> of the same thing. 14 | Yes, the Tao. /Everything/ is a different appearance of the tao. 15 | -- Ken Tilton 16 | 17 | "Ken, I went to the library and read up on Buddhism, and believe me, you 18 | are no Buddhist." 19 | -- Kenny's mom 20 | % 21 | That absolutely terrifies the herd-following, lockstep-marching, 22 | mainstream-saluting cowards that obediently dash out or online to 23 | scoop up books on The Latest Thing. They learn and use atrocities like 24 | Java, C++, XML, and even Python for the security it gives them and 25 | then sit there slaving away miserably, tediously, joylously paying off 26 | mortgages and supporting ungrateful teenagers who despise them, only 27 | to look out the double-sealed thermo-pane windows of their 28 | central-heated, sound-proofed, dead-bolted, suffocating little nests 29 | into the howling gale thinking "what do they know that I do not know?" 30 | when they see us under a lean-to hunched over our laptops to shield 31 | them from the rain laughing our asses off as we write great code 32 | between bong hits.... what was the question? 33 | -- Ken Tilton 34 | % 35 | Shut up! (That last phrase has four or more syllables if pronounced as 36 | intended.) 37 | -- Ken Tilton 38 | % 39 | Nonsense. You'll be using it for the GUI, not protein-folding. 40 | -- Ken Tilton 41 | (responding to a comment that LTK was slow because it 42 | was based on TK) 43 | % 44 | Continuations certainly are clever, but if we learned anything from the 45 | rejection of the cover art for "Smell the Glove", it is that "there is a 46 | fine line between stupid... and clever". 47 | -- Ken Tilton 48 | % 49 | Ah, there's no place like academia for dispassionate, intellectually 50 | honest discussion of new ideas on their merits. Thank god for tenure 51 | giving your bold antagonist the protection they needed to shout down 52 | your iconoclastic..... hang on... 53 | -- Ken Tilton 54 | % 55 | Whoever objected must be in my killfile, ... 56 | -- Ken Tilton 57 | % 58 | From memory (but I think I have it right): 59 | 60 | "But Jesus said, Suffer captured variables, and forbid them not, to come 61 | unto thine macro bodies: for of such is are DSLs made." 62 | -- Ken Tilton 63 | 64 | Can I get an Amen? 65 | % 66 | Awareness of defect is the first step to recovery. 67 | -- Ken Tilton 68 | % 69 | You made a bad analogy (there are no good ones, but you found a new 70 | low) ... 71 | -- Ken Tilton 72 | % 73 | Yes, it is true that Kent Pitman was raised by a closet full of Lisp 74 | Machines, but the exception only proves the rule. 75 | -- Ken Tilton 76 | (in a postscript after positing that computer 77 | languages are not learned in infancy) 78 | % 79 | I suggest you try bartender's school to support yourself, start 80 | programming for fun again. 81 | -- Ken Tilton 82 | (responding to a comment that 98% of anything to do 83 | with computers was not interesting code) 84 | % 85 | You could add four lanes to my carpal tunnel and I still could not 86 | write all the code I am dying to write. 87 | -- Ken Tilton 88 | % 89 | Neutrality? I want to bury other languages, not have a gateway to them. 90 | -- Ken Tilton 91 | % 92 | Ken: "Cute puppy. Did you get it for companionship or to pick up chicks?" 93 | Simon: "Hunh? My puppy /always/ gives me companionship." 94 | -- Ken Tilton 95 | (on how he was understood by a native english speaker) 96 | % 97 | -------------------------------------------------------------------------------- /src/multiplex/fd-wait.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Wait for events on single FDs. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | (define-condition poll-error (error) 9 | ((fd :initarg :fd :reader poll-error-fd) 10 | (identifier :initarg :identifier :initform "Unknown error" 11 | :reader poll-error-identifier)) 12 | (:report (lambda (condition stream) 13 | (format stream "Error caught while polling file descriptor ~A: ~A" 14 | (poll-error-fd condition) 15 | (poll-error-identifier condition)))) 16 | (:documentation 17 | "Signaled when an error occurs while polling for I/O readiness 18 | of a file descriptor.")) 19 | 20 | (define-condition poll-timeout (condition) 21 | ((fd :initarg :fd :reader poll-timeout-fd) 22 | (event-type :initarg :event-type :reader poll-timeout-event-type)) 23 | (:report (lambda (condition stream) 24 | (format stream "Timeout occurred while polling file descriptor ~A for event ~S" 25 | (poll-timeout-fd condition) 26 | (poll-timeout-event-type condition)))) 27 | (:documentation 28 | "Signaled when a timeout occurs while polling for I/O readiness 29 | of a file descriptor.")) 30 | 31 | (defun compute-poll-flags (type) 32 | (ecase type 33 | (:input (logior isys:pollin isys:pollrdhup isys:pollpri)) 34 | (:output (logior isys:pollout)) 35 | (:io (logior isys:pollin isys:pollrdhup isys:pollpri isys:pollout)))) 36 | 37 | (defun process-poll-revents (revents fd) 38 | (let ((readp nil) (writep nil)) 39 | (flags-case revents 40 | ((isys:pollin isys:pollrdhup isys:pollpri) 41 | (setf readp t)) 42 | ((isys:pollout isys:pollhup) 43 | (setf writep t)) 44 | ((isys:pollerr) 45 | (error 'poll-error :fd fd)) 46 | ((isys:pollnval) 47 | (error 'poll-error :fd fd :identifier "Invalid file descriptor"))) 48 | (values readp writep))) 49 | 50 | (defun wait-until-fd-ready (file-descriptor event-type &optional timeout errorp) 51 | "Poll file descriptor `FILE-DESCRIPTOR' for I/O readiness. 52 | `EVENT-TYPE' must be either :INPUT, :OUTPUT or :IO. 53 | `TIMEOUT' must be either a non-negative real measured in seconds, 54 | or `NIL' meaning no timeout at all. If `ERRORP' is not NIL and a timeout 55 | occurs, then a condition of type `POLL-TIMEOUT' is signaled. 56 | Returns two boolean values indicating readability and writeability of `FILE-DESCRIPTOR'." 57 | (flet ((poll-error (unix-err) 58 | (error 'poll-error :fd file-descriptor 59 | :identifier (isys:identifier-of unix-err)))) 60 | (with-foreign-object (pollfd '(:struct isys:pollfd)) 61 | (isys:bzero pollfd (isys:sizeof '(:struct isys:pollfd))) 62 | (with-foreign-slots ((isys:fd isys:events isys:revents) 63 | pollfd (:struct isys:pollfd)) 64 | (setf isys:fd file-descriptor 65 | isys:events (compute-poll-flags event-type)) 66 | (handler-case 67 | (let ((ret (isys:repeat-upon-condition-decreasing-timeout 68 | ((isys:eintr) remaining-time timeout) 69 | (isys:poll pollfd 1 (timeout->milliseconds remaining-time))))) 70 | (when (zerop ret) 71 | (if errorp 72 | (error 'poll-timeout :fd file-descriptor :event-type event-type) 73 | (return* (values nil nil))))) 74 | (isys:syscall-error (err) (poll-error err))) 75 | (process-poll-revents isys:revents file-descriptor))))) 76 | 77 | (defun fd-ready-p (fd &optional (event-type :input)) 78 | "Tests file-descriptor `FD' for I/O readiness. 79 | `EVENT-TYPE' must be either :INPUT, :OUTPUT or :IO ." 80 | (multiple-value-bind (readp writep) 81 | (wait-until-fd-ready fd event-type 0) 82 | (ecase event-type 83 | (:input readp) 84 | (:output writep) 85 | (:io (or readp writep))))) 86 | 87 | (defun fd-readablep (fd) 88 | (nth-value 0 (wait-until-fd-ready fd :input 0))) 89 | 90 | (defun fd-writablep (fd) 91 | (nth-value 1 (wait-until-fd-ready fd :output 0))) 92 | -------------------------------------------------------------------------------- /src/sockets/bsd.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Bindings for BSD sockets. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defmacro define-socket-creation-call (name return-type &body args) 9 | `(defsyscall ,name 10 | (,return-type 11 | :error-generator signal-socket-error) 12 | ,@args)) 13 | 14 | (defmacro define-socket-call (name return-type &body args) 15 | (let ((forms (alexandria:parse-body args))) 16 | `(defsyscall ,name 17 | (,return-type 18 | :handle ,(caar forms) ; the socket FD 19 | :error-generator signal-socket-error) 20 | ,@forms))) 21 | 22 | 23 | ;;;; sys/socket.h 24 | 25 | (define-socket-call (%accept "accept") :int 26 | (socket :int) 27 | (address :pointer) ; sockaddr-foo 28 | (addrlen :pointer)) 29 | 30 | (define-socket-call (%bind "bind") :int 31 | (socket :int) 32 | (address :pointer) 33 | (addrlen socklen-t)) 34 | 35 | (define-socket-call (%connect "connect") :int 36 | (socket :int) 37 | (address :pointer) ; sockaddr-foo 38 | (addrlen socklen-t)) 39 | 40 | (define-socket-call (%getpeername "getpeername") :int 41 | (socket :int) 42 | (address :pointer) 43 | (addrlen :pointer)) 44 | 45 | (define-socket-call (%getsockname "getsockname") :int 46 | (socket :int) 47 | (address :pointer) 48 | (addrlen :pointer)) 49 | 50 | (define-socket-call (%getsockopt "getsockopt") :int 51 | (socket :int) 52 | (level :int) 53 | (optname :int) 54 | (optval :pointer) 55 | (optlen :pointer)) 56 | 57 | (define-socket-call (%listen "listen") :int 58 | (socket :int) 59 | (backlog :int)) 60 | 61 | (define-socket-call (%recvfrom "recvfrom") ssize-t 62 | (socket :int) 63 | (buffer :pointer) 64 | (length size-t) 65 | (flags :int) 66 | (address :pointer) 67 | (addrlen :pointer)) 68 | 69 | (define-socket-call (%sendto "sendto") ssize-t 70 | (socket :int) 71 | (buffer :pointer) 72 | (length size-t) 73 | (flags :int) 74 | (destaddr :pointer) 75 | (destlen socklen-t)) 76 | 77 | (define-socket-call (%recvmsg "recvmsg") ssize-t 78 | (socket :int) 79 | (message :pointer) 80 | (flags :int)) 81 | 82 | (define-socket-call (%sendmsg "sendmsg") ssize-t 83 | (socket :int) 84 | (message :pointer) 85 | (flags :int)) 86 | 87 | (define-socket-call (%setsockopt "setsockopt") :int 88 | (socket :int) 89 | (level :int) 90 | (optname :int) 91 | (optval :pointer) 92 | (optlen socklen-t)) 93 | 94 | (define-socket-call (%shutdown "shutdown") :int 95 | (socket :int) 96 | (how :int)) 97 | 98 | ;;; SOCKET is emulated in winsock.lisp. 99 | (define-socket-creation-call (%socket "socket") :int 100 | (domain :int) ; af-* 101 | (type :int) ; sock-* 102 | (protocol :int)) 103 | 104 | #-(and) ; unused 105 | (define-socket-call (%sockatmark "sockatmark") :int 106 | (socket :int)) 107 | 108 | (define-socket-creation-call (%%socketpair "socketpair") :int 109 | (domain :int) ; af-* 110 | (type :int) ; sock-* 111 | (protocol :int) ; usually 0 - "default protocol", whatever that is 112 | (filedes :pointer)) 113 | 114 | (defun %socketpair (domain type protocol) 115 | (with-foreign-object (filedes :int 2) 116 | (%%socketpair domain type protocol filedes) 117 | (values (mem-aref filedes :int 0) 118 | (mem-aref filedes :int 1)))) 119 | 120 | ;;;; netinet/un.h 121 | 122 | (defconstant unix-path-max 123 | (- (isys:sizeof '(:struct sockaddr-un)) 124 | (foreign-slot-offset '(:struct sockaddr-un) 'path))) 125 | 126 | ;;;; net/if.h 127 | 128 | (defsyscall (%if-nametoindex "if_nametoindex") 129 | (:unsigned-int 130 | :error-predicate zerop 131 | :error-generator (lambda (r syscall h h2) 132 | (declare (ignore r h h2)) 133 | (isys:signal-syscall-error-kw :enxio syscall))) 134 | (ifname :string)) 135 | 136 | (defsyscall (%if-indextoname "if_indextoname") 137 | :string 138 | (ifindex :unsigned-int) 139 | (ifname :pointer)) 140 | 141 | (defsyscall (%if-nameindex "if_nameindex") 142 | :pointer) 143 | 144 | (defsyscall (%if-freenameindex "if_freenameindex") :void 145 | (ptr :pointer)) 146 | -------------------------------------------------------------------------------- /src/sockets/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Socket conditions. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defgeneric error-code (err) 9 | (:method ((err isys:syscall-error)) 10 | (isys:code-of err))) 11 | 12 | (defgeneric error-identifier (err) 13 | (:method ((err isys:syscall-error)) 14 | (isys:identifier-of err))) 15 | 16 | (defgeneric error-message (err) 17 | (:method ((err isys:syscall-error)) 18 | (isys:message-of err))) 19 | 20 | ;;;; Socket Errors 21 | 22 | (define-condition socket-error (isys:syscall-error) ()) 23 | 24 | (defmethod print-object ((socket-error socket-error) stream) 25 | (print-unreadable-object (socket-error stream :type t :identity nil) 26 | (let ((code (iolib/syscalls:code-of socket-error))) 27 | (format stream "~S ~S ~S~@[, FD: ~S~]" 28 | (or code "[Unknown code]") 29 | (error-identifier socket-error) 30 | (if code (isys:strerror code) "[Can't get error string.]") 31 | (isys:handle-of socket-error))))) 32 | 33 | (defparameter *socket-error-map* (make-hash-table :test 'eql)) 34 | 35 | (defmacro define-socket-error (name identifier &optional documentation) 36 | ;; FIXME: find a better way to conditionally define syscall errors 37 | (when (find identifier (cffi:foreign-enum-keyword-list 'isys:errno-values)) 38 | (let ((errno (cffi:foreign-enum-value 'isys:errno-values identifier))) 39 | `(progn 40 | (setf (gethash ,errno *socket-error-map*) ',name) 41 | (define-condition ,name (,(isys:get-syscall-error-condition errno) 42 | socket-error) () 43 | (:default-initargs :code ,(foreign-enum-value 'socket-error-values 44 | identifier) 45 | :identifier ,identifier) 46 | (:documentation ,(or documentation (isys:strerror identifier)))))))) 47 | 48 | (defun lookup-socket-error (errno) 49 | (gethash errno *socket-error-map*)) 50 | 51 | (define-condition unknown-socket-error (socket-error) () 52 | (:documentation "Error signalled upon finding an unknown socket error.")) 53 | 54 | (define-socket-error socket-address-in-use-error :eaddrinuse) 55 | (define-socket-error socket-address-family-not-supported-error :eafnosupport) 56 | (define-socket-error socket-address-not-available-error :eaddrnotavail) 57 | (define-socket-error socket-network-down-error :enetdown) 58 | (define-socket-error socket-network-reset-error :enetreset) 59 | (define-socket-error socket-network-unreachable-error :enetunreach) 60 | (define-socket-error socket-no-network-error :enonet) 61 | (define-socket-error socket-connection-aborted-error :econnaborted) 62 | (define-socket-error socket-connection-reset-error :econnreset) 63 | (define-socket-error socket-connection-refused-error :econnrefused) 64 | (define-socket-error socket-connection-timeout-error :etimedout) 65 | (define-socket-error socket-connection-in-progress-error :einprogress) 66 | (define-socket-error socket-endpoint-shutdown-error :eshutdown) 67 | (define-socket-error socket-no-buffer-space-error :enobufs) 68 | (define-socket-error socket-host-down-error :ehostdown) 69 | (define-socket-error socket-host-unreachable-error :ehostunreach) 70 | (define-socket-error socket-already-connected-error :eisconn) 71 | (define-socket-error socket-not-connected-error :enotconn) 72 | (define-socket-error socket-option-not-supported-error :enoprotoopt) 73 | (define-socket-error socket-operation-not-supported-error :eopnotsupp) 74 | 75 | (declaim (inline %signal-socket-error)) 76 | (defun %signal-socket-error (errno syscall fd fd2) 77 | (when-let (err (lookup-socket-error errno)) 78 | (error err :syscall syscall :handle fd :handle2 fd2))) 79 | 80 | ;;; Used in the ERRNO-WRAPPER foreign type. 81 | (declaim (inline signal-socket-error)) 82 | (defun signal-socket-error (errno &optional syscall fd fd2) 83 | (cond 84 | ((= errno isys:eintr) 85 | (error 'isys:eintr :syscall syscall :handle fd :handle2 fd2)) 86 | ((= errno isys:ewouldblock) 87 | (error 'isys:ewouldblock :syscall syscall :handle fd :handle2 fd2)) 88 | (t 89 | (or (%signal-socket-error errno syscall fd fd2) 90 | (error (isys:make-syscall-error errno syscall fd fd2)))))) 91 | -------------------------------------------------------------------------------- /examples/echo-server.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Multiplexer example, adapted from Juho Snellman's version for SBCL 4 | ;;; which is available at http://jsnell.iki.fi/tmp/echo-server.lisp. 5 | ;;; 6 | 7 | (eval-when (:compile-toplevel :load-toplevel :execute) 8 | (asdf:oos 'asdf:load-op :iolib.sockets)) 9 | 10 | (defpackage echo-server 11 | (:nicknames #:es) 12 | (:use :cl :alexandria) 13 | (:export #:run-server #:*port*)) 14 | 15 | (in-package :echo-server) 16 | 17 | (defparameter *port* 9999) 18 | (defvar *event-base* nil) 19 | (defvar *sockets* ()) 20 | (defvar *counter* 0) 21 | 22 | (defun add-socket (socket) 23 | (push socket *sockets*)) 24 | 25 | (defun remove-socket (socket) 26 | (removef *sockets* socket)) 27 | 28 | (defun close-socket (socket) 29 | (let ((fd (iolib.sockets:socket-os-fd socket))) 30 | (ignore-some-conditions (isys:syscall-error) 31 | (iomux:remove-fd-handlers *event-base* fd)) 32 | (remove-socket socket) 33 | (close socket))) 34 | 35 | (defun make-echoer (stream id disconnector) 36 | (lambda (fd event exception) 37 | (declare (ignore fd event exception)) 38 | (handler-case 39 | (let ((line (read-line stream))) 40 | (cond ((string= line "quit") 41 | (funcall disconnector)) 42 | (t 43 | (format t "~A: ~A~%" id line) 44 | (format stream "~A: ~A~%" id line) 45 | (ignore-some-conditions (iolib.streams:hangup) 46 | (finish-output stream))))) 47 | (end-of-file () 48 | (funcall disconnector))))) 49 | 50 | (defun make-disconnector (socket id) 51 | (lambda () 52 | (format t "~A: closing~%" id) 53 | (close-socket socket))) 54 | 55 | (defun serve (socket id) 56 | (iomux:set-io-handler *event-base* 57 | (iolib.sockets:socket-os-fd socket) 58 | :read 59 | (make-echoer socket id 60 | (make-disconnector socket id)))) 61 | 62 | (defun make-listener-handler (socket) 63 | (lambda (fd event exception) 64 | (declare (ignore fd event)) 65 | (block nil 66 | (when (eql :timeout exception) 67 | (warn "Got a server timeout!") 68 | (return)) 69 | (let ((client (iolib.sockets:accept-connection socket))) 70 | (when client 71 | (setf (iolib.streams:fd-non-blocking client) t) 72 | (add-socket client) 73 | (incf *counter*) 74 | (format t "Accepted client ~A~%" *counter*) 75 | (serve client *counter*)))))) 76 | 77 | (defun start-echo-server (host port) 78 | (let ((socket 79 | (iolib.sockets:make-socket :connect :passive :address-family :internet :type :stream 80 | :local-host host :local-port port 81 | :backlog 5 :reuse-address t 82 | :external-format '(:utf-8 :eol-style :crlf) :ipv6 nil))) 83 | (setf *counter* 0 84 | *sockets* nil) 85 | (unwind-protect-case () 86 | (progn 87 | (setf (iolib.streams:fd-non-blocking socket) t) 88 | (iomux:set-io-handler *event-base* 89 | (iolib.sockets:socket-os-fd socket) 90 | :read 91 | (make-listener-handler socket) 92 | :timeout 15)) 93 | (:abort (close socket))) 94 | socket)) 95 | 96 | (defun close-all-sockets () 97 | (map 'nil #'close-socket *sockets*)) 98 | 99 | (defun run-server (&key (host iolib.sockets:+ipv4-unspecified+) 100 | (port *port*) (new-process t) (timeout 10)) 101 | (flet ((%run-server () 102 | (unwind-protect 103 | (progn 104 | (setf *event-base* (make-instance 'iomux:event-base)) 105 | (with-open-stream (sock (start-echo-server host port)) 106 | (declare (ignorable sock)) 107 | (iomux:event-dispatch *event-base* :timeout timeout))) 108 | (close-all-sockets) 109 | (close *event-base*)))) 110 | (let ((iolib.sockets:*ipv6* nil)) 111 | (if new-process 112 | (bt:make-thread #'%run-server) 113 | (%run-server))))) 114 | -------------------------------------------------------------------------------- /src/syscalls/conditions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Syscall error conditions. 4 | ;;; 5 | 6 | (in-package :iolib/syscalls) 7 | 8 | ;;;------------------------------------------------------------------------- 9 | ;;; System Errors 10 | ;;;------------------------------------------------------------------------- 11 | 12 | (define-condition iolib-condition () 13 | ()) 14 | 15 | (define-condition iolib-error (error iolib-condition) 16 | ()) 17 | 18 | (define-condition syscall-error (iolib-error) 19 | ((syscall :initarg :syscall :reader syscall-of 20 | :documentation "The name of the C syscall.") 21 | (code :initarg :code :reader code-of 22 | :documentation "Numeric error code, or NIL.") 23 | (identifier :initarg :identifier :reader identifier-of 24 | :documentation "Keyword identifier, or NIL.") 25 | (message :initarg :message :reader message-of 26 | :documentation "Error description.") 27 | (handle :initform nil :initarg :handle :reader handle-of 28 | :documentation "The OS handle involved in the error situation.") 29 | (handle2 :initform nil :initarg :handle2 :reader handle2-of 30 | :documentation "An optional second OS handler.")) 31 | (:default-initargs :code nil :identifier :unknown :message nil) 32 | (:documentation "Base class for syscall errors.")) 33 | 34 | (defun syscall-error-p (thing) 35 | (typep thing 'syscall-error)) 36 | 37 | (defun syscall-error (control-string &rest args) 38 | (error 'syscall-error :message (format nil "~?" control-string args))) 39 | 40 | 41 | ;;;------------------------------------------------------------------------- 42 | ;;; I/O Poll Errors 43 | ;;;------------------------------------------------------------------------- 44 | 45 | (define-condition poll-error (syscall-error) 46 | ((event-type :initarg :event-type :reader event-type-of)) 47 | (:report (lambda (c s) 48 | (format s "Poll error(event ~S, handle ~A)" 49 | (event-type-of c) (handle-of c)) 50 | (when (message-of c) 51 | (format s ": ~A" (message-of c))))) 52 | (:documentation 53 | "Signaled when an error occurs while polling for I/O readiness 54 | of a file descriptor.")) 55 | 56 | (define-condition poll-timeout (poll-error) 57 | () 58 | (:report (lambda (c s) 59 | (format s "Poll timeout(event ~S, handle ~A)" 60 | (event-type-of c) (handle-of c)) 61 | (when (message-of c) 62 | (format s ": ~A" (message-of c))))) 63 | (:documentation 64 | "Signaled when a timeout occurs while polling for I/O readiness 65 | of a file descriptor.")) 66 | 67 | 68 | ;;;------------------------------------------------------------------------- 69 | ;;; Repeat upon conditions 70 | ;;;------------------------------------------------------------------------- 71 | 72 | (defmacro repeat-upon-condition ((&rest conditions) &body body) 73 | (with-gensyms (block-name) 74 | `(loop :named ,block-name :do 75 | (ignore-some-conditions ,conditions 76 | (return-from ,block-name (progn ,@body)))))) 77 | 78 | (defmacro repeat-upon-eintr (&body body) 79 | `(repeat-upon-condition (eintr) ,@body)) 80 | 81 | (defmacro repeat-decreasing-timeout 82 | ((timeout-var timeout &optional (block-name nil blockp)) &body body) 83 | (unless (find timeout-var (flatten body)) 84 | (warn "You probably want to use ~S inside the body ~A" timeout-var body)) 85 | (unless blockp (setf block-name (gensym "BLOCK"))) 86 | (with-gensyms (deadline temp-timeout) 87 | `(let* ((,timeout-var ,timeout) 88 | (,deadline (when ,timeout-var 89 | (+ ,timeout-var (get-monotonic-time))))) 90 | (loop :named ,block-name :do 91 | ,@body 92 | (when ,deadline 93 | (let ((,temp-timeout (- ,deadline (get-monotonic-time)))) 94 | (setf ,timeout-var 95 | (if (plusp ,temp-timeout) 96 | ,temp-timeout 97 | 0)))))))) 98 | 99 | (defmacro repeat-upon-condition-decreasing-timeout 100 | (((&rest conditions) timeout-var timeout &optional (block-name nil blockp)) &body body) 101 | (unless blockp (setf block-name (gensym "BLOCK"))) 102 | `(repeat-decreasing-timeout (,timeout-var ,timeout ,block-name) 103 | (ignore-some-conditions ,conditions 104 | (return-from ,block-name (progn ,@body))))) 105 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | -*- mode: outline; fill-column: 78 -*- 2 | 3 | * Changes in 0.7.3 -> 0.8.0: 4 | 5 | ** Dependencies 6 | * Add dependency on libFixPOSIX 7 | * Add dependencies on SPLIT-SEQUENCE, IDNA 8 | 9 | ** API changes 10 | * Add parameter NS to LOOKUP-HOSTNAME 11 | * Remove accessor FD-NON-BLOCKING of FD-MIXIN 12 | - Stream file descriptors are always non-blocking now 13 | * Rewrote CREATE-PROCESS and RUN-PROGRAM 14 | - Add attributes setuid, setgid, resetids and cwd 15 | - Coalesce process name and arguments into a single parameter 16 | - Remove keyarg SEARCH 17 | - Redirect standard descriptors to pipes by default 18 | - Add support for PTYs 19 | - Add keyarg EXTERNAL-FORMAT 20 | - Keep standard streams unbound in a PROCESS instance if not connected 21 | - Use /bin/sh as system shell 22 | * RUN-PROGRAM: a null EXTERNAL-FORMAT will make it return STDOUT and STDERR as octet arrays 23 | * PROCESS-WAIT: change return values 24 | - Return only the exit status on normal exit otherwise 25 | (values signal coredump-p), signal being a keyword 26 | * PROCESS-KILL: make the signal optional(default SIGTERM) and allow keywords too 27 | * Turn PROCESS-STATUS, PROCESS-ACTIVEP and PROCESS-KILL into generic functions 28 | * Export GET-MONOTONIC-TIME from IOLIB.OS 29 | * Allow passing a FOREIGN-POINTER to SEND-TO 30 | * ACCEPT-CONNECTION now returns the remote port as third value for TCP sockets 31 | * Remove stream finalizers 32 | * Add keyarg DUP to MAKE-SOCKET-FROM-FD, null by default 33 | * DELETE-FILES: avoid following symlinks by default, add a keyword argument to enable it 34 | 35 | ** New features 36 | * Add support for IDN to LOOKUP-HOSTNAME 37 | * Wrap syscalls sendfile(), syslog() 38 | * Add accessor WTERMSIG* 39 | * New socket options: IP_HDRINCL, IP_RECVERR, ICMP_FILTER 40 | * Add raw sockets, sponsored by Walled Inc. 41 | * DNS resolver: add support for SRV records 42 | * Export DNS resolver functionality 43 | * Add ABCL gray streams support 44 | 45 | ** Bug fixes: 46 | * Various fixes for Scieneer 47 | * Fix printing of DUAL-CHANNEL-GRAY-STREAM instances: print the actual type 48 | * SOCKET-CONNECTED-P: ignore EINVAL as well 49 | * Make sure that OPEN-STREAM-P works on stream sockets. 50 | * %stream-read-sequence and %stream-write-sequence: fix case where (= start end) 51 | * Fix segfault in LIST-NETWORK-INTERFACES 52 | * EPOLL-MULTIPLEXER: allocate an array large enough to hold events for all FDs 53 | * Remove event-loop exit timer after timeout 54 | 55 | ** Misc 56 | * Reworked build system for ASDF3 57 | - Systems are now to be referred to as iolib/name, the oldsystem names are 58 | available for backwards-compatibility; likewise for package names 59 | - The new .asd files are iolib.asd and asdf2-compat/*.asd 60 | 61 | 62 | 63 | * Changes since 0.7.1: 64 | 65 | ** Bug fixes: 66 | - Don't redefine Alexandria functions (patch by Nikodemus Siivola) 67 | 68 | 69 | 70 | * Changes since 0.7.0: 71 | 72 | ** Bug fixes: 73 | - Only import a few symbols from ASDF into IOLIB.ASDF, which sometimes caused 74 | problems with ASDF2 75 | - Fix compilation on OSX 76 | 77 | 78 | 79 | * Changes since 0.6.0: 80 | 81 | ** API changes 82 | - IOLIB.SOCKETS:LOOKUP-HOST was renamed to LOOKUP-HOSTNAME 83 | - IOLIB.SOCKETS:IPV6-SOCKET-P was renamed to SOCKET-IPV6-P 84 | - When creating an AF_LOCAL socket, IOLIB.SOCKETS:MAKE-SOCKET accepts :FILE as 85 | :TYPE synonim of :LOCAL 86 | - IOLIB.SOCKETS:ACCEPT-CONNECTION : keyword arg TIMEOUT has been coalesced 87 | into WAIT 88 | - IOLIB.SOCKETS:CONNECT : keyword arg TIMEOUT has been coalesced into WAIT 89 | 90 | ** New features 91 | - Add support for abstract UNIX addresses (patch by Julian Stecklina) 92 | - UNIX addresses are now printed as strings. Abstract addresses have a leading #\@ 93 | 94 | ** Bug fixes: 95 | - EVENT-DISPATCH now calculates the distance to the next timer correctly 96 | (reported by Ariel Badichi) 97 | - fixed possible fd load in the the select() multiplexer (reported by Ariel 98 | Badichi) 99 | - reading from socket streams with non-blocking FDs now works (reported by 100 | Chaitanya Gupta) 101 | - make RESOLVER-ERROR actually a subtype of IOLIB-ERROR (reported by Ariel Badichi) 102 | - socket syscalls that return EINTR now work 103 | - when setting send/receive timeouts on blocking sockets, stream methods now 104 | properly signal ISYS:EWOULDBLOCK upon timeout 105 | - fix bug in HEAP-PARENT, used in the multiplexer (reported by Ole Arndt on sbcl-devel) 106 | - fix define-designator for when *print-case* is :downcase. 107 | 108 | ** Misc 109 | - Sources have been reorganized, ASDF system files are now inside src/ 110 | -------------------------------------------------------------------------------- /src/streams/gray/buffer.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Foreign memory buffers. 4 | ;;; 5 | 6 | (in-package :iolib/streams) 7 | 8 | ;;;; Foreign Buffers 9 | 10 | (defconstant +bytes-per-iobuf+ (* 4 1024)) 11 | 12 | ;;; FIXME: make this right 13 | ;;; probably not all SIMPLE-ARRAYs are admissible 14 | ;;; on all implementations 15 | (deftype compatible-lisp-array () 16 | '(simple-array * (*))) 17 | 18 | (defun allocate-iobuf (&optional (size +bytes-per-iobuf+)) 19 | (let ((b (%make-iobuf))) 20 | (setf (iobuf-data b) (foreign-alloc :uint8 :count size) 21 | (iobuf-size b) size) 22 | (values b))) 23 | 24 | (defun free-iobuf (iobuf) 25 | (unless (null-pointer-p (iobuf-data iobuf)) 26 | (foreign-free (iobuf-data iobuf))) 27 | (setf (iobuf-data iobuf) (null-pointer)) 28 | (values iobuf)) 29 | 30 | (defun iobuf-length (iobuf) 31 | (- (iobuf-end iobuf) 32 | (iobuf-start iobuf))) 33 | 34 | (defun iobuf-start-pointer (iobuf) 35 | (inc-pointer (iobuf-data iobuf) 36 | (iobuf-start iobuf))) 37 | 38 | (defun iobuf-end-pointer (iobuf) 39 | (inc-pointer (iobuf-data iobuf) 40 | (iobuf-end iobuf))) 41 | 42 | (defun iobuf-empty-p (iobuf) 43 | (= (iobuf-end iobuf) 44 | (iobuf-start iobuf))) 45 | 46 | (defun iobuf-full-p (iobuf) 47 | (= (iobuf-end iobuf) 48 | (iobuf-size iobuf))) 49 | 50 | (defun iobuf-end-space-length (iobuf) 51 | (- (iobuf-size iobuf) 52 | (iobuf-end iobuf))) 53 | 54 | (defun iobuf-reset (iobuf) 55 | (setf (iobuf-start iobuf) 0 56 | (iobuf-end iobuf) 0)) 57 | 58 | (defun iobuf-peek (iobuf &optional (offset 0)) 59 | (bref iobuf (+ (iobuf-start iobuf) offset))) 60 | 61 | (defun iobuf-copy-data-to-start (iobuf) 62 | (declare (type iobuf iobuf)) 63 | (isys:memmove 64 | (iobuf-data iobuf) 65 | (inc-pointer (iobuf-data iobuf) 66 | (iobuf-start iobuf)) 67 | (iobuf-length iobuf)) 68 | (setf (iobuf-end iobuf) (iobuf-length iobuf)) 69 | (setf (iobuf-start iobuf) 0)) 70 | 71 | (defun iobuf-can-fit-slice-p (iobuf start end) 72 | (<= (- end start) (iobuf-end-space-length iobuf))) 73 | 74 | (defun iobuf-append-slice (iobuf array start end) 75 | (let ((slice-length (- end start))) 76 | (iobuf-copy-from-lisp-array array start iobuf 77 | (iobuf-end iobuf) slice-length) 78 | (incf (iobuf-end iobuf) slice-length))) 79 | 80 | ;;; BREF, (SETF BREF) and BUFFER-COPY *DO NOT* check boundaries 81 | ;;; that must be done by their callers 82 | (defun bref (iobuf index) 83 | (declare (type iobuf iobuf) 84 | (type buffer-index index)) 85 | (debug-only (assert (not (minusp index)))) 86 | (mem-aref (iobuf-data iobuf) :uint8 index)) 87 | 88 | (defun (setf bref) (octet iobuf index) 89 | (declare (type (unsigned-byte 8) octet) 90 | (type iobuf iobuf) 91 | (type buffer-index index)) 92 | (debug-only 93 | (assert (>= index 0)) 94 | (assert (< index (iobuf-size iobuf)))) 95 | (setf (mem-aref (iobuf-data iobuf) :uint8 index) octet)) 96 | 97 | (defun iobuf-copy-from-lisp-array (src soff dst doff length) 98 | (declare (type compatible-lisp-array src) 99 | (type iobuf dst) 100 | (type buffer-index soff doff length)) 101 | (debug-only 102 | (assert (>= doff 0)) 103 | (assert (>= soff 0)) 104 | (assert (<= (+ doff length) (iobuf-size dst)))) 105 | (let ((dst-ptr (iobuf-data dst))) 106 | (with-pointer-to-vector-data (src-ptr src) 107 | (isys:memcpy 108 | (inc-pointer dst-ptr doff) 109 | (inc-pointer src-ptr soff) 110 | length)))) 111 | 112 | (defun iobuf-copy-into-lisp-array (src soff dst doff length) 113 | (declare (type iobuf src) 114 | (type compatible-lisp-array dst) 115 | (type buffer-index soff doff length)) 116 | (debug-only 117 | (assert (>= doff 0)) 118 | (assert (>= soff 0)) 119 | (assert (<= (+ doff length) (length dst)))) 120 | (let ((src-ptr (iobuf-data src))) 121 | (with-pointer-to-vector-data (dst-ptr dst) 122 | (isys:memcpy 123 | (inc-pointer dst-ptr doff) 124 | (inc-pointer src-ptr soff) 125 | length)))) 126 | 127 | (defun iobuf-pop-octet (iobuf) 128 | (declare (type iobuf iobuf)) 129 | (debug-only (assert (> (iobuf-length iobuf) 0))) 130 | (let ((start (iobuf-start iobuf))) 131 | (prog1 (bref iobuf start) 132 | (incf (iobuf-start iobuf))))) 133 | 134 | (defun iobuf-push-octet (iobuf octet) 135 | (declare (type iobuf iobuf) 136 | (type (unsigned-byte 8) octet)) 137 | (debug-only (assert (not (iobuf-full-p iobuf)))) 138 | (let ((end (iobuf-end iobuf))) 139 | (prog1 (setf (bref iobuf end) octet) 140 | (incf (iobuf-end iobuf))))) 141 | -------------------------------------------------------------------------------- /src/sockets/namedb/hosts.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; hosts.lisp --- Static host lookup. 4 | ;;; 5 | 6 | (in-package :iolib/sockets) 7 | 8 | (defvar *hosts-file* "/etc/hosts") 9 | 10 | (defclass host () 11 | ((truename :initform nil :initarg :truename 12 | :accessor host-truename 13 | :documentation "The name of the host.") 14 | (aliases :initform nil :initarg :aliases 15 | :accessor host-aliases 16 | :documentation "A list of aliases.") 17 | (addresses :initform nil :initarg :addresses 18 | :accessor host-addresses 19 | :documentation "A list of addresses.")) 20 | (:documentation "Class representing a host: name, aliases and addresses.")) 21 | 22 | (defmethod initialize-instance :after ((host host) &key) 23 | (with-accessors ((name host-truename) (aliases host-aliases) 24 | (addresses host-addresses)) host 25 | (flet ((namep (h) (and (stringp h) (plusp (length h))))) 26 | (assert (namep name) (name) "Invalid host truename: ~A" name) 27 | (assert (every #'namep aliases) (aliases) "Invalid host aliases: ~A" aliases) 28 | (assert addresses (addresses) "A host must have at least one address.") 29 | (setf addresses (ensure-list addresses)) 30 | (map-into addresses #'ensure-address addresses)))) 31 | 32 | (defun make-host (truename addresses &optional aliases) 33 | "Instantiates a HOST object." 34 | (make-instance 'host 35 | :truename truename 36 | :aliases aliases 37 | :addresses addresses)) 38 | 39 | (defmethod print-object ((host host) stream) 40 | (print-unreadable-object (host stream :type t :identity nil) 41 | (with-slots (truename aliases addresses) host 42 | (format stream "Canonical name: ~S. Aliases: ~:[None~;~:*~{~S~^, ~}~]. Addresses: ~{~A~^, ~}" 43 | truename aliases addresses)))) 44 | 45 | (defvar *hosts-cache* ()) 46 | (defvar *hosts-cache-lock* (bt:make-lock "/etc/hosts cache lock")) 47 | 48 | (defun parse-/etc/hosts (file) 49 | (let (hosts) 50 | (flet ((parse-one-line (tokens) 51 | (when (< (length tokens) 2) (error 'parse-error)) 52 | (destructuring-bind (address cname &rest aliases) tokens 53 | (push (make-host cname (ensure-address address) aliases) 54 | hosts)))) 55 | (alexandria:ignore-some-conditions (file-error) 56 | (map-etc-file (lambda (tokens) (ignore-errors (parse-one-line tokens))) 57 | file)) 58 | (nreverse hosts)))) 59 | 60 | (defun search-host-by-name (name ipv6) 61 | (labels ((compatible-address-p (address) 62 | (ecase ipv6 63 | ((t) (inet-address-p address)) 64 | ((nil) (ipv4-address-p address)) 65 | (:ipv6 (ipv6-address-p address)))) 66 | (compatible-host-p (host) 67 | (and (or (string= name (host-truename host)) 68 | (member name (host-aliases host) 69 | :test #'string=)) 70 | (compatible-address-p (car (host-addresses host)))))) 71 | (let ((hosts (bt:with-lock-held (*hosts-cache-lock*) 72 | (remove-if-not #'compatible-host-p *hosts-cache*))) 73 | addresses aliases) 74 | (when hosts 75 | (mapc (lambda (host) 76 | (let ((address (car (host-addresses host)))) 77 | (push address addresses) 78 | (push (cons (host-truename host) address) aliases) 79 | (mapc (lambda (alias) (push (cons alias address) aliases)) 80 | (host-aliases host)))) 81 | hosts) 82 | (let ((addresses (nreverse addresses))) 83 | (values (car addresses) (cdr addresses) 84 | name (nreverse aliases))))))) 85 | 86 | (defun search-host-by-address (address) 87 | (let* ((address (ensure-address address)) 88 | (host (bt:with-lock-held (*hosts-cache-lock*) 89 | (find-if (lambda (host) 90 | (address= (car (host-addresses host)) 91 | address)) 92 | *hosts-cache*)))) 93 | (when host 94 | (values address '() 95 | (host-truename host) 96 | (list* (cons (host-truename host) address) 97 | (mapcar (lambda (alias) (cons alias address)) 98 | (host-aliases host))))))) 99 | 100 | (defun update-hosts-list (file) 101 | (setf *hosts-cache* (parse-/etc/hosts file))) 102 | 103 | (defvar *hosts-monitor* 104 | (make-instance 'file-monitor 105 | :file *hosts-file* 106 | :update-fn 'update-hosts-list 107 | :lock *hosts-cache-lock*)) 108 | -------------------------------------------------------------------------------- /src/streams/zeta/device.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- Device common functions. 4 | ;;; 5 | 6 | (in-package :iolib/zstreams) 7 | 8 | ;;;------------------------------------------------------------------------- 9 | ;;; Classes and Types 10 | ;;;------------------------------------------------------------------------- 11 | 12 | (defclass device () 13 | ((handle :initarg :handle 14 | :accessor device-handle) 15 | (readable :initarg :readable 16 | :accessor device-readablep) 17 | (writeable :initarg :writeable 18 | :accessor device-writeablep) 19 | (seekable :initarg :seekable 20 | :accessor device-seekablep))) 21 | 22 | (defclass direct-device (device) ()) 23 | 24 | (defclass memory-buffer-device (direct-device) ()) 25 | 26 | 27 | ;;;------------------------------------------------------------------------- 28 | ;;; Relinquish I/O resources 29 | ;;;------------------------------------------------------------------------- 30 | 31 | (defgeneric relinquish (device &rest args &key abort)) 32 | 33 | 34 | ;;;------------------------------------------------------------------------- 35 | ;;; Generic functions 36 | ;;;------------------------------------------------------------------------- 37 | 38 | (defgeneric device-read (device vector &key start end timeout)) 39 | 40 | (defgeneric device-write (device vector &key start end timeout)) 41 | 42 | (defgeneric device-position (device)) 43 | 44 | (defgeneric (setf device-position) (position device &optional from)) 45 | 46 | (defgeneric device-length (device)) 47 | 48 | (defgeneric (setf device-length) (length device)) 49 | 50 | (defgeneric device-poll (device direction &optional timeout)) 51 | 52 | ;;; Internal functions 53 | 54 | (defgeneric device-open (device slot-names initargs)) 55 | 56 | (defgeneric device-read/non-blocking (device vector start end)) 57 | 58 | (defgeneric device-read/timeout (device vector start end timeout)) 59 | 60 | (defgeneric device-write/non-blocking (device vector start end)) 61 | 62 | (defgeneric device-write/timeout (device vector start end timeout)) 63 | 64 | 65 | ;;;------------------------------------------------------------------------- 66 | ;;; Helper macros 67 | ;;;------------------------------------------------------------------------- 68 | 69 | (defmacro with-device ((name) &body body) 70 | `(let ((*device* ,name)) 71 | (declare (special *device*)) 72 | ,@body)) 73 | 74 | 75 | ;;;------------------------------------------------------------------------- 76 | ;;; Default no-op methods 77 | ;;;------------------------------------------------------------------------- 78 | 79 | (defmethod relinquish (device &key abort) 80 | (declare (ignore device abort))) 81 | 82 | (defmethod device-position ((device device)) 83 | ;; FIXME: signal proper condition 84 | (error "Device not seekable: ~S" device)) 85 | 86 | (defmethod (setf device-position) (position (device device) &optional from) 87 | (declare (ignore position from)) 88 | ;; FIXME: signal proper condition 89 | (error "Device not seekable: ~S" device)) 90 | 91 | (defmethod device-length ((device device)) 92 | ;; FIXME: signal proper condition 93 | (error "Device not seekable: ~S" device)) 94 | 95 | (defmethod (setf device-length) (length (device device)) 96 | (declare (ignore length)) 97 | ;; FIXME: signal proper condition 98 | (error "Device not seekable: ~S" device)) 99 | 100 | 101 | ;;;------------------------------------------------------------------------- 102 | ;;; Default DEVICE-READ 103 | ;;;------------------------------------------------------------------------- 104 | 105 | (defmethod device-read :around ((device device) vector &key 106 | (start 0) end timeout) 107 | (check-bounds vector start end) 108 | (when (= start end) (return* 0)) 109 | (call-next-method device vector :start start :end end :timeout timeout)) 110 | 111 | (defmethod device-read ((device device) vector &key start end timeout) 112 | (if (and timeout (zerop timeout)) 113 | (device-read/non-blocking device vector start end) 114 | (device-read/timeout device vector start end timeout))) 115 | 116 | 117 | ;;;------------------------------------------------------------------------- 118 | ;;; Default DEVICE-WRITE 119 | ;;;------------------------------------------------------------------------- 120 | 121 | (defmethod device-write :around ((device device) vector &key 122 | (start 0) end timeout) 123 | (check-bounds vector start end) 124 | (when (= start end) (return* 0)) 125 | (call-next-method device vector :start start :end end :timeout timeout)) 126 | 127 | (defmethod device-write ((device device) vector &key start end timeout) 128 | (if (and timeout (zerop timeout)) 129 | (device-write/non-blocking device vector start end) 130 | (device-write/timeout device vector start end timeout))) 131 | -------------------------------------------------------------------------------- /src/new-cl/gray-streams.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- GRAY stream mixin. 4 | ;;; 5 | 6 | (in-package :iolib/common-lisp) 7 | 8 | (defclass trivial-gray-stream-mixin () 9 | ((%open :initform t))) 10 | 11 | (defmethod close ((s trivial-gray-stream-mixin) &key abort) 12 | (declare (ignore abort)) 13 | (prog1 (slot-value s '%open) 14 | (setf (slot-value s '%open) nil))) 15 | 16 | (defmethod open-stream-p ((s trivial-gray-stream-mixin)) 17 | (slot-value s '%open)) 18 | 19 | (defgeneric stream-read-sequence 20 | (stream sequence start end &key &allow-other-keys)) 21 | 22 | (defgeneric stream-write-sequence 23 | (stream sequence start end &key &allow-other-keys)) 24 | 25 | (defgeneric stream-file-position (stream)) 26 | 27 | (defgeneric (setf stream-file-position) (newval stream)) 28 | 29 | (defmethod stream-write-string 30 | ((stream trivial-gray-stream-mixin) seq &optional start end) 31 | (stream-write-sequence stream seq (or start 0) (or end (length seq)))) 32 | 33 | ;; Implementations should provide this default method, I believe, but 34 | ;; at least sbcl and allegro don't. 35 | (defmethod stream-terpri ((stream trivial-gray-stream-mixin)) 36 | (write-char #\newline stream)) 37 | 38 | (defmethod stream-file-position ((stream trivial-gray-stream-mixin)) 39 | nil) 40 | 41 | (defmethod (setf stream-file-position) 42 | (newval (stream trivial-gray-stream-mixin)) 43 | (declare (ignore newval)) 44 | nil) 45 | 46 | #+allegro 47 | (progn 48 | (defmethod excl:stream-read-sequence 49 | ((s trivial-gray-stream-mixin) seq &optional start end) 50 | (stream-read-sequence s seq (or start 0) (or end (length seq)))) 51 | 52 | (defmethod excl:stream-write-sequence 53 | ((s trivial-gray-stream-mixin) seq &optional start end) 54 | (stream-write-sequence s seq (or start 0) (or end (length seq))))) 55 | 56 | #+cmu 57 | (progn 58 | (defmethod ext:stream-read-sequence 59 | ((s trivial-gray-stream-mixin) seq &optional start end) 60 | (stream-read-sequence s seq (or start 0) (or end (length seq)))) 61 | 62 | (defmethod ext:stream-write-sequence 63 | ((s trivial-gray-stream-mixin) seq &optional start end) 64 | (stream-write-sequence s seq (or start 0) (or end (length seq))))) 65 | 66 | #+lispworks 67 | (progn 68 | (defmethod stream:stream-read-sequence 69 | ((s trivial-gray-stream-mixin) seq start end) 70 | (stream-read-sequence s seq start end)) 71 | 72 | (defmethod stream:stream-write-sequence 73 | ((s trivial-gray-stream-mixin) seq start end) 74 | (stream-write-sequence s seq start end)) 75 | 76 | (defmethod stream:stream-file-position ((stream trivial-gray-stream-mixin)) 77 | (stream-file-position stream)) 78 | 79 | (defmethod (setf stream:stream-file-position) 80 | (newval (stream trivial-gray-stream-mixin)) 81 | (setf (stream-file-position stream) newval))) 82 | 83 | #+openmcl 84 | (progn 85 | (defmethod ccl:stream-read-vector 86 | ((s trivial-gray-stream-mixin) seq start end) 87 | (stream-read-sequence s seq start end)) 88 | 89 | (defmethod ccl:stream-write-vector 90 | ((s trivial-gray-stream-mixin) seq start end) 91 | (stream-write-sequence s seq start end))) 92 | 93 | #+clisp 94 | (eval-when (:compile-toplevel :load-toplevel :execute) 95 | (let* ((pkg (find-package :gray)) 96 | (sym (and pkg (find-symbol (string '#:stream-read-sequence) pkg)))) 97 | (unless (and sym (fboundp sym)) 98 | (error "Your CLISP does not have ~A and is therefore unsupported" 99 | "gray:stream-read-sequence")))) 100 | 101 | #+clisp 102 | (progn 103 | (defmethod gray:stream-read-sequence 104 | ((s trivial-gray-stream-mixin) seq &key start end) 105 | (stream-read-sequence s seq (or start 0) (or end (length seq)))) 106 | 107 | (defmethod gray:stream-write-sequence 108 | ((s trivial-gray-stream-mixin) seq &key start end) 109 | (stream-write-sequence s seq (or start 0) (or end (length seq)))) 110 | 111 | (defmethod gray:stream-position ((stream trivial-gray-stream-mixin) position) 112 | (if position 113 | (setf (stream-file-position stream) position) 114 | (stream-file-position stream)))) 115 | 116 | #+sbcl 117 | (progn 118 | (defmethod sb-gray:stream-read-sequence 119 | ((s trivial-gray-stream-mixin) seq &optional start end) 120 | (stream-read-sequence s seq (or start 0) (or end (length seq)))) 121 | 122 | (defmethod sb-gray:stream-write-sequence 123 | ((s trivial-gray-stream-mixin) seq &optional start end) 124 | (stream-write-sequence s seq (or start 0) (or end (length seq)))) 125 | 126 | ;; SBCL extension: 127 | (defmethod sb-gray:stream-line-length ((stream trivial-gray-stream-mixin)) 128 | 80)) 129 | 130 | #+ecl 131 | (progn 132 | (defmethod gray:stream-read-sequence 133 | ((s trivial-gray-stream-mixin) seq &optional start end) 134 | (stream-read-sequence s seq (or start 0) (or end (length seq)))) 135 | 136 | (defmethod gray:stream-write-sequence 137 | ((s trivial-gray-stream-mixin) seq &optional start end) 138 | (stream-write-sequence s seq (or start 0) (or end (length seq))))) 139 | -------------------------------------------------------------------------------- /src/multiplex/backend-kqueue.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- kqueue(2) multiplexer implementation. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | (defconstant +kqueue-priority+ 1) 9 | 10 | (define-multiplexer kqueue-multiplexer +kqueue-priority+ (multiplexer) 11 | ()) 12 | 13 | (defmethod print-object ((mux kqueue-multiplexer) stream) 14 | (print-unreadable-object (mux stream :type nil :identity nil) 15 | (format stream "kqueue(2) multiplexer"))) 16 | 17 | (defvar *kqueue-max-events* 200) 18 | 19 | (defmethod initialize-instance :after ((mux kqueue-multiplexer) &key) 20 | (setf (slot-value mux 'fd) (isys:kqueue))) 21 | 22 | (defun do-kqueue-event-request (kqueue-fd fd-entry filter request-type) 23 | (let ((fd (fd-entry-fd fd-entry))) 24 | (with-foreign-object (kev 'isys:kevent) 25 | (isys:bzero kev (isys:sizeof 'isys:kevent)) 26 | (isys:ev-set kev fd filter request-type 0 0 (null-pointer)) 27 | (isys:kevent kqueue-fd 28 | kev 1 29 | (null-pointer) 0 30 | (null-pointer))))) 31 | 32 | (defun calc-kqueue-monitor-filter (fd-entry) 33 | (if (null (fd-entry-read-handler fd-entry)) 34 | isys:evfilt-write 35 | isys:evfilt-read)) 36 | 37 | (defmethod monitor-fd ((mux kqueue-multiplexer) fd-entry) 38 | (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!") 39 | (handler-case 40 | (do-kqueue-event-request (fd-of mux) fd-entry 41 | (calc-kqueue-monitor-filter fd-entry) 42 | isys:ev-add) 43 | (isys:ebadf () 44 | (warn "FD ~A is invalid, cannot monitor it." (fd-entry-fd fd-entry))))) 45 | 46 | (defun calc-kqueue-update-filter-and-flags (event-type edge-change) 47 | (case event-type 48 | (:read 49 | (case edge-change 50 | (:add (values isys:evfilt-read isys:ev-add)) 51 | (:del (values isys:evfilt-read isys:ev-delete)))) 52 | (:write 53 | (case edge-change 54 | (:add (values isys:evfilt-write isys:ev-add)) 55 | (:del (values isys:evfilt-write isys:ev-delete)))))) 56 | 57 | (defmethod update-fd ((mux kqueue-multiplexer) fd-entry event-type edge-change) 58 | (assert fd-entry (fd-entry) "Must supply an FD-ENTRY!") 59 | (handler-case 60 | (multiple-value-call #'do-kqueue-event-request (fd-of mux) fd-entry 61 | (calc-kqueue-update-filter-and-flags event-type edge-change)) 62 | (isys:ebadf () 63 | (warn "FD ~A is invalid, cannot update its status." 64 | (fd-entry-fd fd-entry))) 65 | (isys:enoent () 66 | (warn "FD ~A was not monitored, cannot update its status." 67 | (fd-entry-fd fd-entry))))) 68 | 69 | (defun calc-kqueue-unmonitor-filter (fd-entry) 70 | (if (null (fd-entry-read-handler fd-entry)) 71 | isys:evfilt-read 72 | isys:evfilt-write)) 73 | 74 | (defmethod unmonitor-fd ((mux kqueue-multiplexer) fd-entry) 75 | (handler-case 76 | (do-kqueue-event-request (fd-of mux) fd-entry 77 | (calc-kqueue-unmonitor-filter fd-entry) 78 | isys:ev-delete) 79 | (isys:ebadf () 80 | (warn "FD ~A is invalid, cannot unmonitor it." (fd-entry-fd fd-entry))) 81 | (isys:enoent () 82 | (warn "FD ~A was not monitored, cannot unmonitor it." 83 | (fd-entry-fd fd-entry))))) 84 | 85 | (defmethod harvest-events ((mux kqueue-multiplexer) timeout) 86 | (with-foreign-objects ((events 'isys:kevent *kqueue-max-events*) 87 | (ts 'isys:timespec)) 88 | (isys:bzero events (* *kqueue-max-events* (isys:sizeof 'isys:kevent))) 89 | (let (ready-fds) 90 | (isys:repeat-upon-condition-decreasing-timeout 91 | ((isys:eintr) tmp-timeout timeout) 92 | (when tmp-timeout 93 | (timeout->timespec tmp-timeout ts)) 94 | (setf ready-fds 95 | (isys:kevent (fd-of mux) (null-pointer) 0 96 | events *kqueue-max-events* 97 | (if tmp-timeout ts (null-pointer))))) 98 | (macrolet ((kevent-slot (slot-name) 99 | `(foreign-slot-value (mem-aref events 'isys:kevent i) 100 | 'isys:kevent ',slot-name))) 101 | (loop for i below ready-fds 102 | for fd = (kevent-slot isys:ident) 103 | for flags = (kevent-slot isys:flags) 104 | for filter = (kevent-slot isys:filter) 105 | for data = (kevent-slot isys:data) 106 | for kqueue-event = (make-kqueue-event fd flags filter data) 107 | when kqueue-event collect kqueue-event))))) 108 | 109 | ;;; TODO: do something with DATA 110 | (defun make-kqueue-event (fd flags filter data) 111 | (declare (ignore data)) 112 | (let ((event ())) 113 | (switch (filter :test #'=) 114 | (isys:evfilt-write (push :write event)) 115 | (isys:evfilt-read (push :read event))) 116 | (flags-case flags 117 | ;; TODO: check what exactly EV_EOF means 118 | ;; (ev-eof (pushnew :read event)) 119 | (isys:ev-error (push :error event))) 120 | (when event 121 | (list fd event)))) 122 | -------------------------------------------------------------------------------- /src/multiplex/backend-poll.lisp: -------------------------------------------------------------------------------- 1 | ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | ;;; 3 | ;;; --- poll(2) multiplexer implementation. 4 | ;;; 5 | 6 | (in-package :iolib/multiplex) 7 | 8 | (defconstant +poll-priority+ 2) 9 | 10 | (define-multiplexer poll-multiplexer +poll-priority+ (multiplexer) 11 | ((fd-set :initform (allocate-pollfd-set) :accessor fd-set-of) 12 | (fd-set-size :initform 5 :accessor fd-set-size-of) 13 | (fd-count :initform 0 :accessor fd-count-of))) 14 | 15 | (defun allocate-pollfd-set (&optional (count 5)) 16 | (let ((fds (foreign-alloc 'nix::pollfd :count count))) 17 | (nix:bzero fds (* (isys:sizeof 'isys:pollfd) count)) 18 | (values fds))) 19 | 20 | (defmethod print-object ((mux poll-multiplexer) stream) 21 | (print-unreadable-object (mux stream :type nil :identity nil) 22 | (format stream "poll(2) multiplexer"))) 23 | 24 | (defmethod close-multiplexer progn ((mux poll-multiplexer)) 25 | (foreign-free (fd-set-of mux)) 26 | (setf (fd-set-of mux) nil)) 27 | 28 | (defvar *pollfd-table* (make-hash-table :test #'eql)) 29 | 30 | (defun calc-pollfd-flags (readp writep) 31 | (let ((flags 0)) 32 | (when readp (setf flags (logior nix:pollin nix:pollrdhup nix:pollpri))) 33 | (when writep (setf flags (logior flags nix:pollout nix:pollhup))) 34 | (values flags))) 35 | 36 | (defun set-pollfd-entry (fd-set index fd readp writep) 37 | (with-foreign-slots ((nix::fd nix::events nix::revents) 38 | (mem-aref fd-set 'nix::pollfd index) 39 | nix::pollfd) 40 | (setf nix::fd fd 41 | nix::revents 0 42 | nix::events (calc-pollfd-flags readp writep)))) 43 | 44 | (defun extend-pollfd-set (fd-set size) 45 | (let* ((new-size (+ size 5)) 46 | (new-fd-set (foreign-alloc 'nix::pollfd :count new-size))) 47 | (nix:memcpy new-fd-set fd-set (* size (isys:sizeof 'isys:pollfd))) 48 | (foreign-free fd-set) 49 | (values new-fd-set new-size))) 50 | 51 | (defmethod monitor-fd ((mux poll-multiplexer) fd-entry) 52 | (let ((fd (fd-entry-fd fd-entry)) 53 | (readp (fd-entry-read-handler fd-entry)) 54 | (writep (fd-entry-write-handler fd-entry))) 55 | (with-accessors ((fd-set fd-set-of) (size fd-set-size-of) 56 | (count fd-count-of)) mux 57 | (when (= count size) 58 | (setf (values fd-set size) (extend-pollfd-set fd-set size))) 59 | (set-pollfd-entry fd-set count fd readp writep) 60 | (setf (gethash fd *pollfd-table*) count) 61 | (incf count)))) 62 | 63 | (defmethod update-fd ((mux poll-multiplexer) fd-entry event-type edge-change) 64 | (declare (ignore event-type edge-change)) 65 | (let* ((fd (fd-entry-fd fd-entry)) 66 | (pos (gethash fd *pollfd-table*)) 67 | (readp (fd-entry-read-handler fd-entry)) 68 | (writep (fd-entry-write-handler fd-entry))) 69 | (with-accessors ((fd-set fd-set-of)) mux 70 | (set-pollfd-entry fd-set pos fd readp writep)))) 71 | 72 | (defun shrink-pollfd-set (fd-set count size pos) 73 | (let* ((new-size (if (> 5 (- size count)) (- size 5) size)) 74 | (new-fd-set (foreign-alloc 'nix::pollfd :count new-size))) 75 | (when (plusp pos) 76 | (nix:memcpy new-fd-set fd-set (* pos (isys:sizeof 'isys:pollfd)))) 77 | (when (< pos count) 78 | (nix:memcpy new-fd-set fd-set (* (- count pos) (isys:sizeof 'isys:pollfd)))) 79 | (foreign-free fd-set) 80 | (values new-fd-set new-size))) 81 | 82 | (defmethod unmonitor-fd ((mux poll-multiplexer) fd-entry) 83 | (let* ((fd (fd-entry-fd fd-entry)) 84 | (pos (gethash fd *pollfd-table*))) 85 | (with-accessors ((fd-set fd-set-of) (size fd-set-size-of) 86 | (count fd-count-of)) mux 87 | (setf (values fd-set size) (shrink-pollfd-set fd-set (1- count) size pos)) 88 | (remhash fd *pollfd-table*) 89 | (decf count)))) 90 | 91 | (defmethod harvest-events ((mux poll-multiplexer) timeout) 92 | (with-accessors ((fd-set fd-set-of) (size fd-set-size-of) 93 | (count fd-count-of)) mux 94 | ;; if there are no fds set and timeout is NULL 95 | ;; poll() blocks forever 96 | (when (and (zerop count) 97 | (null timeout)) 98 | (warn "Non fds to monitor and no timeout set !") 99 | (return* nil)) 100 | ;; FIXME: when does poll() return EBADF ? 101 | (nix:repeat-upon-condition-decreasing-timeout 102 | ((nix:eintr) tmp-timeout timeout) 103 | (nix:poll fd-set count (timeout->milliseconds tmp-timeout))) 104 | (harvest-pollfd-events fd-set count))) 105 | 106 | (defun harvest-pollfd-events (fd-set count) 107 | (macrolet ((pollfd-slot (name index) 108 | `(foreign-slot-value (mem-aref fd-set 'nix::pollfd ,index) 109 | 'nix::pollfd ,name))) 110 | (loop :for i :below count 111 | :for event := () 112 | :for fd := (pollfd-slot 'nix::fd i) 113 | :for revents := (pollfd-slot 'nix::revents i) 114 | :do (flags-case revents 115 | ((nix:pollout nix:pollhup) (push :write event)) 116 | ((nix:pollin nix:pollrdhup nix:pollpri) (push :read event)) 117 | ((nix:pollerr nix:pollnval) (push :error event))) 118 | :when event :collect (list fd event)))) 119 | --------------------------------------------------------------------------------