- Implement optimized second-resolution timer access minimizing syscalls
[mmondor.git] / mmsoftware / cl / server / ecl-mp-server.lisp
1 ;;; $Id: ecl-mp-server.lisp,v 1.6 2011/08/13 07:57:43 mmondor Exp $
2
3 #|
4
5 Copyright (c) 2011, Matthew Mondor
6 All rights reserved.
7
8 Redistribution and use in source and binary forms, with or without
9 modification, are permitted provided that the following conditions
10 are met:
11 1. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
13 2. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17 THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18 IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19 OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20 IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23 USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24 THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26 THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28 |#
29
30 ;;; ecl-mp-server.lisp - Simple library for TCP server applications
31
32 ;;; XXX TODO XXX
33 ;;; - File/syslog logging (currently only supports in-memory logging)
34 ;;; - Maybe use reuseaddr/reuseport
35 ;;; - We support basic input timeout, but we don't yet support dropping the
36 ;;; client if it hasn't sent a request within a reasonable amount of time
37 ;;; yet still remains active. Perhaps that we could do that simply by
38 ;;; maintaining and checking time when input occurs...
39
40
41 (declaim (optimize (speed 3) (safety 1) (debug 3)))
42
43 (eval-when (:compile-toplevel :load-toplevel)
44 (require :sb-bsd-sockets)
45 (load "dlist"))
46
47
48 (defpackage :server
49 (:use :cl :sb-bsd-sockets :dlist)
50 (:export #:server-config
51 #:make-server-config
52 #:log-clear
53 #:log-tail
54 #:log-line
55 #:server-init
56 #:server-cleanup
57 #:server-stat
58 #:line-read
59 #:address-string
60 #:address-fixnum
61 #:server-time
62 #:server-time-posix
63 #:server-time-unix
64 #:server-time-rfc))
65
66 (in-package :server)
67
68
69 (defun noop (&rest args)
70 (declare (ignore args))
71 nil)
72
73
74 (defstruct (server-config (:conc-name config-))
75 (stacktrace t :type boolean)
76 (external-format :utf-8 :type symbol)
77 (listen-address "127.0.0.1" :type string)
78 (listen-port 7777 :type fixnum)
79 (log-lines 1000 :type fixnum)
80 (input-timeout 60 :type fixnum)
81 (children-initial 16 :type fixnum)
82 (children-minspare 16 :type fixnum)
83 (children-maxspare 16 :type fixnum)
84 (children-maximum 64 :type fixnum)
85 (children-avg-seconds 60 :type fixnum)
86 (conn-per-addr 8 :type fixnum)
87 (serve-function #'noop :type function)
88 (overflow-function #'noop :type function))
89
90 (defvar *config* nil)
91
92
93 ;;; Various utility functions
94
95 (defvar *time-lock* (mp:make-lock :name 'time-lock))
96
97 (defvar *time* (mp:with-lock (*time-lock*)
98 (get-universal-time)))
99
100 (defun server-time ()
101 "Returns the current universal time in seconds."
102 (let ((time (mp:with-lock (*time-lock*)
103 *time*)))
104 time))
105
106 (defun server-time-posix (&optional (ut (server-time)))
107 "Returns UTC time stamp.
108 UT may optionally be supplied if the current time is already known."
109 ; (declare (type integer ut))
110 (multiple-value-bind
111 (second minute hour date month year)
112 (decode-universal-time ut 0)
113 (format nil "~4,'0D~2,'0D~2,'0D~2,'0D~2,'0D~2,'0D-0000"
114 year month date hour minute second)))
115
116 (defun server-time-unix (&optional (ut (server-time)))
117 "Returns Unix timestamp from Epoch.
118 UT may optionally be supplied if the current time is already known."
119 (- ut 2208988800))
120
121 (defun server-time-rfc (&optional (unix-time nil))
122 "Returns RFC UTC time stamp.
123 UNIX-TIME may optionally be supplied if the current Unix timestamp is
124 already known."
125 ; (declare (type (or null integer) unix-time))
126 (let ((days #("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
127 (months #("Jan" "Feb" "Mar" "Apr" "May" "Jun"
128 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))
129 (declare (type (simple-array string (7)) days)
130 (type (simple-array string (12)) months))
131 (multiple-value-bind
132 (second minute hour date month year day)
133 (decode-universal-time (if unix-time
134 (+ 2208988800 unix-time)
135 (server-time))
136 0)
137 (format nil "~A, ~2,'0D ~A ~4,'0D ~2,'0D:~2,'0D:~2,'0D GMT"
138 (svref days day)
139 date (svref months (1- month)) year
140 hour minute second))))
141
142 (defun address-string (addr)
143 "Converts supplied ADDR 4-part integer vector to a string suitable for
144 representation of an IPv4 address."
145 (declare (type (simple-array t (4)) addr)
146 (optimize (speed 3) (safety 0) (debug 0)))
147 (format nil "~A.~A.~A.~A"
148 (svref addr 0) (svref addr 1) (svref addr 2) (svref addr 3)))
149
150 ;;; Macro to convert a multiple arguments operation into combined pairs,
151 ;;; which are more easily inlined to C.
152 (defmacro with-fixnum-reduce ((op) &rest args)
153 (reduce #'(lambda (a b)
154 `(the fixnum (,op (the fixnum ,a) (the fixnum ,b))))
155 args))
156
157 (defun address-fixnum (addr)
158 "Converts supplied ADDR 4-part integer vector to a FIXNUM integer
159 suitable for hashing."
160 (declare (optimize (speed 3) (safety 0) (debug 0))
161 (type (simple-array t (4)) addr))
162 (with-fixnum-reduce (logior)
163 (ash (the fixnum (svref addr 0)) 24)
164 (ash (the fixnum (svref addr 1)) 16)
165 (ash (the fixnum (svref addr 2)) 8)
166 (svref addr 3)))
167
168
169 ;;; Implementation of a simple thread-safe FIFO buffer with limited entries.
170
171 (defstruct fifo
172 (head '() :type list)
173 (tail '() :type list)
174 (count 0 :type fixnum)
175 (size 0 :type fixnum)
176 (lock (mp:make-lock :name 'fifo-lock) :type mp:lock))
177
178 (defun fifo-append (fifo object)
179 (declare (optimize (speed 3) (safety 0) (debug 0)))
180 (with-accessors ((head fifo-head) (tail fifo-tail)
181 (count fifo-count) (size fifo-size)
182 (lock fifo-lock)) fifo
183 (mp:with-lock (lock)
184 (if (= (the fixnum count) (the fixnum size))
185 (setf head (rest head))
186 (incf (the fixnum count)))
187 (let ((new (cons object nil)))
188 (if (null head)
189 (setf head new
190 tail new)
191 (setf (rest tail) new
192 tail new)))))
193 nil)
194
195 (defun fifo-clear (fifo)
196 (mp:with-lock ((fifo-lock fifo))
197 (let ((list '()))
198 (setf (fifo-head fifo) list
199 (fifo-tail fifo) list
200 (fifo-count fifo) 0)))
201 nil)
202
203
204 ;;; Simple memory log implementation using the above FIFO
205
206 (defvar *log-buffer* nil)
207
208 (defun log-line (fmt &rest args)
209 "Appends FORMAT-like results to the server log, prefixed with the current
210 time."
211 (let ((l (if (null args)
212 fmt
213 (apply #'format nil fmt args))))
214 (fifo-append *log-buffer* (format nil "~A ~A" (server-time-posix) l)))
215 nil)
216
217 (defun log-clear ()
218 "Clears the in-memory server log."
219 (fifo-clear *log-buffer*))
220
221 (defun log-tail ()
222 "Writes to *STANDARD-OUTPUT* the contents of the server log."
223 (loop
224 for line in (fifo-head *log-buffer*)
225 do
226 (write-string (format nil "~A~%" line))))
227
228 (defun log-connection (connect socket address port)
229 (log-line "! ~A: [~A:~A] #~A"
230 (if connect
231 "Connect "
232 "Disconnect")
233 (address-string address)
234 port
235 (socket-file-descriptor socket)))
236
237 (defun log-overflow (socket address port reason)
238 (log-line "* Overflow : [~A:~A] #~A (~A)"
239 (address-string address)
240 port
241 (socket-file-descriptor socket)
242 reason))
243
244 ;;; Note that DEBUG level must be at 3 for this to work.
245 (defun log-stacktrace ()
246 (let ((top (si:ihs-top))
247 (current si::*ihs-current*))
248 (with-output-to-string (s)
249 (format s " Stack trace:~%" current top)
250 ;; Substract LOG-STACKTRACE, LOG-ERROR and avoid printing the last
251 ;; node which is always NIL.
252 (loop
253 for i downfrom (- top 2) above current
254 do
255 (format s " in ~A~%"
256 (let ((f (si::ihs-fun i)))
257 (typecase f
258 (generic-function (clos:generic-function-name f))
259 (function (ext:compiled-function-name f))
260 (t f))))))))
261
262 (defun log-error (e)
263 (let ((trace (if (config-stacktrace *config*)
264 (log-stacktrace)
265 "")))
266 (log-line "# Error of type ~S: ~A~A"
267 (type-of e) e trace)))
268
269
270 ;;; Connection limits management
271
272 (defstruct climit
273 (connections 0 :type fixnum)
274 (table (make-hash-table :test 'eql) :type hash-table)
275 (max-total 64 :type fixnum)
276 (max-address 8 :type fixnum)
277 (lock (mp:make-lock :name 'climit-lock) :type mp:lock))
278
279 (defun climit-add (climit address)
280 (declare (optimize (speed 3) (safety 0) (debug 0))
281 (type fixnum address))
282 (with-accessors ((connections climit-connections)
283 (table climit-table)
284 (max-total climit-max-total)
285 (max-address climit-max-address)
286 (lock climit-lock)) climit
287 (mp:with-lock (lock)
288 (when (>= (the fixnum connections) (the fixnum max-total))
289 (return-from climit-add (values nil :max-total)))
290 (let ((node (gethash address table)))
291 (when (and node (>= (the fixnum (car node))
292 (the fixnum max-address)))
293 (return-from climit-add (values nil :max-address)))
294 (if node
295 (the fixnum (incf (the fixnum (car node))))
296 (setf (gethash address table) (cons 1 nil))))
297 (incf (the fixnum connections)))
298 (values t :success)))
299
300 (defun climit-remove (climit address)
301 (declare (optimize (speed 3) (safety 0) (debug 0))
302 (type fixnum address))
303 (with-accessors ((connections climit-connections)
304 (table climit-table)
305 (lock climit-lock)) climit
306 (mp:with-lock (lock)
307 (let ((node (gethash address table)))
308 (when (zerop (the fixnum (decf (the fixnum (car node)))))
309 (remhash address table)))
310 (decf (the fixnum connections)))
311 nil))
312
313
314 (defun bind-socket ()
315 (let ((server-socket (make-instance 'inet-socket
316 :type :stream
317 :protocol :tcp)))
318 ;;; XXX Do necessary setsockopt(2) calls which BSD inherits
319 (setf (sockopt-tcp-nodelay server-socket) t)
320 (socket-bind server-socket
321 (make-inet-address (config-listen-address *config*))
322 (config-listen-port *config*))
323 (socket-listen server-socket (config-children-maximum *config*))
324 server-socket))
325
326
327 ;;; System which allows the thread-manager thread and REPL commands to
328 ;;; to query the state of worker threads and manage them.
329 ;;; We insert one node per thread, which the thread is left a reference
330 ;;; to so it can update its state.
331 ;;; This also allows the parent thread to notify a thread that it should
332 ;;; quit but only when done serving its client (by setting the status to
333 ;;; :QUIT, in which case the child may set its status to :DEAD so the
334 ;;; thread-manager thread may free that object.
335
336 (defstruct thread-node
337 thread ; Thread object so parent may kill it
338 (status :init :type symbol) ; :init :ready :busy :quit :dead
339 (connections 0 :type integer))
340
341 ;;; Although children threads don't access this list directl (only their
342 ;;; own specific node object), the thread-manager thread as well as the
343 ;;; user REPL commands in SWANK may concurrently access it, so use a lock.
344 (defvar *threads-lock* (mp:make-lock :name 'threads-lock))
345 (defvar *threads-list* (make-dlist))
346 (defvar *thread-node* nil) ; Locally bound by threads
347
348 (defvar *manager-thread* nil)
349
350 (defvar *server-socket* -1)
351 (defvar *climit* nil)
352
353 (defun server-init (&optional (config (make-server-config)))
354 "Initialization function. CONFIG supplies an object of type SERVER-CONFIG
355 holding the wanted configuration. Binds the server socket and launches
356 server threads."
357 (check-type config server-config)
358 (setf *config* config)
359 #-:SWANK
360 (unless (eq (config-external-format *config*) :utf-8)
361 (setf (stream-external-format *standard-output*) '(:LATIN-1 :LF)))
362 (ext:catch-signal ext:+sigpipe+ :ignore)
363 (setf *server-socket* (bind-socket))
364 (setf *log-buffer* (make-fifo :size (config-log-lines *config*)))
365 (setf *climit* (make-climit :max-total (config-children-maximum *config*)
366 :max-address (config-conn-per-addr *config*)))
367 (setf *manager-thread*
368 (mp:process-run-function 'manager-thread #'children-manager-thread))
369 (mp:with-lock (*threads-lock*)
370 (loop
371 repeat (config-children-initial *config*)
372 do
373 (let* ((node (make-thread-node))
374 (n (dnode-alloc node))
375 (thread (mp:process-run-function 'accept-thread
376 #'accept-loop-thread
377 node)))
378 (setf (thread-node-thread node) thread)
379 (dlist-append *threads-list* n))))
380 t)
381
382 (defun server-cleanup ()
383 "Kills every thread and unbinds the server socket."
384 (handler-case
385 (progn
386 (mp:process-kill *manager-thread*)
387 (setf *manager-thread* nil))
388 (t ()))
389 (let ((threads-list *threads-list*))
390 (mp:with-lock (*threads-lock*)
391 (do-dlist (n threads-list)
392 (let ((node (dnode-object n)))
393 (handler-case
394 (progn
395 (mp:process-kill (thread-node-thread node))
396 (dlist-unlink threads-list n))
397 (t ()))))))
398 (log-clear)
399 (handler-case
400 (progn
401 (socket-close *server-socket*)
402 (setf *server-socket* -1))
403 (t ()))
404 t)
405
406
407 (defun server-stat ()
408 "Returns an alist with status on the server threads.
409 :TOTAL - The total number of current worker threads
410 :READY - The number of threads ready to serve a client
411 :BUSY - The number of threads currently busy serving clients
412 :DEAD - The number of tansient exiting threads
413 :CONNECTIONS - The total of the recorded number of connections recorded
414 for each thread. Note that when threads exit their number of
415 connections are lost and no longer accounted."
416 (let ((threads-list *threads-list*)
417 (dead 0)
418 (ready 0)
419 (busy 0)
420 (total 0)
421 (connections 0))
422 (declare (type fixnum dead ready busy total))
423 (mp:with-lock (*threads-lock*)
424 (do-dlist (n threads-list)
425 (let ((node (dnode-object n)))
426 (with-accessors ((status thread-node-status)) node
427 (incf total)
428 (incf connections (thread-node-connections node))
429 (cond ((eq :dead status)
430 (dlist-unlink threads-list n)
431 (incf dead))
432 ((eq :ready status)
433 (incf ready))
434 ((eq :busy status)
435 (incf busy)))))))
436 `(:total ,total
437 :ready ,ready
438 :busy ,busy
439 :dead ,dead
440 :connections ,connections)))
441
442
443 (defmacro with-log-errors (&body body)
444 (let ((s-block (intern (symbol-name (gensym "BLOCK")) :keyword)))
445 `(block ,s-block
446 (let ((*debugger-hook* #'(lambda (condition hook)
447 (declare (ignore hook))
448 (log-error condition)
449 (return-from ,s-block nil))))
450 ,@body))))
451
452
453 ;;; Automatic worker threads pool manager
454
455 (defvar *maximum-children-reached* nil)
456
457 (defvar *ready-avg* 0)
458 (defvar *ready-avg-cnt* 0)
459
460 (defun children-manager ()
461 (let* ((threads-list *threads-list*)
462 (dead 0)
463 (ready 0)
464 (busy 0)
465 (config *config*)
466 (children-minspare (config-children-minspare config))
467 (children-maxspare (config-children-maxspare config))
468 (children-maximum (config-children-maximum config))
469 (children-avg-seconds (config-children-avg-seconds config)))
470 (declare (type fixnum dead ready busy
471 children-minspare children-maxspare children-maximum
472 children-avg-seconds))
473 (mp:with-lock (*threads-lock*)
474 (let ((total (dlist-nodes threads-list)))
475 (declare (type fixnum total))
476 (do-dlist (n threads-list)
477 (let ((status (thread-node-status (dnode-object n))))
478 (cond ((eq :dead status)
479 (dlist-unlink threads-list n)
480 (incf dead))
481 ((eq :ready status)
482 (incf ready))
483 ((eq :busy status)
484 (incf busy)))))
485
486 ;; More children needed? Launch them now if allowed.
487 (when (< ready children-minspare)
488 (loop
489 repeat (the fixnum (- children-minspare ready))
490 while (< total children-maximum)
491 do
492 (let* ((node (make-thread-node))
493 (n (dnode-alloc node))
494 (thread (mp:process-run-function 'accept-thread
495 #'accept-loop-thread
496 node)))
497 (setf (thread-node-thread node) thread)
498 (dlist-append threads-list n)
499 (incf total)))
500 (when (and (not *maximum-children-reached*)
501 (= total children-maximum))
502 (setf *maximum-children-reached* t)
503 (log-line "* Maximum number of children reached (~A)" total)))
504
505 ;; Determine if we can safely kill children which are not in use
506 ;; since some time. To do this we maintain average statistics to
507 ;; avoid constantly spawning and killing threads.
508 ;; The average calculation is spread over children-avg-seconds
509 ;; (the number of samples).
510 (if (= *ready-avg-cnt* children-avg-seconds)
511 (progn
512 (setf *ready-avg* (floor (/ *ready-avg* *ready-avg-cnt*)))
513 (let ((overflow (- *ready-avg* children-maxspare)))
514 (when (plusp overflow)
515 (do-dlist (n threads-list)
516 (with-accessors ((status thread-node-status)
517 (thread thread-node-thread))
518 (dnode-object n)
519 (when (eq :ready status)
520 (setf status :quit)
521 (handler-case
522 (mp:process-kill thread)
523 (t ()))
524 (dlist-unlink threads-list n)))
525 (when (zerop (decf overflow))
526 (loop-finish)))))
527 (setf *ready-avg* 0
528 *ready-avg-cnt* 0))
529 (progn
530 (incf *ready-avg* ready)
531 (incf *ready-avg-cnt*))))))
532 t)
533
534 ;;; Since we'd need something like setitimer(2), and that we want to
535 ;;; leave the main thread free for interactive REPL and optionally SWANK,
536 ;;; let's simply use a thread for the children threads pool manager.
537 ;;; We also use this thread to update the current time which user code
538 ;;; may want to use to observe timeouts, and which we use to optimize
539 ;;; logging.
540 (defun children-manager-thread ()
541 (let ((*ready-avg* 0)
542 (*ready-avg-count* 0))
543 (loop
544 do
545 (with-log-errors
546 (sleep 1)
547 (let ((time (get-universal-time)))
548 (mp:with-lock (*time-lock*)
549 (setf *time* time)))
550 (children-manager))))
551 nil)
552
553
554 ;;; Makes sure that supplied SOCKET gets closed, that Connect/Disconnect
555 ;;; log entries always exist and match, and that status matches.
556 (defmacro with-socket ((socket address port) &body body)
557 (let ((s-socket (gensym))
558 (s-address (gensym))
559 (s-port (gensym)))
560 `(let ((,s-socket ,socket)
561 (,s-address ,address)
562 (,s-port ,port))
563 (with-accessors ((status thread-node-status)
564 (connections thread-node-connections)) *thread-node*
565 (unwind-protect
566 (progn
567 (incf connections)
568 (when (eq :ready status)
569 (setf status :busy))
570 (log-connection t ,s-socket ,s-address ,s-port)
571 ,@body)
572 (log-connection nil ,s-socket ,s-address ,s-port)
573 (when (eq :busy status)
574 (setf status :ready))
575 (handler-case
576 (socket-close ,s-socket)
577 (t (e)
578 nil)))))))
579
580 ;;; Makes sure to close supplied STREAM.
581 (defmacro with-stream ((stream) &body body)
582 (let ((s-stream (gensym)))
583 `(let ((,s-stream ,stream))
584 (unwind-protect
585 (progn
586 ,@body)
587 (handler-case
588 (close ,s-stream)
589 (t (e)
590 nil))))))
591
592 ;;; Makes sure to match successful CLIMIT-ADD calls with CLIMIT-REMOVE ones.
593 (defmacro with-climit ((climit-var allowed-p-var reason-var address-int-var)
594 &body body)
595 `(multiple-value-bind (,allowed-p-var ,reason-var)
596 (climit-add ,climit-var ,address-int-var)
597 (unwind-protect
598 (progn
599 ,@body)
600 (when ,allowed-p-var
601 (climit-remove ,climit-var ,address-int-var)))))
602
603
604 ;;; The main loop of our worker threads. Accepts and serves connections
605 ;;; until told to exit or killed. On OSs where this is necessary, uses
606 ;;; *ACCEPT-LOCK* so that one thread at most is actually accept(3)-blocking
607 ;;; on the file descriptor, while other threads block waiting for the lock
608 ;;; to become available.
609
610 #-netbsd(defvar *accept-lock* (mp:make-lock :name 'accept-lock))
611
612 (defun accept-loop-thread (node)
613 (setf (thread-node-status node) :ready)
614 (loop
615 with config = *config*
616 with *thread-node* = node
617 with timeout of-type fixnum = (config-input-timeout config)
618 with external-format = (config-external-format config)
619 with serve-function = (config-serve-function config)
620 with overflow-function = (config-overflow-function config)
621 with climit = *climit*
622 until (eq :quit (thread-node-status node))
623 do
624 (with-log-errors
625 (multiple-value-bind (socket address port)
626 #-netbsd(mp:with-lock (*accept-lock*)
627 (socket-accept *server-socket*))
628 #+netbsd(socket-accept *server-socket*)
629 (with-socket (socket address port)
630 (setf (sockopt-keep-alive socket) t
631 (sockopt-receive-timeout socket) timeout)
632 (let ((client-stream
633 (socket-make-stream socket
634 :input t
635 :output t
636 :buffering :full
637 :external-format external-format))
638 (address-int (address-fixnum address)))
639 (with-stream (client-stream)
640 (with-climit (climit allowed-p reason address-int)
641 (if allowed-p
642 (funcall serve-function client-stream address port)
643 (progn
644 (log-overflow socket address port reason)
645 (funcall overflow-function client-stream
646 address port reason))))))))))
647 (setf (thread-node-status node) :dead)
648 nil)
649
650
651 (defun line-read (stream)
652 "Reads a text line from STREAM. Lines are expected to be terminated
653 using NewLine (\n), and any trailing NewLine-Return (\r\n) are not
654 provided as part of the returned line string.
655 If the EXTERNAL-FORMAT is UTF-8 and an invalid UTF-8 input sequence
656 is encountered, invalid octets will be imported as LATIN-1 characters,
657 in which case output will not preserve the original bytes.
658 To obtain literal bytes, use the LATIN-1 EXTERNAL-FORMAT."
659 (let ((line (make-array 512
660 :element-type 'character
661 :adjustable nil
662 :fill-pointer 0)))
663 (macrolet ((add-char (c)
664 `(vector-push ,c line)))
665 (loop
666 do
667 (let ((c (handler-bind
668 ((ext:stream-decoding-error
669 #'(lambda (e)
670 (mapc #'(lambda (o)
671 (let ((c (code-char o)))
672 (if (char= #\Newline c)
673 (invoke-restart 'use-value c)
674 (add-char c))))
675 (ext:character-decoding-error-octets e))
676 (invoke-restart 'continue)))
677 (simple-error
678 #'(lambda (e)
679 (declare (ignore e))
680 (error (make-condition 'end-of-file
681 :stream stream)))))
682 (read-char stream))))
683 (declare (type character c))
684 ;; Terminate loop and return LINE upon \n
685 (when (char= #\Newline c)
686 (handler-case
687 (loop
688 for c of-type character = (vector-pop line)
689 while (member c '(#\Return #\Newline))
690 finally (add-char c))
691 (simple-error () ; VECTOR-POP may error when string empty
692 nil))
693 (return line))
694 (add-char c))))))