Changed the license to the AGPL3. Downcased all the lisp sources. Completed the READM...
[com-informatimago:com-informatimago.git] / clisp / iotask.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               iotask.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Encapsulates clisp socket-status.
10 ;;;;    
11 ;;;;AUTHORS
12 ;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
13 ;;;;MODIFICATIONS
14 ;;;;    2005-08-31 <PJB> Created.
15 ;;;;BUGS
16 ;;;;TODO merge with pollio?
17 ;;;;
18 ;;;;LEGAL
19 ;;;;    AGPL3
20 ;;;;    
21 ;;;;    Copyright Pascal Bourguignon 2005 - 2005
22 ;;;;    
23 ;;;;    This program is free software: you can redistribute it and/or modify
24 ;;;;    it under the terms of the GNU Affero General Public License as published by
25 ;;;;    the Free Software Foundation, either version 3 of the License, or
26 ;;;;    (at your option) any later version.
27 ;;;;    
28 ;;;;    This program is distributed in the hope that it will be useful,
29 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
30 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
31 ;;;;    GNU Affero General Public License for more details.
32 ;;;;    
33 ;;;;    You should have received a copy of the GNU Affero General Public License
34 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
35 ;;;;****************************************************************************
36
37 (defpackage "COM.INFORMATIMAGO.CLISP.IOTASK"
38   (:documentation
39    "This package exports a sheduler encapsulating clisp SOCKET:SOCKET-STATUS
40     which itself encapsulate select(2)/poll(2).
41
42     Copyright Pascal Bourguignon 2005 - 2005
43     This package is provided under the GNU General Public License.
44     See the source file for details.")
45   (:use "COMMON-LISP"
46          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ECMA048"
47          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
48          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.STRING"
49          "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST")
50   (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.ECMA048" "ED")
51   (:export
52    "IOTASK" "IOTASK-ENQUEUE" "IOTASK-ENQUEUE-STREAM" "IOTASK-DEQUEUE"
53    "IOTASK-POLL" "IOTASK-SCHEDULE"
54    "MAKE-BUFFERED-DISCIPLINE" "MAKE-KEYBOARD-DISCIPLINE"))
55 (in-package  "COM.INFORMATIMAGO.CLISP.IOTASK")
56
57
58 (defclass iotask ()
59   ((stream        :accessor iotask-stream        :initarg :stream)
60    (process-event :accessor iotask-process-event :initarg :process-event)
61    (name          :accessor iotask-name          :initarg :name)
62    (stdin  :accessor iotask-stdin  :initarg :stdin  :initform *standard-input*)
63    (stdout :accessor iotask-stdout :initarg :stdout :initform *standard-output*)
64    (stderr :accessor iotask-stderr :initarg :stderr :initform *error-output*)
65    (query  :accessor iotask-query  :initarg :query  :initform *query-io*)
66    (alarm-time    :accessor iotask-alarm-time    :initarg :alarm-time
67                   :documentation
68                   "The next run-time an :alarm event should be posted.
69                    (in INTERNAL-TIME-UNITS-PER-SECOND units)")
70    (alarm-period  :accessor iotask-alarm-period  :initarg :alarm-period
71                   :documentation
72                   "The period run-time an :alarm event should be posted.
73                    (in INTERNAL-TIME-UNITS-PER-SECOND units)")))
74 (defclass iotask-wait    () ())
75 (defclass iotask-no-wait () ())
76
77
78 (defmethod initialize-instance ((task iotask) &rest args)
79   (declare (ignore args))
80   (call-next-method)
81   (handler-case (socket:socket-status (iotask-stream task) 0)
82     (error     ()                           (change-class task 'iotask-no-wait))
83     (:no-error (s n) (declare (ignore s n)) (change-class task 'iotask-wait)))
84   task)
85
86
87 (defvar *iotasks*        '()
88   "List of IOTASK instances that are scheduled in the pool loop.")
89 (defvar *iotask-wait*    '()
90   "Sublist of *iotask* which can be handled by socket:socket-wait.")
91 (defvar *iotask-no-wait* '() 
92   "Sublist of *iotask* which cannot be handled by socket:socket-wait.")
93
94 ;; INVARIANT:
95 ;; (assert (null (intersection *iotask-wait* *iotask-no-wait*)))
96 ;; (assert (set-equal *iotasks* (union *iotask-wait* *iotask-no-wait*)))
97
98
99 (defun iotask-enqueue (task)
100   (push task *iotasks*)
101   (handler-case (socket:socket-status (iotask-stream task) 0)
102     (error     ()                           (push task *iotask-no-wait*))
103     (:no-error (s n) (declare (ignore s n)) (push task *iotask-wait*))))
104
105
106 (defun iotask-enqueue-stream (stream process-event
107                               &key name alarm-time alarm-period)
108   (iotask-enqueue (make-instance 'iotask
109                     :stream stream
110                     :stdin  stream
111                     :stdout stream
112                     :stderr stream
113                     :query  stream
114                     :process-event process-event
115                     :name          name
116                     :alarm-time    alarm-time
117                     :alarm-period  alarm-period)))
118
119
120 (defun iotask-dequeue (task)
121   (setf *iotasks*        (delete task *iotasks*))
122   (setf *iotask-wait*    (delete task *iotask-wait*))
123   (setf *iotask-no-wait* (delete task *iotask-no-wait*)))
124
125
126 (defun iotask-poll (&optional (timeout 0.0))
127   ;; TODO: implement the :alarm event.
128   (map nil 
129        (lambda (task status)
130          (when status
131            (let ((*standard-input*  (iotask-stdin  task))
132                  (*standard-output* (iotask-stdout task))
133                  (*error-output*    (iotask-stderr task))
134                  (*query-io*        (iotask-query  task)))
135              (funcall (iotask-process-event task) task status))))
136        *iotask-no-wait*
137        (mapcar
138         (lambda (task)
139           (let ((stream (iotask-stream task)))
140             (cond
141               ((input-stream-p stream)  (cond
142                                           ((listen stream)          :input)
143                                           ((output-stream-p stream) :output)
144                                           (t                        nil)))
145               ((output-stream-p stream) :output)
146               (t  nil))))
147         *iotask-no-wait*))
148   (map nil
149        (lambda (task status)
150          (when status
151            (let ((*standard-input*  (iotask-stdin  task))
152                  (*standard-output* (iotask-stdout task))
153                  (*error-output*    (iotask-stderr task))
154                  (*query-io*        (iotask-query  task)))
155              (funcall (iotask-process-event task) task status))))
156        *iotask-wait*
157        (socket:socket-status
158         (mapcar (function iotask-stream) *iotask-wait*) timeout)))
159
160
161 (defun iotask-schedule ()
162   (loop while *iotasks* do (iotask-poll 1.0)))
163
164
165 (defun make-buffered-discipline (process-input)
166   "process-input discipline to be used on buffered input streams."
167   (lambda (task event)
168     (when (member event '(:input :error))
169       (funcall process-input task (read-line (iotask-stream task))))))
170
171
172 (defun make-keyboard-discipline (process-input)
173   "process-input discipline to be used on clisp *keyboard-input*:
174    buffer up a line before forwarding to process-input."
175   (let ((buffer (make-array '(128) :element-type 'character
176                             :fill-pointer 0
177                             :adjustable t)))
178     (lambda (task event)
179       (when (eq :input event)
180         (let* ((ich (read-char (iotask-stream task)))
181                (ch  (system::input-character-char ich)))
182           (cond 
183             ((null ch))
184             ((= (char-code ch) com.informatimago.common-lisp.cesarum.ecma048:cr)
185              (terpri)
186              (finish-output)
187              (funcall process-input 
188                       task (subseq buffer 0 (fill-pointer buffer)))
189              (setf (fill-pointer buffer) 0))
190             ((or (= (char-code ch) com.informatimago.common-lisp.cesarum.ecma048:bs)
191                  (= (char-code ch) com.informatimago.common-lisp.cesarum.ecma048::del))
192              (when (< 0 (fill-pointer buffer))
193                (princ (code-char com.informatimago.common-lisp.cesarum.ecma048:bs))
194                (princ " ")
195                (princ (code-char com.informatimago.common-lisp.cesarum.ecma048:bs))
196                (finish-output)
197                (decf (fill-pointer buffer))))
198             (t
199              (princ ch)
200              (finish-output)
201              (vector-push ch buffer))))))))
202
203
204 ;;;; THE END ;;;;