1 /*
2 * port.c - port implementation
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
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 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/class.h"
37 #include "gauche/priv/portP.h"
38 #include "gauche/priv/builtin-syms.h"
39
40 #include <string.h>
41 #include <fcntl.h>
42 #include <errno.h>
43 #include <ctype.h>
44
45 #undef MAX
46 #undef MIN
47 #define MAX(a, b) ((a)>(b)? (a) : (b))
48 #define MIN(a, b) ((a)<(b)? (a) : (b))
49
50 #define PORT_BUFFER_MODE(p) \
51 (PORT_BUF(p)->mode & SCM_PORT_BUFFER_MODE_MASK)
52 #define PORT_BUFFER_SIGPIPE_SENSITIVE_P(p) \
53 (PORT_BUF(p)->mode & SCM_PORT_BUFFER_SIGPIPE_SENSITIVE)
54 #define PORT_BUFFER_ROOM(p) \
55 (PORT_BUF(p)->buffer + PORT_BUF(p)->size - PORT_BUF(p)->end)
56 #define PORT_BUFFER_AVAIL(p) \
57 (PORT_BUF(p)->current - PORT_BUF(p)->buffer)
58
59 #define PORT_UNGOTTEN(p) (P_(p)->ungotten)
60 #define PORT_SCRATCH(p) (P_(p)->scratch)
61 #define PORT_LINE(p) (P_(p)->line)
62 #define PORT_BYTES(p) (P_(p)->bytes)
63 #define PORT_ATTRS(p) (P_(p)->attrs)
64 #define PORT_SAVED_POS(p) (P_(p)->savedPos)
65
66 /* Parameter location for the global reader lexical mode, from which
67 ports inherit. */
68 static ScmPrimitiveParameter *readerLexicalMode;
69
70 /*================================================================
71 * Class stuff
72 */
73
74 static void port_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx);
75 static void port_finalize(ScmObj obj, void* data);
76 static void register_buffered_port(ScmPort *port);
77 static void unregister_buffered_port(ScmPort *port);
78 static void bufport_flush(ScmPort*, ScmSize, int);
79 static void file_closer(ScmPort *p);
80 static int file_buffered_port_p(ScmPort *p); /* for Scm_PortFdDup */
81 static void file_buffered_port_set_fd(ScmPort *p, int fd); /* ditto */
82
get_port_name(ScmPort * port)83 static ScmObj get_port_name(ScmPort *port)
84 {
85 return Scm_PortName(port);
86 }
87
get_port_current_line(ScmPort * port)88 static ScmObj get_port_current_line(ScmPort *port)
89 {
90 return SCM_MAKE_INT(Scm_PortLine(port));
91 }
92
get_port_buffering(ScmPort * port)93 static ScmObj get_port_buffering(ScmPort *port)
94 {
95 return Scm_GetPortBufferingModeAsKeyword(port);
96 }
97
set_port_buffering(ScmPort * port,ScmObj val)98 static void set_port_buffering(ScmPort *port, ScmObj val)
99 {
100 if (SCM_PORT_TYPE(port) != SCM_PORT_FILE) {
101 Scm_Error("can't set buffering mode to non-buffered port: %S", port);
102 }
103 Scm_SetPortBufferingMode(port,Scm_BufferingMode(val,port->direction,-1));
104 }
105
get_port_sigpipe_sensitive(ScmPort * port)106 static ScmObj get_port_sigpipe_sensitive(ScmPort *port)
107 {
108 return SCM_MAKE_BOOL(Scm_GetPortBufferSigpipeSensitive(port));
109 }
110
set_port_sigpipe_sensitive(ScmPort * port,ScmObj val)111 static void set_port_sigpipe_sensitive(ScmPort *port, ScmObj val)
112 {
113 Scm_SetPortBufferSigpipeSensitive(port, SCM_BOOL_VALUE(val));
114 }
115
116 static ScmClassStaticSlotSpec port_slots[] = {
117 SCM_CLASS_SLOT_SPEC("name", get_port_name, NULL),
118 SCM_CLASS_SLOT_SPEC("buffering", get_port_buffering,
119 set_port_buffering),
120 SCM_CLASS_SLOT_SPEC("sigpipe-sensitive?", get_port_sigpipe_sensitive,
121 set_port_sigpipe_sensitive),
122 SCM_CLASS_SLOT_SPEC("current-line", get_port_current_line, NULL),
123 SCM_CLASS_SLOT_SPEC_END()
124 };
125
126 SCM_DEFINE_BASE_CLASS(Scm_PortClass,
127 ScmPort, /* instance type */
128 port_print, NULL, NULL, NULL, NULL);
129
130 static ScmClass *port_cpl[] = {
131 SCM_CLASS_STATIC_PTR(Scm_PortClass),
132 SCM_CLASS_STATIC_PTR(Scm_TopClass),
133 NULL
134 };
135
136 SCM_DEFINE_BASE_CLASS(Scm_CodingAwarePortClass,
137 ScmPort, /* instance type */
138 port_print, NULL, NULL, NULL, port_cpl);
139
140 /*================================================================
141 * Common
142 */
143
144 /* Cleaning up:
145 * The underlying file descriptor/stream may be closed when the port
146 * is explicitly closed by close-port, or implicitly destroyed by the
147 * garbage collector. To keep consistency, Scheme ports should never
148 * share the same file descriptor. However, C code and Scheme port
149 * may share the same file descriptor for efficiency (e.g. stdios).
150 * In such cases, it is C code's responsibility to destroy the port.
151 */
port_cleanup(ScmPort * port)152 static void port_cleanup(ScmPort *port)
153 {
154 if (SCM_PORT_CLOSED_P(port)) return;
155
156 /* NB: Flush or close subroutine may raise an error and leave the port
157 not fully cleaned up. For now, we leave the port 'non-closed' state,
158 so this part may be called again---it's up to the close routine to
159 handle the situation gracefully.
160 */
161 switch (SCM_PORT_TYPE(port)) {
162 case SCM_PORT_FILE:
163 if (SCM_PORT_DIR(port) == SCM_PORT_OUTPUT) {
164 if (!SCM_PORT_ERROR_OCCURRED_P(port)) {
165 bufport_flush(port, 0, TRUE);
166 }
167 if (!(SCM_PORT_FLAGS(port) & SCM_PORT_TRANSIENT)) {
168 unregister_buffered_port(port);
169 }
170 }
171 ScmPortBuffer *buf = Scm_PortBufferStruct(port);
172 if (port->ownerp && buf->closer) buf->closer(port);
173 break;
174 case SCM_PORT_PROC:
175 if (PORT_VT(port)->Close) PORT_VT(port)->Close(port);
176 break;
177 default:
178 break;
179 }
180 (void)SCM_INTERNAL_FASTLOCK_DESTROY(P_(port)->lock);
181
182 SCM_PORT_CLOSED_P(port) = TRUE;
183 /* avoid unnecessary finalization */
184 Scm_UnregisterFinalizer(SCM_OBJ(port));
185 }
186
187 /* called by GC */
port_finalize(ScmObj obj,void * data SCM_UNUSED)188 static void port_finalize(ScmObj obj, void* data SCM_UNUSED)
189 {
190 port_cleanup(SCM_PORT(obj));
191 }
192
193 /*
194 * Internal Constructor.
195 * If this port owns the underlying file descriptor/stream,
196 * ownerp must be TRUE.
197 */
make_port(ScmClass * klass,ScmObj name,int dir,int type)198 static ScmPort *make_port(ScmClass *klass, ScmObj name, int dir, int type)
199 {
200 ScmPortImpl *port = (ScmPortImpl*)SCM_NEW_INSTANCE(ScmPort, klass);
201
202 port->direction = dir & SCM_PORT_IOMASK;
203 port->type = type;
204 port->scrcnt = 0;
205 port->ungotten = SCM_CHAR_INVALID;
206 port->closed = FALSE;
207 port->error = FALSE;
208 port->ownerp = FALSE;
209 port->flags =
210 SCM_VM_RUNTIME_FLAG_IS_SET(Scm_VM(), SCM_CASE_FOLD)
211 ? SCM_PORT_CASE_FOLD
212 : 0;
213 port->savedPos = SCM_UNBOUND;
214 (void)SCM_INTERNAL_FASTLOCK_INIT(port->lock);
215 port->lockOwner = NULL;
216 port->lockCount = 0;
217 port->writeState = NULL;
218 port->line = 1;
219 /* We set name attribute as read-only attribute. See portapi.c
220 for the format of attrs. */
221 port->attrs = SCM_LIST1(Scm_Cons(SCM_SYM_NAME, Scm_Cons(name, SCM_FALSE)));
222
223 Scm_RegisterFinalizer(SCM_OBJ(port), port_finalize, NULL);
224
225 /* Default reader lexical mode */
226 Scm_PortAttrSetUnsafe(SCM_PORT(port),
227 SCM_SYM_READER_LEXICAL_MODE,
228 Scm_ReaderLexicalMode());
229
230 return SCM_PORT(port);
231 }
232
233 /*
234 * Close
235 */
Scm_ClosePort(ScmPort * port)236 void Scm_ClosePort(ScmPort *port)
237 {
238 ScmVM *vm = Scm_VM();
239 PORT_LOCK(port, vm);
240 PORT_SAFE_CALL(port,
241 do {
242 if (!SCM_PORT_CLOSED_P(port)) {
243 port_cleanup(port);
244 }
245 } while (0), /*no cleanup*/);
246 PORT_UNLOCK(port);
247 }
248
249 /*===============================================================
250 * Locking ports
251 */
252
253 /* OBSOLETED */
254 /* C routines can use PORT_SAFE_CALL, so we reimplemented this in libio.scm.
255 Kept here for ABI compatibility; will be gone by 1.0. */
Scm_VMWithPortLocking(ScmPort * port SCM_UNUSED,ScmObj closure)256 ScmObj Scm_VMWithPortLocking(ScmPort *port SCM_UNUSED, ScmObj closure)
257 {
258 static ScmObj with_port_locking_proc = SCM_UNDEFINED;
259 SCM_BIND_PROC(with_port_locking_proc, "with-port-locking",
260 Scm_GaucheModule());
261 return Scm_ApplyRec1(with_port_locking_proc, closure);
262 }
263
264 /*===============================================================
265 * Getting information
266 * NB: Port attribute access API is in portapi.c
267 */
268
Scm_PortName(ScmPort * port)269 ScmObj Scm_PortName(ScmPort *port)
270 {
271 return Scm_PortAttrGet(port, SCM_SYM_NAME, SCM_FALSE);
272 }
273
Scm_PortLine(ScmPort * port)274 ScmSize Scm_PortLine(ScmPort *port)
275 {
276 return PORT_LINE(port);
277 }
278
Scm_PortBytes(ScmPort * port)279 ScmSize Scm_PortBytes(ScmPort *port)
280 {
281 return PORT_BYTES(port);
282 }
283
port_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)284 static void port_print(ScmObj obj, ScmPort *port,
285 ScmWriteContext *ctx SCM_UNUSED)
286 {
287 Scm_Printf(port, "#<%s%sport%s %A %p>",
288 (SCM_PORT_DIR(obj)&SCM_PORT_INPUT)? "i" : "",
289 (SCM_PORT_DIR(obj)&SCM_PORT_OUTPUT)? "o" : "",
290 SCM_PORT_CLOSED_P(obj)? "(closed)" : "",
291 Scm_PortName(SCM_PORT(obj)),
292 obj);
293 }
294
295 /* Returns port's associated file descriptor number, if any.
296 Returns -1 otherwise. */
Scm_PortFileNo(ScmPort * port)297 int Scm_PortFileNo(ScmPort *port)
298 {
299 if (SCM_PORT_TYPE(port) == SCM_PORT_FILE) {
300 ScmPortBuffer *buf = Scm_PortBufferStruct(port);
301 if (buf->filenum) return buf->filenum(port);
302 else return -1;
303 } else {
304 /* TODO: proc port */
305 return -1;
306 }
307 }
308
309 /* Returns a pointer to the 'src' strcuture. User code should use this
310 * instead of directly referring to 'src' member.
311 */
Scm_PortBufferStruct(ScmPort * port)312 ScmPortBuffer *Scm_PortBufferStruct(ScmPort *port)
313 {
314 SCM_ASSERT(port->type == SCM_PORT_FILE);
315 return PORT_BUF(port);
316 }
317
Scm_PortInputStringStruct(ScmPort * port)318 ScmPortInputString *Scm_PortInputStringStruct(ScmPort *port)
319 {
320 SCM_ASSERT(port->type == SCM_PORT_ISTR);
321 return PORT_ISTR(port);
322 }
323
Scm_PortOutputDString(ScmPort * port)324 ScmDString *Scm_PortOutputDString(ScmPort *port)
325 {
326 SCM_ASSERT(port->type == SCM_PORT_OSTR);
327 return PORT_OSTR(port);
328 }
329
Scm_PortVTableStruct(ScmPort * port)330 ScmPortVTable *Scm_PortVTableStruct(ScmPort *port)
331 {
332 SCM_ASSERT(port->type == SCM_PORT_PROC);
333 return PORT_VT(port);
334 }
335
336 /* For input buffered port, returns the size of room that can be filled
337 by the filler */
Scm_PortBufferRoom(ScmPort * port)338 ScmSize Scm_PortBufferRoom(ScmPort *port)
339 {
340 SCM_ASSERT(port->type == SCM_PORT_FILE);
341 return PORT_BUFFER_ROOM(port);
342 }
343
344 /* For output buffered port, returns the size of available data that can
345 be flushed by the flusher */
Scm_PortBufferAvail(ScmPort * port)346 ScmSize Scm_PortBufferAvail(ScmPort *port)
347 {
348 SCM_ASSERT(port->type == SCM_PORT_FILE);
349 return PORT_BUFFER_AVAIL(port);
350 }
351
Scm_PortWriteState(ScmPort * port)352 ScmWriteState *Scm_PortWriteState(ScmPort *port)
353 {
354 return P_(port)->writeState;
355 }
356
Scm_PortWriteStateSet(ScmPort * port,ScmWriteState * ws)357 void Scm_PortWriteStateSet(ScmPort *port, ScmWriteState *ws)
358 {
359 P_(port)->writeState = ws;
360 }
361
Scm_GetPortBufferingMode(ScmPort * port)362 int Scm_GetPortBufferingMode(ScmPort *port)
363 {
364 if (port->type == SCM_PORT_FILE) return PORT_BUFFER_MODE(port);
365 else return SCM_PORT_BUFFER_NONE;
366 }
367
Scm_SetPortBufferingMode(ScmPort * port,int mode)368 void Scm_SetPortBufferingMode(ScmPort *port, int mode)
369 {
370 if (port->type != SCM_PORT_FILE) {
371 Scm_Error("Can't set buffering mode to non-buffered port: %S", port);
372 }
373 PORT_BUF(port)->mode =
374 (PORT_BUF(port)->mode & ~SCM_PORT_BUFFER_MODE_MASK)
375 | (mode & SCM_PORT_BUFFER_MODE_MASK);
376 }
377
Scm_GetPortBufferSigpipeSensitive(ScmPort * port)378 int Scm_GetPortBufferSigpipeSensitive(ScmPort *port)
379 {
380 if (port->type == SCM_PORT_FILE) {
381 return (PORT_BUFFER_SIGPIPE_SENSITIVE_P(port) != FALSE);
382 } else {
383 return FALSE;
384 }
385 }
386
Scm_SetPortBufferSigpipeSensitive(ScmPort * port,int sensitive)387 void Scm_SetPortBufferSigpipeSensitive(ScmPort *port, int sensitive)
388 {
389 if (port->type != SCM_PORT_FILE) {
390 Scm_Error("Can't set sigpipe sensitivity to non-buffered port: %S",
391 port);
392 }
393 if (sensitive) {
394 PORT_BUF(port)->mode |= SCM_PORT_BUFFER_SIGPIPE_SENSITIVE;
395 } else {
396 PORT_BUF(port)->mode &= ~SCM_PORT_BUFFER_SIGPIPE_SENSITIVE;
397 }
398 }
399
400 /* Port case folding mode is usually set at port creation, according
401 to the VM's case folding mode. In rare occasion we need to switch
402 it (but it's not generally recommended). */
Scm_GetPortCaseFolding(ScmPort * port)403 int Scm_GetPortCaseFolding(ScmPort *port)
404 {
405 return (SCM_PORT_CASE_FOLDING(port) != FALSE);
406 }
407
Scm_SetPortCaseFolding(ScmPort * port,int folding)408 void Scm_SetPortCaseFolding(ScmPort *port, int folding)
409 {
410 if (folding) {
411 SCM_PORT_FLAGS(port) |= SCM_PORT_CASE_FOLD;
412 } else {
413 SCM_PORT_FLAGS(port) &= ~SCM_PORT_CASE_FOLD;
414 }
415 }
416
417 /* Port's reader lexical mode is set at port creation, taken from
418 readerLexicalMode parameter. It may be altered by reader directive
419 such as #!r7rs.
420 The possible value is the same as the global reader lexical mode,
421 i.e. one of the symbols legacy, warn-legacy, permissive or strict-r7.
422 */
Scm_GetPortReaderLexicalMode(ScmPort * port)423 ScmObj Scm_GetPortReaderLexicalMode(ScmPort *port)
424 {
425 /* We let it throw an error if there's no reader-lexical-mode attr.
426 It must be set in the constructor. */
427 return Scm_PortAttrGet(port, SCM_SYM_READER_LEXICAL_MODE, SCM_UNBOUND);
428 }
429
Scm_SetPortReaderLexicalMode(ScmPort * port,ScmObj mode)430 void Scm_SetPortReaderLexicalMode(ScmPort *port, ScmObj mode)
431 {
432 /*The check is duplicatd in Scm_SetReaderLexicalMode; refactoring needed.*/
433 if (!(SCM_EQ(mode, SCM_SYM_LEGACY)
434 || SCM_EQ(mode, SCM_SYM_WARN_LEGACY)
435 || SCM_EQ(mode, SCM_SYM_PERMISSIVE)
436 || SCM_EQ(mode, SCM_SYM_STRICT_R7))) {
437 Scm_Error("reader-lexical-mode must be one of the following symbols:"
438 " legacy, warn-legacy, permissive, strict-r7, but got %S",
439 mode);
440 }
441 Scm_PortAttrSet(port, SCM_SYM_READER_LEXICAL_MODE, mode);
442 }
443
444 /* global reader lexical mode. */
Scm_SetReaderLexicalMode(ScmObj mode)445 ScmObj Scm_SetReaderLexicalMode(ScmObj mode)
446 {
447 if (!(SCM_EQ(mode, SCM_SYM_LEGACY)
448 || SCM_EQ(mode, SCM_SYM_WARN_LEGACY)
449 || SCM_EQ(mode, SCM_SYM_PERMISSIVE)
450 || SCM_EQ(mode, SCM_SYM_STRICT_R7))) {
451 Scm_Error("reader-lexical-mode must be one of the following symbols:"
452 " legacy, warn-legacy, permissive, strict-r7, but got %S",
453 mode);
454 }
455 return Scm_PrimitiveParameterSet(Scm_VM(), readerLexicalMode, mode);
456 }
457
Scm_ReaderLexicalMode()458 ScmObj Scm_ReaderLexicalMode()
459 {
460 return Scm_PrimitiveParameterRef(Scm_VM(), readerLexicalMode);
461 }
462
463 /* flag can be checked with SCM_PORT_ERROR_OCCURRED_P() */
Scm_SetPortErrorOccurred(ScmPort * port,int flag)464 void Scm_SetPortErrorOccurred(ScmPort *port, int flag)
465 {
466 port->error = flag;
467 }
468
469 /* Query whether the port is positoinable. If setp is false, returns
470 if port can get current pos. If setp is true, returns if port
471 can set pos.
472 Note: For the buffering and procedural ports, if the user used old
473 protocol (using seeker), we can't exactly know if get/set position
474 is possible or not.
475 */
Scm_PortPositionable(ScmPort * port,int setp)476 int Scm_PortPositionable(ScmPort *port, int setp)
477 {
478 switch (SCM_PORT_TYPE(port)) {
479 case SCM_PORT_FILE:
480 if (setp) {
481 return (PORT_BUF(port)->setpos || PORT_BUF(port)->seeker);
482 } else {
483 return (PORT_BUF(port)->getpos || PORT_BUF(port)->seeker);
484 }
485 case SCM_PORT_PROC:
486 if (setp) {
487 return (PORT_VT(port)->SetPos || PORT_VT(port)->Seek);
488 } else {
489 return (PORT_VT(port)->GetPos || PORT_VT(port)->Seek);
490 }
491 case SCM_PORT_ISTR:
492 return TRUE;
493 case SCM_PORT_OSTR:
494 if (setp) return FALSE; /* we haven't supported setpos for ostr */
495 else return TRUE;
496 }
497 return FALSE; /* dummy */
498 }
499
500 /* Duplicates the file descriptor of the source port, and set it to
501 the destination port. Both source and destination port must be
502 file ports.
503 DST also must be a file buffered port, for we rewrite the fd slot
504 in its private data structure. */
Scm_PortFdDup(ScmPort * dst,ScmPort * src)505 void Scm_PortFdDup(ScmPort *dst, ScmPort *src)
506 {
507 int r;
508
509 if (SCM_PORT_TYPE(dst) != SCM_PORT_FILE)
510 Scm_Error("file port required, but got %S", dst);
511 if (SCM_PORT_TYPE(src) != SCM_PORT_FILE)
512 Scm_Error("file port required, but got %S", src);
513 if (src->direction != dst->direction)
514 Scm_Error("port direction mismatch: got %S and %S",
515 src, dst);
516
517 int srcfd = Scm_PortFileNo(src);
518 int dstfd = Scm_PortFileNo(dst);
519
520 if (srcfd < 0) Scm_Error("port isn't associated to fd: %S", src);
521 if (dstfd < 0) Scm_Error("port isn't associated to fd: %S", dst);
522
523 if (!file_buffered_port_p(dst)) {
524 Scm_Error("port isn't directly associated to file: %S", dst);
525 }
526
527 if (dst->direction == SCM_PORT_INPUT) {
528 /* discard the current buffer */
529 ScmVM *vm = Scm_VM();
530 PORT_LOCK(dst, vm);
531 PORT_BUF(dst)->current = PORT_BUF(dst)->buffer;
532 PORT_BUF(dst)->end = PORT_BUF(dst)->buffer;
533 PORT_UNLOCK(dst);
534 } else {
535 /* flush the current buffer */
536 Scm_Flush(dst);
537 }
538 /* NB: We don't retry dup2(). By the time it returns EINTR, the
539 dstfd has actually been closed, and if other thread happens to
540 grab the same fd, retrying dup2() inadvertently closes that one.
541 */
542
543 #if defined(GAUCHE_WINDOWS)
544 r = _dup2(srcfd, dstfd);
545 #else /*!GAUCHE_WINDOWS*/
546 r = dup2(srcfd, dstfd);
547 #endif /*!GAUCHE_WINDOWS*/
548 if (r < 0) Scm_SysError("dup2 failed");
549 file_buffered_port_set_fd(dst, r);
550 }
551
552 /* Low-level function to find if the file descriptor is ready or not.
553 DIR specifies SCM_PORT_INPUT or SCM_PORT_OUTPUT.
554 If the system doesn't have select(), this function returns
555 SCM_FD_UNKNOWN. */
Scm_FdReady(int fd,int dir)556 int Scm_FdReady(int fd, int dir)
557 {
558 #if defined(HAVE_SELECT) && !defined(GAUCHE_WINDOWS)
559 fd_set fds;
560 int r;
561 struct timeval tm;
562
563 /* In case if this is called on non-file ports.*/
564 if (fd < 0) return SCM_FD_READY;
565 if (fd >= FD_SETSIZE) Scm_Error("Scm_FdReady: fd out of range: %d", fd);
566
567 FD_ZERO(&fds);
568 FD_SET(fd, &fds);
569 tm.tv_sec = tm.tv_usec = 0;
570 if (dir == SCM_PORT_OUTPUT) {
571 SCM_SYSCALL(r, select(fd+1, NULL, &fds, NULL, &tm));
572 } else {
573 SCM_SYSCALL(r, select(fd+1, &fds, NULL, NULL, &tm));
574 }
575 if (r < 0) Scm_SysError("select failed");
576 if (r > 0) return SCM_FD_READY;
577 else return SCM_FD_WOULDBLOCK;
578 #elif defined(GAUCHE_WINDOWS)
579 /* Windows have select(), but it can only be used on sockets.*/
580 if (dir == SCM_PORT_OUTPUT) {
581 /* We assume it is always ok */
582 return SCM_FD_READY;
583 } else {
584 HANDLE h = (HANDLE)_get_osfhandle(fd);
585 if (h == INVALID_HANDLE_VALUE) return SCM_FD_READY;
586
587 /* pipe */
588 DWORD avail;
589 if (PeekNamedPipe(h, NULL, 0, NULL, &avail, NULL) != 0) {
590 if (avail == 0) return SCM_FD_WOULDBLOCK;
591 else return SCM_FD_READY;
592 }
593
594 /* socket */
595 int optval;
596 int optlen;
597 optlen = sizeof(optval);
598 if (getsockopt((SOCKET)h, SOL_SOCKET, SO_TYPE, (char*)&optval, &optlen) != SOCKET_ERROR) {
599 fd_set fds;
600 int r;
601 struct timeval tm;
602 FD_ZERO(&fds);
603 FD_SET((SOCKET)h, &fds);
604 tm.tv_sec = tm.tv_usec = 0;
605 /* NB: The first argument of select() is ignored on Windows */
606 SCM_SYSCALL(r, select(0, &fds, NULL, NULL, &tm));
607 if (r < 0) Scm_SysError("select failed");
608 if (r > 0) return SCM_FD_READY;
609 else return SCM_FD_WOULDBLOCK;
610 }
611
612 /* other */
613 return SCM_FD_UNKNOWN;
614 }
615 #else /*!HAVE_SELECT && !GAUCHE_WINDOWS */
616 return SCM_FD_UNKNOWN;
617 #endif /*!HAVE_SELECT && !GAUCHE_WINDOWS */
618 }
619
620 /*===============================================================
621 * buffered Port
622 * - mainly used for buffered file I/O, but can also be used
623 * for other purpose, like character-code conversion port.
624 */
625
626 /* [Buffered port protocol]
627 *
628 * Legends
629 * b = port->src.buf.buffer
630 * c = port->src.buf.current
631 * e = port->src.buf.end
632 * '*' = valid data
633 * '-' = invalid data
634 *
635 * Output
636 *
637 * When used as output, the end pointer always points one byte past
638 * the buffer. Initially the buffer is empty and the current pointer
639 * is the same as the beginning of the buffer.
640 *
641 * port->src.buf.flusher(ScmPort* p, int cnt, int forcep) is called when
642 * the port needs to create some room in the buffer. When the flusher
643 * is called, the buffer is like this:
644 *
645 * <--------------- size ---------------->
646 * |*********************************-----|
647 * ^ ^ ^
648 * b c e
649 *
650 * The flusher is supposed to output the cnt bytes of data beginning from
651 * the buffer, which is usually up to the current pointer (but the flusher
652 * doesn't need to check the current pointer; it is taken care of by the
653 * caller of the flusher).
654 *
655 * If the third argument forcep is false, the flusher may return before
656 * entire data is output, in case like underlying device is busy.
657 * The flusher must output at least one byte even in that case.
658 * On the other hand, if the forcep argument is true, the flusher must
659 * write cnt bytes; if it is not possible, the flusher must return -1 to
660 * indicate an error(*1).
661 *
662 * The flusher returns the number of bytes actually written out.
663 * If an error occurs, the flusher must return -1.
664 *
665 * The flusher must be aware that the port p is locked by the current
666 * thread when called.
667 *
668 * The flusher shouldn't change the buffer's internal state.
669 *
670 * After the flusher returns, bufport_flush shifts the unflushed data
671 * (if any), so the buffer becomes like this:
672 *
673 * <--------------- size ---------------->
674 * |****----------------------------------|
675 * ^ ^ ^
676 * b c e
677 *
678 * (*1) Why should these two modes need to be distinguished? Suppose
679 * you implement a buffered port that does character encoding conversion.
680 * The flusher converts the content of the buffer to different character
681 * encoding and feed it to some specified port. It is often the case
682 * that you find a few bytes at the end of the buffer which you can't
683 * convert into a whole character but have to wait for next byte(s).
684 * It is valid that you leave them in the buffer if you can expect
685 * more data to come. However, if you know it is really the end of
686 * the stream, you can't leave any data in the buffer and you should
687 * take appropriate action, for example, raising an error.
688 *
689 * Input
690 *
691 * When used as input, the end pointer points to one byte past the
692 * end of the valid data, which may be before the end of the buffer.
693 *
694 * port->src.buf.filler(ScmPort *p, int cnt) is called when the buffer
695 * doesn't have enough data to read. Suppose the input routine detects
696 * the buffer doesn't have enough data when it looks like this:
697 *
698 * <--------------- size ---------------->
699 * |-----------------------------****-----|
700 * ^ ^ ^
701 * b c e
702 *
703 * First, bufport_fill shifts the unread data (if any) to the beginning
704 * of the buffer, so it becomes like this:
705 *
706 * <--------------- size ---------------->
707 * |****----------------------------------|
708 * ^ ^
709 * bc e
710 *
711 * Then port->src.buf.filler is called. It is supposed to read as many
712 * bytes as cnt, putting them after the end pointer. The filler doesn't
713 * need to modify the end pointer; it is taken care of after the filler
714 * returns.
715 *
716 * The filler may read less than cnt bytes if all bytes of data is not
717 * available immediately. The filler returns the number of bytes
718 * actually read in. The filler should return 0 if it reaches the end
719 * of the data source. If an error occurs, the filler must return -1.
720 *
721 * bufport_fill then adjust the end pointer, so the buffer becomes like
722 * this.
723 *
724 * <--------------- size ---------------->
725 * |************************************--|
726 * ^ ^
727 * bc e
728 *
729 * Close
730 * Port is closed either explicitly (via close-port etc) or implicitly
731 * (via GC -> finalizer). In either case, the flusher is called first
732 * if there's any data remaining in the buffer. Then, if the closer
733 * procedure (port->src.buf.closer) is not NULL, and port->owner is TRUE,
734 * the closer procedure is called which has to take care of any system-
735 * level cleanup. The closer can assume the buffer is already flushed.
736 *
737 * Ready
738 * When char-ready? is called on a buffered port, it first checks if
739 * there's any data available in the buffer. If so, it returns true.
740 * If not, it calls port->src.buf.ready if it is not NULL to query
741 * the character is ready. If port->src.buf.ready is NULL, bufport
742 * assumes the input is always ready.
743 * port->src.buf.ready should return either SCM_FD_READY, SCM_FD_WOULDBLOCK
744 * or SCM_FD_UNKNOWN.
745 *
746 * Filenum
747 * Port->src.buf.filenum is a query procedure that should return the
748 * underlying integer file descriptor of the port, or -1 if there's
749 * no associated one. If it is NULL, the port is assumed not to
750 * be associated to any file descriptor.
751 *
752 * Buffering mode
753 * {For Output}
754 * SCM_PORT_BUFFER_FULL : Full buffering. The buffer is flushed
755 * only when the buffer gets full, explicitly requested, or
756 * closed. This is the default, and suitable for file I/O.
757 *
758 * SCM_PORT_BUFFER_LINE : Line buffering. The buffer is flushed
759 * when a newline character is put, other than the normal
760 * circumstances as in SCM_PORT_BUFFER_FULL. Unlike C stdio,
761 * the buffer isn't flushed when an input is called on the same
762 * terminal device.
763 * This is natural for output of interactive communication.
764 * This is the default of stdout.
765 *
766 * SCM_PORT_BUFFER_NONE : data is always passed to the flusher
767 * procedure. The buffer is used just as a temporary storage.
768 * This slows down port operation significantly. Should only
769 * be used when you want to guarantee what you write is always
770 * passed to the lower layer. This is the default of stderr.
771 *
772 * {For Input}
773 * SCM_PORT_BUFFER_FULL : Full buffering. The filler procedure
774 * is called only if the buffer doesn't have enough data to
775 * satisfy the read request. Read-block or read-string won't
776 * return until the specified bytes/characters are read from
777 * the port, except the port reaches EOF.
778 *
779 * SCM_PORT_BUFFER_LINE : For input ports, this is almost the same
780 * as BUFFER_FULL, except that read-block and read-string may
781 * return shorter data than requested, if only that amount of
782 * data is immediately available. Usually this mode is suitable
783 * for the ports that is attached to a pipe or network.
784 *
785 * SCM_PORT_BUFFER_NONE : No buffering. Every time the data is
786 * requested, the filler procedure is called with exact amount
787 * of the requested data.
788 */
789
790 #define SCM_PORT_DEFAULT_BUFSIZ 8192
791
Scm_MakeBufferedPortFull(ScmClass * klass,ScmObj name,int dir,ScmPortBuffer * bufrec,u_long flags)792 ScmObj Scm_MakeBufferedPortFull(ScmClass *klass,
793 ScmObj name,
794 int dir, /* direction */
795 ScmPortBuffer *bufrec,
796 u_long flags)
797 {
798 ScmSize size = bufrec->size;
799 char *buf = bufrec->buffer;
800
801 if (size == 0) size = SCM_PORT_DEFAULT_BUFSIZ;
802 if (buf == NULL) buf = SCM_NEW_ATOMIC2(char*, size);
803 ScmPort *p = make_port(klass, name, dir, SCM_PORT_FILE);
804 p->ownerp = flags & SCM_PORT_OWNER;
805 PORT_BUF(p)->buffer = buf;
806 if ((dir & SCM_PORT_IOMASK) == SCM_PORT_INPUT) {
807 PORT_BUF(p)->current = PORT_BUF(p)->buffer;
808 PORT_BUF(p)->end = PORT_BUF(p)->buffer;
809 } else {
810 PORT_BUF(p)->current = PORT_BUF(p)->buffer;
811 PORT_BUF(p)->end = PORT_BUF(p)->buffer + size;
812 }
813 if (dir == SCM_PORT_OUTPUT_TRANSIENT) {
814 SCM_PORT_FLAGS(p) |= SCM_PORT_TRANSIENT;
815 }
816 PORT_BUF(p)->size = size;
817 PORT_BUF(p)->mode = bufrec->mode;
818 PORT_BUF(p)->filler = bufrec->filler;
819 PORT_BUF(p)->flusher = bufrec->flusher;
820 PORT_BUF(p)->closer = bufrec->closer;
821 PORT_BUF(p)->ready = bufrec->ready;
822 PORT_BUF(p)->filenum = bufrec->filenum;
823 PORT_BUF(p)->seeker = bufrec->seeker;
824 PORT_BUF(p)->data = bufrec->data;
825
826 if (flags & SCM_PORT_WITH_POSITION) {
827 PORT_BUF(p)->getpos = bufrec->getpos;
828 PORT_BUF(p)->setpos = bufrec->setpos;
829 PORT_BUF(p)->flags = bufrec->flags;
830 } else {
831 PORT_BUF(p)->getpos = NULL;
832 PORT_BUF(p)->setpos = NULL;
833 PORT_BUF(p)->flags = 0;
834 }
835
836 /* NB: DIR may be SCM_PORT_OUTPUT_TRANSIENT; in that case we don't
837 register the buffer. */
838 if (dir == SCM_PORT_OUTPUT) register_buffered_port(p);
839 return SCM_OBJ(p);
840 }
841
842 /* deprecated */
Scm_MakeBufferedPort(ScmClass * klass,ScmObj name,int dir,int ownerp,ScmPortBuffer * bufrec)843 ScmObj Scm_MakeBufferedPort(ScmClass *klass,
844 ScmObj name,
845 int dir, /* direction */
846 int ownerp,
847 ScmPortBuffer *bufrec)
848 {
849 return Scm_MakeBufferedPortFull(klass, name, dir, bufrec,
850 (ownerp? SCM_PORT_OWNER : 0));
851 }
852
853 /* flushes the buffer, to make a room of cnt bytes.
854 cnt == 0 means all the available data. Note that, unless forcep == TRUE,
855 this function only does "best effort" to make room, but doesn't
856 guarantee to output cnt bytes. */
bufport_flush(ScmPort * p,ScmSize cnt,int forcep)857 static void bufport_flush(ScmPort *p, ScmSize cnt, int forcep)
858 {
859 ScmSize cursiz = PORT_BUFFER_AVAIL(p);
860
861 if (cursiz == 0) return;
862 if (cnt <= 0) { cnt = cursiz; }
863 ScmSize nwrote = PORT_BUF(p)->flusher(p, cnt, forcep);
864 if (nwrote < 0) {
865 PORT_BUF(p)->current = PORT_BUF(p)->buffer; /* for safety */
866 p->error = TRUE;
867 /* TODO: can we raise an error here, or should we propagate
868 it to the caller? */
869 Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
870 "Couldn't flush port %S due to an error", p);
871 }
872 if (nwrote >= 0 && nwrote < cursiz) {
873 memmove(PORT_BUF(p)->buffer, PORT_BUF(p)->buffer+nwrote,
874 cursiz-nwrote);
875 PORT_BUF(p)->current -= nwrote;
876 } else {
877 PORT_BUF(p)->current = PORT_BUF(p)->buffer;
878 }
879 }
880
881 /* Writes siz bytes in src to the buffered port. siz may be larger than
882 the port's buffer. Won't return until entire siz bytes are written. */
bufport_write(ScmPort * p,const char * src,ScmSize siz)883 static void bufport_write(ScmPort *p, const char *src, ScmSize siz)
884 {
885 do {
886 ScmSize room = PORT_BUF(p)->end - PORT_BUF(p)->current;
887 if (room >= siz) {
888 memcpy(PORT_BUF(p)->current, src, siz);
889 PORT_BUF(p)->current += siz;
890 siz = 0;
891 } else {
892 memcpy(PORT_BUF(p)->current, src, room);
893 PORT_BUF(p)->current += room;
894 siz -= room;
895 src += room;
896 bufport_flush(p, 0, FALSE);
897 }
898 } while (siz != 0);
899 }
900
901 /* Fills the buffer. Reads at least MIN bytes (unless it reaches EOF).
902 * If ALLOW_LESS is true, however, we allow to return before the full
903 * data is read.
904 * Returns the number of bytes actually read, or 0 if EOF, or -1 if error.
905 */
bufport_fill(ScmPort * p,ScmSize min,int allow_less)906 static ScmSize bufport_fill(ScmPort *p, ScmSize min, int allow_less)
907 {
908 ScmSize cursiz = PORT_BUF(p)->end - PORT_BUF(p)->current;
909 ScmSize nread = 0, toread;
910 if (cursiz > 0) {
911 memmove(PORT_BUF(p)->buffer, PORT_BUF(p)->current, cursiz);
912 PORT_BUF(p)->current = PORT_BUF(p)->buffer;
913 PORT_BUF(p)->end = PORT_BUF(p)->current + cursiz;
914 } else {
915 PORT_BUF(p)->current = PORT_BUF(p)->end = PORT_BUF(p)->buffer;
916 }
917 if (min <= 0) min = PORT_BUFFER_ROOM(p);
918 if (PORT_BUFFER_MODE(p) != SCM_PORT_BUFFER_NONE) {
919 toread = PORT_BUFFER_ROOM(p);
920 } else {
921 toread = min;
922 }
923
924 do {
925 ScmSize r = PORT_BUF(p)->filler(p, toread-nread);
926 if (r <= 0) break;
927 nread += r;
928 PORT_BUF(p)->end += r;
929 } while (!allow_less && nread < min);
930 return nread;
931 }
932
933 /* Reads siz bytes to dst from the buffered port. siz may be larger
934 * than the port's buffer, in which case the filler procedure is called
935 * more than once. Unless the port buffering mode is BUFFER_FULL,
936 * this may read less than SIZ bytes if only that amount of data is
937 * immediately available.
938 * Caveat: if the filler procedure returns N where 0 < N < requested size,
939 * we know less data is available; non-greedy read can return at that point.
940 * However, if the filler procedure returns exactly the requested size,
941 * and we need more bytes, we gotta be careful -- next call to the filler
942 * procedure may or may not block. So we need to check the ready procedure.
943 */
bufport_read(ScmPort * p,char * dst,ScmSize siz)944 static ScmSize bufport_read(ScmPort *p, char *dst, ScmSize siz)
945 {
946 ScmSize nread = 0;
947 ScmSize avail = PORT_BUF(p)->end - PORT_BUF(p)->current;
948
949 ScmSize req = MIN(siz, avail);
950 if (req > 0) {
951 memcpy(dst, PORT_BUF(p)->current, req);
952 PORT_BUF(p)->current += req;
953 nread += req;
954 siz -= req;
955 dst += req;
956 }
957 while (siz > 0) {
958 /* We check data availability first, since we might already get
959 some data from the remanings in the buffer, and it is enough
960 if buffering mode is not full. */
961 if (nread && (PORT_BUFFER_MODE(p) != SCM_PORT_BUFFER_FULL)) {
962 if (PORT_BUF(p)->ready
963 && PORT_BUF(p)->ready(p) == SCM_FD_WOULDBLOCK) {
964 break;
965 }
966 }
967
968 ScmSize req = MIN(siz, PORT_BUF(p)->size);
969 ScmSize r = bufport_fill(p, req, TRUE);
970 if (r <= 0) break; /* EOF or an error*/
971 if (r >= siz) {
972 memcpy(dst, PORT_BUF(p)->current, siz);
973 PORT_BUF(p)->current += siz;
974 nread += siz;
975 break;
976 } else {
977 memcpy(dst, PORT_BUF(p)->current, r);
978 PORT_BUF(p)->current += r;
979 nread += r;
980 siz -= r;
981 dst += r;
982 }
983 }
984 return nread;
985 }
986
987 /* Tracking buffered ports:
988 *
989 * The OS doesn't automatically flush the buffered output port,
990 * as it does on FILE* structure. So Gauche keeps track of active
991 * output buffered ports, in a weak vector.
992 * When the port is no longer used, it is collected by GC and removed
993 * from the vector. Scm_FlushAllPorts() flushes the active ports.
994 *
995 * Note that we don't remove entry from the weak vector explicitly.
996 * We used to do that in the port finalizer; however, the finalizer
997 * is called _after_ GC has run and determined the port is a garbage,
998 * and at that moment GC has already cleared the vector entry. So we
999 * can rather let GC remove the entries.
1000 *
1001 * When we find the weak vector is full, we trigger a global GC once.
1002 * It may collect garbaged ports and make some room in the vector,
1003 * even though the ports are not finalized (GC_gcollect doesn't call
1004 * finalizers; they are called at the next checkpoint in VM).
1005 */
1006
1007 /*TODO: allow to extend the port vector. */
1008
1009 #define PORT_VECTOR_SIZE 256 /* need to be 2^n */
1010
1011 static struct {
1012 ScmWeakVector *ports;
1013 ScmInternalMutex mutex;
1014 } active_buffered_ports;
1015
1016 #define PORT_HASH(port) \
1017 ((((SCM_WORD(port)>>3) * 2654435761UL)>>16) % PORT_VECTOR_SIZE)
1018
register_buffered_port(ScmPort * port)1019 static void register_buffered_port(ScmPort *port)
1020 {
1021 int i, h, c;
1022 int tried_gc = FALSE;
1023 int need_gc = FALSE;
1024
1025 retry:
1026 h = i = (int)PORT_HASH(port);
1027 c = 0;
1028 /* search an available entry by quadratic hash
1029 used entry may have #<port> or #t. #t is for transient state
1030 during Scm_FlushAllPorts()---see below. */
1031 (void)SCM_INTERNAL_MUTEX_LOCK(active_buffered_ports.mutex);
1032 while (!SCM_FALSEP(Scm_WeakVectorRef(active_buffered_ports.ports,
1033 i, SCM_FALSE))) {
1034 i -= ++c; while (i<0) i+=PORT_VECTOR_SIZE;
1035 if (i == h) {
1036 /* Vector entry is full. We run global GC to try to collect
1037 unused entry. */
1038 need_gc = TRUE;
1039 break;
1040 }
1041 }
1042 if (!need_gc) {
1043 Scm_WeakVectorSet(active_buffered_ports.ports, i, SCM_OBJ(port));
1044 }
1045 (void)SCM_INTERNAL_MUTEX_UNLOCK(active_buffered_ports.mutex);
1046
1047 if (need_gc) {
1048 if (tried_gc) {
1049 /* We should probably try to extend the weak vector.
1050 But for the time being... */
1051 Scm_Panic("active buffered port table overflow");
1052 } else {
1053 GC_gcollect();
1054 tried_gc = TRUE;
1055 need_gc = FALSE;
1056 goto retry;
1057 }
1058 }
1059 }
1060
1061 /* This should be called when the output buffered port is explicitly closed.
1062 The ports collected by GC are automatically unregistered. */
unregister_buffered_port(ScmPort * port)1063 static void unregister_buffered_port(ScmPort *port)
1064 {
1065 int h = (int)PORT_HASH(port);
1066 int i = h;
1067 int c = 0;
1068 (void)SCM_INTERNAL_MUTEX_LOCK(active_buffered_ports.mutex);
1069 do {
1070 ScmObj p = Scm_WeakVectorRef(active_buffered_ports.ports, i, SCM_FALSE);
1071 if (!SCM_FALSEP(p) && SCM_EQ(SCM_OBJ(port), p)) {
1072 Scm_WeakVectorSet(active_buffered_ports.ports, i, SCM_FALSE);
1073 break;
1074 }
1075 i -= ++c; while (i<0) i+=PORT_VECTOR_SIZE;
1076 } while (i != h);
1077 (void)SCM_INTERNAL_MUTEX_UNLOCK(active_buffered_ports.mutex);
1078 }
1079
1080 /* Flush all ports. Note that it is possible that this routine can be
1081 called recursively if one of the flushing routine calls Scm_Exit.
1082 In order to avoid infinite loop, I have to delete the entries of already
1083 flushed port before calling flush, then recover them before return
1084 (unless exiting is true, in that case we know nobody cares the active
1085 port vector anymore).
1086 Even if more than one thread calls Scm_FlushAllPorts simultaneously,
1087 the flush method is called only once for each vector.
1088 */
Scm_FlushAllPorts(int exitting)1089 void Scm_FlushAllPorts(int exitting)
1090 {
1091 ScmObj p = SCM_FALSE;
1092 int saved = 0;
1093
1094 ScmVector *save = SCM_VECTOR(Scm_MakeVector(PORT_VECTOR_SIZE, SCM_FALSE));
1095 ScmWeakVector *ports = active_buffered_ports.ports;
1096
1097 for (int i=0; i<PORT_VECTOR_SIZE;) {
1098 (void)SCM_INTERNAL_MUTEX_LOCK(active_buffered_ports.mutex);
1099 for (; i<PORT_VECTOR_SIZE; i++) {
1100 p = Scm_WeakVectorRef(ports, i, SCM_FALSE);
1101 if (SCM_PORTP(p)) {
1102 Scm_VectorSet(save, i, p);
1103 /* Set #t so that the slot won't be reused. */
1104 Scm_WeakVectorSet(ports, i, SCM_TRUE);
1105 saved++;
1106 break;
1107 }
1108 }
1109 (void)SCM_INTERNAL_MUTEX_UNLOCK(active_buffered_ports.mutex);
1110 if (SCM_PORTP(p)) {
1111 SCM_ASSERT(SCM_PORT_TYPE(p)==SCM_PORT_FILE);
1112 if (!SCM_PORT_ERROR_OCCURRED_P(SCM_PORT(p))) {
1113 bufport_flush(SCM_PORT(p), 0, TRUE);
1114 }
1115 }
1116 }
1117 if (!exitting && saved) {
1118 (void)SCM_INTERNAL_MUTEX_LOCK(active_buffered_ports.mutex);
1119 for (int i=0; i<PORT_VECTOR_SIZE; i++) {
1120 p = Scm_VectorRef(save, i, SCM_FALSE);
1121 if (SCM_PORTP(p)) Scm_WeakVectorSet(ports, i, p);
1122 }
1123 (void)SCM_INTERNAL_MUTEX_UNLOCK(active_buffered_ports.mutex);
1124 }
1125 }
1126
1127 /* Utility procedure to translate Scheme arg into buffering mode */
1128 static ScmObj key_full = SCM_UNBOUND;
1129 static ScmObj key_modest = SCM_UNBOUND;
1130 static ScmObj key_line = SCM_UNBOUND;
1131 static ScmObj key_none = SCM_UNBOUND;
1132
Scm_KeywordToBufferingMode(ScmObj flag,int direction,int fallback)1133 int Scm_KeywordToBufferingMode(ScmObj flag, int direction, int fallback)
1134 {
1135 if (SCM_EQ(flag, key_full)) return SCM_PORT_BUFFER_FULL;
1136 if (SCM_EQ(flag, key_none)) return SCM_PORT_BUFFER_NONE;
1137 if (fallback >= 0 && (SCM_UNBOUNDP(flag) || SCM_FALSEP(flag)))
1138 return fallback;
1139 if (direction == SCM_PORT_INPUT) {
1140 if (SCM_EQ(flag, key_modest)) return SCM_PORT_BUFFER_LINE;
1141 else Scm_Error("buffering mode must be one of :full, :modest or :none, but got %S", flag);
1142 }
1143 if (direction == SCM_PORT_OUTPUT) {
1144 if (SCM_EQ(flag, key_line)) return SCM_PORT_BUFFER_LINE;
1145 else Scm_Error("buffering mode must be one of :full, :line or :none, but got %S", flag);
1146 }
1147 /* if direction is none of input or output, allow both. */
1148 if (SCM_EQ(flag, key_line) || SCM_EQ(flag, key_modest)) {
1149 return SCM_PORT_BUFFER_LINE;
1150 }
1151 else Scm_Error("buffering mode must be one of :full, :modest, :line or :none, but got %S", flag);
1152 return -1; /* dummy */
1153 }
1154
Scm_GetPortBufferingModeAsKeyword(ScmPort * port)1155 ScmObj Scm_GetPortBufferingModeAsKeyword(ScmPort *port)
1156 {
1157 if (SCM_PORT_TYPE(port) == SCM_PORT_FILE) {
1158 switch (PORT_BUFFER_MODE(port)) {
1159 case SCM_PORT_BUFFER_FULL: return key_full;
1160 case SCM_PORT_BUFFER_NONE: return key_none;
1161 default:
1162 if (SCM_IPORTP(port)) return key_modest;
1163 else return key_line;
1164 }
1165 }
1166 return SCM_FALSE;
1167 }
1168
1169 /* For the backward compatibility until release 1.0 */
Scm_BufferingMode(ScmObj flag,int direction,int fallback)1170 int Scm_BufferingMode(ScmObj flag, int direction, int fallback)
1171 {
1172 return Scm_KeywordToBufferingMode(flag, direction, fallback);
1173 }
1174
Scm_GetBufferingMode(ScmPort * port)1175 ScmObj Scm_GetBufferingMode(ScmPort *port)
1176 {
1177 return Scm_GetPortBufferingModeAsKeyword(port);
1178 }
1179
1180 /*===============================================================
1181 * Generic procedures
1182 */
1183
1184 #define SAFE_PORT_OP
1185 #include "portapi.c"
1186 #undef SAFE_PORT_OP
1187 #include "portapi.c"
1188
1189 /*===============================================================
1190 * File Port
1191 */
1192
1193 /* This small piece of data is kept in port->src.buf.data. */
1194 typedef struct file_port_data_rec {
1195 int fd;
1196 } file_port_data;
1197
1198 #define FILE_PORT_DATA(p) ((file_port_data*)(PORT_BUF(p)->data))
1199
file_filler(ScmPort * p,ScmSize cnt)1200 static ScmSize file_filler(ScmPort *p, ScmSize cnt)
1201 {
1202 ScmSize nread = 0;
1203 int fd = FILE_PORT_DATA(p)->fd;
1204 char *datptr = PORT_BUF(p)->end;
1205 SCM_ASSERT(fd >= 0);
1206 while (nread == 0) {
1207 ScmSize r;
1208 errno = 0;
1209 SCM_SYSCALL(r, read(fd, datptr, cnt-nread));
1210 if (r < 0) {
1211 p->error = TRUE;
1212 Scm_SysError("read failed on %S", p);
1213 } else if (r == 0) {
1214 /* EOF is read */
1215 break;
1216 } else {
1217 datptr += r;
1218 nread += r;
1219 }
1220 }
1221 return nread;
1222 }
1223
file_flusher(ScmPort * p,ScmSize cnt,int forcep)1224 static ScmSize file_flusher(ScmPort *p, ScmSize cnt, int forcep)
1225 {
1226 ScmSize nwrote = 0;
1227 ScmSize datsiz = PORT_BUFFER_AVAIL(p);
1228 int fd = FILE_PORT_DATA(p)->fd;
1229 char *datptr = PORT_BUF(p)->buffer;
1230
1231 SCM_ASSERT(fd >= 0);
1232 while ((!forcep && nwrote == 0)
1233 || (forcep && nwrote < cnt)) {
1234 ScmSize r;
1235 errno = 0;
1236 SCM_SYSCALL(r, write(fd, datptr, datsiz-nwrote));
1237 if (r < 0) {
1238 if (PORT_BUFFER_SIGPIPE_SENSITIVE_P(p)) {
1239 /* (sort of) emulate termination by SIGPIPE.
1240 NB: The difference is visible from the outside world
1241 as the process exit status differ (WIFEXITED
1242 instead of WIFSIGNALED). If it becomes a problem,
1243 we can reset the signal handler to SIG_DFL and
1244 send SIGPIPE to self. */
1245 Scm_Exit(1); /* exit code is somewhat arbitrary */
1246 }
1247 p->error = TRUE;
1248 Scm_SysError("write failed on %S", p);
1249 } else {
1250 datptr += r;
1251 nwrote += r;
1252 }
1253 }
1254 return nwrote;
1255 }
1256
file_closer(ScmPort * p)1257 static void file_closer(ScmPort *p)
1258 {
1259 int fd = FILE_PORT_DATA(p)->fd;
1260 if (fd >= 0) {
1261 /* If close() fails, the port's CLOSED flag isn't set and file_closer
1262 may be called again (probably via finalizer). We don't want to call
1263 close() again and raise an error. */
1264 FILE_PORT_DATA(p)->fd = -1;
1265 if (close(fd) < 0) {
1266 Scm_SysError("close() failed on %S", SCM_OBJ(p));
1267 }
1268 }
1269 }
1270
file_ready(ScmPort * p)1271 static int file_ready(ScmPort *p)
1272 {
1273 int fd = FILE_PORT_DATA(p)->fd;
1274 SCM_ASSERT(fd >= 0);
1275 return Scm_FdReady(fd, SCM_PORT_DIR(p));
1276 }
1277
file_filenum(ScmPort * p)1278 static int file_filenum(ScmPort *p)
1279 {
1280 return FILE_PORT_DATA(p)->fd;
1281 }
1282
file_seeker(ScmPort * p,off_t offset,int whence)1283 static off_t file_seeker(ScmPort *p, off_t offset, int whence)
1284 {
1285 return lseek(FILE_PORT_DATA(p)->fd, offset, whence);
1286 }
1287
1288 /* Kludge: We should have better way */
file_buffered_port_p(ScmPort * p)1289 static int file_buffered_port_p(ScmPort *p)
1290 {
1291 return (PORT_BUF(p)->filenum == file_filenum);
1292 }
1293
file_buffered_port_set_fd(ScmPort * p,int fd)1294 static void file_buffered_port_set_fd(ScmPort *p, int fd)
1295 {
1296 if (!file_buffered_port_p(p)) {
1297 Scm_Error("port is not directly conntect to fd: %S", p);
1298 }
1299 FILE_PORT_DATA(p)->fd = fd;
1300 }
1301
Scm_OpenFilePort(const char * path,int flags,int buffering,int perm)1302 ScmObj Scm_OpenFilePort(const char *path, int flags, int buffering, int perm)
1303 {
1304 int dir = 0;
1305
1306 if ((flags & O_ACCMODE) == O_RDONLY) dir = SCM_PORT_INPUT;
1307 else if ((flags & O_ACCMODE) == O_WRONLY) dir = SCM_PORT_OUTPUT;
1308 else Scm_Error("unsupported file access mode %d to open %s", flags&O_ACCMODE, path);
1309 if (buffering < SCM_PORT_BUFFER_FULL || buffering > SCM_PORT_BUFFER_NONE) {
1310 Scm_Error("bad buffering flag: %d", buffering);
1311 }
1312 #if defined(GAUCHE_WINDOWS)
1313 /* Force binary mode if not specified */
1314 if (!(flags & (O_TEXT|O_BINARY))) {
1315 flags |= O_BINARY;
1316 }
1317 #endif /*GAUCHE_WINDOWS*/
1318 int fd = open(path, flags, perm);
1319 if (fd < 0) return SCM_FALSE;
1320 /* In appending mode, we need to seek explicitly to the end to make
1321 port-tell returns the size of the file.
1322 We ignore the result of lseek here--it can fail if the opened file
1323 is a character device, for example, and it's ok. Any other serious
1324 errors would be caught by later operations anyway.
1325 */
1326 if (flags & O_APPEND) (void)lseek(fd, 0, SEEK_END);
1327
1328 file_port_data *data = SCM_NEW(file_port_data);
1329 data->fd = fd;
1330
1331 ScmPortBuffer bufrec;
1332 bufrec.mode = buffering;
1333 bufrec.buffer = NULL;
1334 bufrec.size = 0;
1335 bufrec.filler = file_filler;
1336 bufrec.flusher = file_flusher;
1337 bufrec.closer = file_closer;
1338 bufrec.ready = file_ready;
1339 bufrec.filenum = file_filenum;
1340 bufrec.seeker = file_seeker;
1341 bufrec.data = data;
1342 ScmObj p = Scm_MakeBufferedPort(SCM_CLASS_PORT, SCM_MAKE_STR_COPYING(path),
1343 dir, TRUE, &bufrec);
1344 return p;
1345 }
1346
1347 /* Create a port on specified file descriptor.
1348 NAME - used for the name of the port.
1349 DIRECTION - either SCM_PORT_INPUT or SCM_PORT_OUTPUT
1350 FD - the opened file descriptor.
1351 BUFMODE - buffering mode (ScmPortBufferMode)
1352 OWNERP - if TRUE, fd will be closed when this port is closed.
1353 */
Scm_MakePortWithFd(ScmObj name,int direction,int fd,int bufmode,int ownerp)1354 ScmObj Scm_MakePortWithFd(ScmObj name, int direction,
1355 int fd, int bufmode, int ownerp)
1356 {
1357 file_port_data *data = SCM_NEW(file_port_data);
1358 data->fd = fd;
1359
1360 ScmPortBuffer bufrec;
1361 bufrec.buffer = NULL;
1362 bufrec.size = 0;
1363 bufrec.mode = bufmode;
1364 bufrec.filler = file_filler;
1365 bufrec.flusher =file_flusher;
1366 bufrec.closer = file_closer;
1367 bufrec.ready = file_ready;
1368 bufrec.filenum = file_filenum;
1369 bufrec.data = data;
1370
1371 /* Check if the given fd is seekable, and set seeker if so. */
1372 if (lseek(fd, 0, SEEK_CUR) < 0) {
1373 bufrec.seeker = NULL;
1374 } else {
1375 bufrec.seeker = file_seeker;
1376 }
1377
1378 ScmObj p = Scm_MakeBufferedPort(SCM_CLASS_PORT, name, direction, ownerp,
1379 &bufrec);
1380 return p;
1381 }
1382
1383 /*===============================================================
1384 * String port
1385 */
1386
Scm_MakeInputStringPortFull(ScmString * str,ScmObj name,u_long flags)1387 ScmObj Scm_MakeInputStringPortFull(ScmString *str, ScmObj name,
1388 u_long flags)
1389 {
1390 ScmPort *p = make_port(SCM_CLASS_PORT, name, SCM_PORT_INPUT, SCM_PORT_ISTR);
1391 ScmSmallInt size;
1392 const char *s = Scm_GetStringContent(str, &size, NULL, NULL);
1393 PORT_ISTR(p)->start = s;
1394 PORT_ISTR(p)->current = s;
1395 PORT_ISTR(p)->end = s + size;
1396 if (flags&SCM_PORT_STRING_PRIVATE) PORT_PRELOCK(p, Scm_VM());
1397 return SCM_OBJ(p);
1398 }
1399
1400 /* deprecated */
Scm_MakeInputStringPort(ScmString * str,int privatep)1401 ScmObj Scm_MakeInputStringPort(ScmString *str, int privatep)
1402 {
1403 return Scm_MakeInputStringPortFull(str,
1404 SCM_MAKE_STR("(input string port)"),
1405 (privatep?SCM_PORT_STRING_PRIVATE:0));
1406 }
1407
Scm_MakeOutputStringPortFull(ScmObj name,u_long flags)1408 ScmObj Scm_MakeOutputStringPortFull(ScmObj name, u_long flags)
1409 {
1410 ScmPort *p = make_port(SCM_CLASS_PORT, name, SCM_PORT_OUTPUT, SCM_PORT_OSTR);
1411 Scm_DStringInit(PORT_OSTR(p));
1412 if (flags&SCM_PORT_STRING_PRIVATE) PORT_PRELOCK(p, Scm_VM());
1413 return SCM_OBJ(p);
1414 }
1415
1416 /* deprecated */
Scm_MakeOutputStringPort(int privatep)1417 ScmObj Scm_MakeOutputStringPort(int privatep)
1418 {
1419 return Scm_MakeOutputStringPortFull(SCM_MAKE_STR("(output string port)"),
1420 (privatep?SCM_PORT_STRING_PRIVATE:0));
1421 }
1422
Scm_GetOutputString(ScmPort * port,int flags)1423 ScmObj Scm_GetOutputString(ScmPort *port, int flags)
1424 {
1425 if (SCM_PORT_TYPE(port) != SCM_PORT_OSTR)
1426 Scm_Error("output string port required, but got %S", port);
1427 ScmVM *vm = Scm_VM();
1428 PORT_LOCK(port, vm);
1429 ScmObj r = Scm_DStringGet(PORT_OSTR(port), flags);
1430 PORT_UNLOCK(port);
1431 return r;
1432 }
1433
Scm_GetOutputStringUnsafe(ScmPort * port,int flags)1434 ScmObj Scm_GetOutputStringUnsafe(ScmPort *port, int flags)
1435 {
1436 if (SCM_PORT_TYPE(port) != SCM_PORT_OSTR)
1437 Scm_Error("output string port required, but got %S", port);
1438 return Scm_DStringGet(PORT_OSTR(port), flags);
1439 }
1440
1441 #if GAUCHE_API_VERSION < 1000
1442 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1443 Will be removed on 1.0 */
Scm__GetOutputStringCompat(ScmPort * port)1444 ScmObj Scm__GetOutputStringCompat(ScmPort *port)
1445 {
1446 return Scm_GetOutputString(port, 0);
1447 }
1448
1449 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1450 Will be removed on 1.0 */
Scm__GetOutputStringUnsafeCompat(ScmPort * port)1451 ScmObj Scm__GetOutputStringUnsafeCompat(ScmPort *port)
1452 {
1453 return Scm_GetOutputStringUnsafe(port, 0);
1454 }
1455 #endif /*GAUCHE_API_VERSION < 1000*/
1456
1457 static ScmObj get_remaining_input_string_aux(const char *s, ScmSize ssiz,
1458 const char *p, ScmSize psiz,
1459 int flags);
1460
Scm_GetRemainingInputString(ScmPort * port,int flags)1461 ScmObj Scm_GetRemainingInputString(ScmPort *port, int flags)
1462 {
1463 if (SCM_PORT_TYPE(port) != SCM_PORT_ISTR)
1464 Scm_Error("input string port required, but got %S", port);
1465 /* NB: we don't need to lock the port, since the string body
1466 the port is pointing won't be changed. */
1467 const char *ep = PORT_ISTR(port)->end;
1468 const char *cp = PORT_ISTR(port)->current;
1469 /* Things gets complicated if there's an ungotten char or bytes.
1470 We want to share the string body whenever possible, so we
1471 first check the ungotten stuff matches the content of the
1472 buffer. */
1473 if (PORT_UNGOTTEN(port) != SCM_CHAR_INVALID) {
1474 char cbuf[SCM_CHAR_MAX_BYTES];
1475 int nbytes = SCM_CHAR_NBYTES(PORT_UNGOTTEN(port));
1476 SCM_CHAR_PUT(cbuf, PORT_UNGOTTEN(port));
1477 const char *sp = PORT_ISTR(port)->start;
1478 if (cp - sp >= nbytes
1479 && memcmp(cp - nbytes, cbuf, nbytes) == 0) {
1480 cp -= nbytes; /* we can reuse buffer */
1481 return Scm_MakeString(cp, (int)(ep-cp), -1, flags);
1482 } else {
1483 /* we need to copy */
1484 return get_remaining_input_string_aux(cp, ep-cp,
1485 cbuf, nbytes, flags);
1486 }
1487 } else if (port->scrcnt > 0) {
1488 const char *sp = PORT_ISTR(port)->start;
1489 if (cp - sp >= (int)port->scrcnt
1490 && memcmp(cp - port->scrcnt, PORT_SCRATCH(port), port->scrcnt) == 0) {
1491 cp -= port->scrcnt; /* we can reuse buffer */
1492 return Scm_MakeString(cp, (int)(ep-cp), -1, flags);
1493 } else {
1494 /* we need to copy */
1495 return get_remaining_input_string_aux(cp, ep-cp,
1496 PORT_SCRATCH(port),
1497 port->scrcnt, flags);
1498 }
1499 } else {
1500 return Scm_MakeString(cp, (int)(ep-cp), -1, flags);
1501 }
1502 }
1503
get_remaining_input_string_aux(const char * s,ScmSize ssiz,const char * p,ScmSize psiz,int flags)1504 static ScmObj get_remaining_input_string_aux(const char *s, ScmSize ssiz,
1505 const char *p, ScmSize psiz,
1506 int flags)
1507 {
1508 char *b = SCM_NEW_ATOMIC2(char *, psiz+ssiz+1);
1509 memcpy(b, p, psiz);
1510 memcpy(b+psiz, s, ssiz);
1511 b[psiz+ssiz] = '\0';
1512 return Scm_MakeString(b, psiz+ssiz, -1, flags);
1513 }
1514
1515 #if GAUCHE_API_VERSION < 1000
1516 /* TRANSIENT: Pre-0.9 Compatibility routine. Kept for the binary compatibility.
1517 Will be removed on 1.0 */
Scm__GetRemainingInputStringCompat(ScmPort * port)1518 ScmObj Scm__GetRemainingInputStringCompat(ScmPort *port)
1519 {
1520 return Scm_GetRemainingInputString(port, 0);
1521 }
1522 #endif /*GAUCHE_API_VERSION < 1000*/
1523
1524 /*===============================================================
1525 * Procedural port
1526 */
1527
1528 /* To create a procedural port, fill in the ScmPortVTable function
1529 pointers and pass it to Scm_MakeVirtualPort. You don't need to
1530 provide all the functions; put NULL if you think you don't
1531 provide the functionality.
1532 */
1533
1534 /* default dummy procedures */
null_getb(ScmPort * dummy SCM_UNUSED)1535 static int null_getb(ScmPort *dummy SCM_UNUSED)
1536 {
1537 return SCM_CHAR_INVALID;
1538 }
1539
null_getc(ScmPort * dummy SCM_UNUSED)1540 static int null_getc(ScmPort *dummy SCM_UNUSED)
1541 {
1542 return SCM_CHAR_INVALID;
1543 }
1544
null_getz(char * buf SCM_UNUSED,ScmSize buflen SCM_UNUSED,ScmPort * dummy SCM_UNUSED)1545 static ScmSize null_getz(char *buf SCM_UNUSED,
1546 ScmSize buflen SCM_UNUSED,
1547 ScmPort *dummy SCM_UNUSED)
1548 {
1549 return 0;
1550 }
1551
null_ready(ScmPort * dummy SCM_UNUSED,int charp SCM_UNUSED)1552 static int null_ready(ScmPort *dummy SCM_UNUSED, int charp SCM_UNUSED)
1553 {
1554 return TRUE;
1555 }
1556
null_putb(ScmByte b SCM_UNUSED,ScmPort * dummy SCM_UNUSED)1557 static void null_putb(ScmByte b SCM_UNUSED, ScmPort *dummy SCM_UNUSED)
1558 {
1559 }
1560
null_putc(ScmChar c SCM_UNUSED,ScmPort * dummy SCM_UNUSED)1561 static void null_putc(ScmChar c SCM_UNUSED, ScmPort *dummy SCM_UNUSED)
1562 {
1563 }
1564
null_putz(const char * str SCM_UNUSED,ScmSize len SCM_UNUSED,ScmPort * dummy SCM_UNUSED)1565 static void null_putz(const char *str SCM_UNUSED,
1566 ScmSize len SCM_UNUSED,
1567 ScmPort *dummy SCM_UNUSED)
1568 {
1569 }
1570
null_puts(ScmString * s SCM_UNUSED,ScmPort * dummy SCM_UNUSED)1571 static void null_puts(ScmString *s SCM_UNUSED, ScmPort *dummy SCM_UNUSED)
1572 {
1573 }
1574
null_flush(ScmPort * dummy SCM_UNUSED)1575 static void null_flush(ScmPort *dummy SCM_UNUSED)
1576 {
1577 }
1578
Scm_MakeVirtualPortFull(ScmClass * klass,ScmObj name,int direction,const ScmPortVTable * vtable,u_long flags SCM_UNUSED)1579 ScmObj Scm_MakeVirtualPortFull(ScmClass *klass, ScmObj name,
1580 int direction,
1581 const ScmPortVTable *vtable,
1582 u_long flags SCM_UNUSED)
1583 {
1584 ScmPort *p = make_port(klass, name, direction, SCM_PORT_PROC);
1585
1586 /* Initialize default values */
1587 PORT_VT(p)->Getb = null_getb;
1588 PORT_VT(p)->Getc = null_getc;
1589 PORT_VT(p)->Getz = null_getz;
1590 PORT_VT(p)->Ready = null_ready;
1591 PORT_VT(p)->Putb = null_putb;
1592 PORT_VT(p)->Putc = null_putc;
1593 PORT_VT(p)->Putz = null_putz;
1594 PORT_VT(p)->Puts = null_puts;
1595 PORT_VT(p)->Flush = null_flush;
1596 PORT_VT(p)->Close = NULL;
1597 PORT_VT(p)->Seek = NULL;
1598 PORT_VT(p)->data = NULL;
1599 PORT_VT(p)->GetPos = NULL;
1600 PORT_VT(p)->SetPos = NULL;
1601 PORT_VT(p)->flags = 0;
1602
1603 if (vtable->Getb) PORT_VT(p)->Getb = vtable->Getb;
1604 if (vtable->Getc) PORT_VT(p)->Getc = vtable->Getc;
1605 if (vtable->Getz) PORT_VT(p)->Getz = vtable->Getz;
1606 if (vtable->Ready) PORT_VT(p)->Ready = vtable->Ready;
1607 if (vtable->Putb) PORT_VT(p)->Putb = vtable->Putb;
1608 if (vtable->Putc) PORT_VT(p)->Putc = vtable->Putc;
1609 if (vtable->Putz) PORT_VT(p)->Putz = vtable->Putz;
1610 if (vtable->Puts) PORT_VT(p)->Puts = vtable->Puts;
1611 if (vtable->Flush) PORT_VT(p)->Flush = vtable->Flush;
1612 if (vtable->Close) PORT_VT(p)->Close = vtable->Close;
1613 if (vtable->Seek) PORT_VT(p)->Seek = vtable->Seek;
1614 PORT_VT(p)->data = vtable->data;
1615
1616 if (flags & SCM_PORT_WITH_POSITION) {
1617 if (vtable->GetPos) PORT_VT(p)->GetPos = vtable->GetPos;
1618 if (vtable->SetPos) PORT_VT(p)->SetPos = vtable->SetPos;
1619 PORT_VT(p)->flags = vtable->flags;
1620 }
1621
1622 return SCM_OBJ(p);
1623 }
1624
1625 /* deprecated */
Scm_MakeVirtualPort(ScmClass * klass,int direction,const ScmPortVTable * vtable)1626 ScmObj Scm_MakeVirtualPort(ScmClass *klass,
1627 int direction,
1628 const ScmPortVTable *vtable)
1629 {
1630 return Scm_MakeVirtualPortFull(klass, SCM_FALSE, direction, vtable, 0);
1631 }
1632
1633 /*===============================================================
1634 * Coding-aware port
1635 */
1636
1637 /* Coding-aware port wraps an input port, and specifically recognizes
1638 'coding' magic comment. It is primarily used when loading source
1639 code, but can be used separately. */
1640
1641 static ScmPort *(*coding_aware_port_hook)(ScmPort *src,
1642 const char *srcencoding) = NULL;
1643
1644 /* gauche.charconv sets the pointer */
Scm__InstallCodingAwarePortHook(ScmPort * (* f)(ScmPort *,const char *))1645 void Scm__InstallCodingAwarePortHook(ScmPort *(*f)(ScmPort*, const char*))
1646 {
1647 coding_aware_port_hook = f;
1648 }
1649
1650 #define CODING_MAGIC_COMMENT_LINES 2 /* maximum number of lines to be
1651 looked at for the 'encoding' magic
1652 comment. */
1653
1654 typedef struct coding_port_data_rec {
1655 ScmPort *source; /* source port */
1656 int state; /* port state; see below */
1657 const char *pbuf; /* prefetched buffer. NUL terminated.
1658 contains at most CODING_MAGIC_COMMENT_LINES
1659 newlines. */
1660 int pbufsize; /* # of bytes in pbuf */
1661 } coding_port_data;
1662
1663 enum {
1664 CODING_PORT_INIT, /* initial state */
1665 CODING_PORT_RECOGNIZED, /* prefetched up to two lines, and
1666 conversion port is set if necessary.
1667 there are buffered data in lines[]. */
1668 CODING_PORT_FLUSHED /* prefetched lines are flushed. */
1669 };
1670
1671 /* A hardcoded DFA to recognize #/;.*coding[:=]\s*([\w.-]+)/ */
look_for_encoding(const char * buf)1672 static const char *look_for_encoding(const char *buf)
1673 {
1674 const char *s;
1675
1676 init:
1677 for (;;) {
1678 switch (*buf++) {
1679 case '\0': return NULL;
1680 case ';': goto comment;
1681 }
1682 }
1683 comment:
1684 for (;;) {
1685 switch (*buf++) {
1686 case '\0': return NULL;
1687 case '\n': goto init;
1688 case '\r': if (*buf != '\n') goto init; break;
1689 case 'c' : goto coding;
1690 }
1691 }
1692 coding:
1693 if (strncmp(buf, "oding", 5) != 0) goto comment;
1694 buf+=5;
1695 if (*buf != ':' && *buf != '=') goto comment;
1696 for (buf++;;buf++) {
1697 if (*buf != ' ' && *buf != '\t') break;
1698 }
1699 if (*buf == '\0') return NULL;
1700
1701 for (s = buf;*buf;buf++) {
1702 if (!isalnum(*buf) && *buf != '_' && *buf != '-' && *buf != '.') {
1703 break;
1704 }
1705 }
1706 if (s == buf) goto comment;
1707
1708 /* Here we found a matching string, starting from s and ends at buf. */
1709
1710 /* kludge: Emacs uses special suffix #/-(unix|dos|mac)$/ to distinguish
1711 EOL variants. For compatibility, drop such suffix if we have one. */
1712 if (buf-s > 5 && (strncmp(buf-5, "-unix", 5) == 0)) {
1713 buf -= 5;
1714 } else if (buf-s > 4 && (strncmp(buf-4, "-dos", 4) == 0
1715 || strncmp(buf-4, "-mac", 4) == 0)) {
1716 buf -= 4;
1717 }
1718
1719 /* Copy and return the encoding string */
1720 return SCM_STRDUP_PARTIAL(s, buf-s);
1721 }
1722
coding_port_recognize_encoding(ScmPort * port,coding_port_data * data)1723 static void coding_port_recognize_encoding(ScmPort *port,
1724 coding_port_data *data)
1725 {
1726 int num_newlines = 0;
1727 int cr_seen = FALSE;
1728
1729 SCM_ASSERT(data->source != NULL);
1730
1731 /* Prefetch up to CODING_MAGIC_COMMENT_LINES lines or the first NUL
1732 character. data->pbuf ends up holding NUL terminated string. */
1733 ScmDString ds;
1734 Scm_DStringInit(&ds);
1735 for (;num_newlines < CODING_MAGIC_COMMENT_LINES;) {
1736 int c = Scm_GetbUnsafe(data->source);
1737 if (c == EOF) break;
1738 if (c == 0) {
1739 /* take extra care not to lose '\0' */
1740 Scm_UngetbUnsafe(c, data->source);
1741 break;
1742 }
1743 SCM_DSTRING_PUTB(&ds, c);
1744 if (c == '\r') { /* for the source that only uses '\r' */
1745 if (cr_seen) num_newlines++;
1746 cr_seen = TRUE;
1747 } else if (c == '\n' || cr_seen) {
1748 num_newlines++;
1749 cr_seen = FALSE;
1750 } else {
1751 cr_seen = FALSE;
1752 }
1753 }
1754 data->pbuf = Scm_DStringGetz(&ds);
1755 data->pbufsize = (int)strlen(data->pbuf);
1756
1757 /* Look for the magic comment */
1758 const char *encoding = NULL;
1759 encoding = look_for_encoding(data->pbuf);
1760
1761 /* Wrap the source port by conversion port, if necessary. */
1762 if (encoding == NULL || Scm_SupportedCharacterEncodingP(encoding)) {
1763 return;
1764 }
1765
1766 if (coding_aware_port_hook == NULL) {
1767 /* Require gauche.charconv.
1768 NB: we don't need mutex here, for loading the module is
1769 serialized in Scm_Require. */
1770 Scm_Require(SCM_MAKE_STR("gauche/charconv"),
1771 SCM_LOAD_PROPAGATE_ERROR, NULL);
1772 if (coding_aware_port_hook == NULL) {
1773 Scm_PortError(port, SCM_PORT_ERROR_OTHER,
1774 "couldn't load gauche.charconv module");
1775 }
1776 }
1777 data->source = coding_aware_port_hook(data->source, encoding);
1778 }
1779
coding_filler(ScmPort * p,ScmSize cnt)1780 static ScmSize coding_filler(ScmPort *p, ScmSize cnt)
1781 {
1782 ScmSize nread = 0;
1783 coding_port_data *data = (coding_port_data*)PORT_BUF(p)->data;
1784 char *datptr = PORT_BUF(p)->end;
1785
1786 SCM_ASSERT(data->source);
1787
1788 /* deals with the most frequent case */
1789 if (data->state == CODING_PORT_FLUSHED) {
1790 return Scm_GetzUnsafe(datptr, cnt, data->source);
1791 }
1792
1793 if (data->state == CODING_PORT_INIT) {
1794 coding_port_recognize_encoding(p, data);
1795 data->state = CODING_PORT_RECOGNIZED;
1796 }
1797
1798 /* Here, we have data->state == CODING_PORT_RECOGNIZED */
1799 if (data->pbufsize > 0) {
1800 if (data->pbufsize <= cnt) {
1801 memcpy(datptr, data->pbuf, data->pbufsize);
1802 nread = data->pbufsize;
1803 data->pbuf = NULL;
1804 data->pbufsize = 0;
1805 data->state = CODING_PORT_FLUSHED;
1806 } else {
1807 memcpy(datptr, data->pbuf, cnt);
1808 nread = cnt;
1809 data->pbuf += cnt;
1810 data->pbufsize -= cnt;
1811 }
1812 return nread;
1813 } else {
1814 data->state = CODING_PORT_FLUSHED;
1815 return Scm_GetzUnsafe(datptr, cnt, data->source);
1816 }
1817 }
1818
coding_closer(ScmPort * p)1819 static void coding_closer(ScmPort *p)
1820 {
1821 coding_port_data *data = (coding_port_data*)PORT_BUF(p)->data;
1822 if (data->source) {
1823 Scm_ClosePort(data->source);
1824 data->source = NULL;
1825 }
1826 }
1827
coding_ready(ScmPort * p)1828 static int coding_ready(ScmPort *p)
1829 {
1830 coding_port_data *data = (coding_port_data*)PORT_BUF(p)->data;
1831 if (data->source == NULL) return TRUE;
1832 if (data->state == CODING_PORT_RECOGNIZED) {
1833 return SCM_FD_READY;
1834 } else {
1835 return Scm_ByteReadyUnsafe(p);
1836 }
1837 }
1838
coding_filenum(ScmPort * p)1839 static int coding_filenum(ScmPort *p)
1840 {
1841 coding_port_data *data = (coding_port_data*)PORT_BUF(p)->data;
1842 if (data->source == NULL) return -1;
1843 return Scm_PortFileNo(data->source);
1844 }
1845
Scm_MakeCodingAwarePort(ScmPort * iport)1846 ScmObj Scm_MakeCodingAwarePort(ScmPort *iport)
1847 {
1848 if (!SCM_IPORTP(iport)) {
1849 Scm_Error("open-coding-aware-port requires an input port, but got %S", iport);
1850 }
1851 coding_port_data *data = SCM_NEW(coding_port_data);
1852 data->source = iport;
1853 data->state = CODING_PORT_INIT;
1854 data->pbuf = NULL;
1855 data->pbufsize = 0;
1856
1857 ScmPortBuffer bufrec;
1858 bufrec.mode = SCM_PORT_BUFFER_FULL;
1859 bufrec.buffer = NULL;
1860 bufrec.size = 0;
1861 bufrec.filler = coding_filler;
1862 bufrec.flusher = NULL;
1863 bufrec.closer = coding_closer;
1864 bufrec.ready = coding_ready;
1865 bufrec.filenum = coding_filenum;
1866 bufrec.seeker = NULL;
1867 bufrec.data = (void*)data;
1868 ScmObj p = Scm_MakeBufferedPort(SCM_CLASS_CODING_AWARE_PORT,
1869 Scm_PortName(iport), SCM_PORT_INPUT,
1870 TRUE, &bufrec);
1871 return p;
1872 }
1873
1874 /*===============================================================
1875 * Standard ports
1876 */
1877
1878 static ScmObj scm_stdin = SCM_UNBOUND;
1879 static ScmObj scm_stdout = SCM_UNBOUND;
1880 static ScmObj scm_stderr = SCM_UNBOUND;
1881
1882 #define DEFSTDPORT(Name, var) \
1883 ScmObj SCM_CPP_CAT(Scm_, Name)(void) \
1884 { \
1885 return var; \
1886 } \
1887 ScmObj SCM_CPP_CAT(Scm_Set, Name)(ScmPort *port) \
1888 { \
1889 ScmObj oldp = var; \
1890 var = SCM_OBJ(port); \
1891 return oldp; \
1892 }
1893
DEFSTDPORT(Stdin,scm_stdin)1894 DEFSTDPORT(Stdin, scm_stdin)
1895 DEFSTDPORT(Stdout, scm_stdout)
1896 DEFSTDPORT(Stderr, scm_stderr)
1897
1898 ScmObj Scm_SetCurrentInputPort(ScmPort *port)
1899 {
1900 ScmVM *vm = Scm_VM();
1901 ScmObj oldp = SCM_OBJ(SCM_VM_CURRENT_INPUT_PORT(vm));
1902 SCM_VM_CURRENT_INPUT_PORT(vm) = port;
1903 return oldp;
1904 }
1905
Scm_SetCurrentOutputPort(ScmPort * port)1906 ScmObj Scm_SetCurrentOutputPort(ScmPort *port)
1907 {
1908 ScmVM *vm = Scm_VM();
1909 ScmObj oldp = SCM_OBJ(SCM_VM_CURRENT_OUTPUT_PORT(vm));
1910 SCM_VM_CURRENT_OUTPUT_PORT(vm) = port;
1911 return oldp;
1912 }
1913
Scm_SetCurrentErrorPort(ScmPort * port)1914 ScmObj Scm_SetCurrentErrorPort(ScmPort *port)
1915 {
1916 ScmVM *vm = Scm_VM();
1917 ScmObj oldp = SCM_OBJ(SCM_VM_CURRENT_ERROR_PORT(vm));
1918 SCM_VM_CURRENT_ERROR_PORT(vm) = port;
1919 return oldp;
1920 }
1921
1922 /*===============================================================
1923 * Initialization
1924 */
1925
Scm__InitPort(void)1926 void Scm__InitPort(void)
1927 {
1928 if (sizeof(ScmPort) < sizeof(ScmPortImpl)) {
1929 fprintf(stderr,
1930 "sizeof(ScmPort) [%"PRIdPTR"] is smaller than "
1931 "sizeof(ScmPortImpl) [%"PRIdPTR"]\n",
1932 SCM_WORD(sizeof(ScmPort)), SCM_WORD(sizeof(ScmPortImpl)));
1933 Scm_Panic("Implementation error. Exitting.");
1934 }
1935
1936 (void)SCM_INTERNAL_MUTEX_INIT(active_buffered_ports.mutex);
1937 active_buffered_ports.ports = SCM_WEAK_VECTOR(Scm_MakeWeakVector(PORT_VECTOR_SIZE));
1938
1939 Scm_InitStaticClass(&Scm_PortClass, "<port>",
1940 Scm_GaucheModule(), port_slots, 0);
1941 Scm_InitStaticClass(&Scm_CodingAwarePortClass, "<coding-aware-port>",
1942 Scm_GaucheModule(), port_slots, 0);
1943
1944 /* This must be done before *any* port is created. */
1945 readerLexicalMode =
1946 Scm_BindPrimitiveParameter(Scm_GaucheModule(), "reader-lexical-mode",
1947 SCM_OBJ(SCM_SYM_PERMISSIVE), 0);
1948
1949 scm_stdin = Scm_MakePortWithFd(SCM_MAKE_STR("(standard input)"),
1950 SCM_PORT_INPUT, 0,
1951 SCM_PORT_BUFFER_FULL, TRUE);
1952 /* By default, stdout and stderr are SIGPIPE sensitive */
1953 scm_stdout = Scm_MakePortWithFd(SCM_MAKE_STR("(standard output)"),
1954 SCM_PORT_OUTPUT, 1,
1955 ((isatty(1)
1956 ? SCM_PORT_BUFFER_LINE
1957 : SCM_PORT_BUFFER_FULL)
1958 | SCM_PORT_BUFFER_SIGPIPE_SENSITIVE),
1959 TRUE);
1960 scm_stderr = Scm_MakePortWithFd(SCM_MAKE_STR("(standard error output)"),
1961 SCM_PORT_OUTPUT, 2,
1962 (SCM_PORT_BUFFER_NONE
1963 | SCM_PORT_BUFFER_SIGPIPE_SENSITIVE),
1964 TRUE);
1965
1966 /* The root VM is initialized with bogus standard ports; we need to
1967 reset them. */
1968 Scm_VM()->curin = SCM_PORT(scm_stdin);
1969 Scm_VM()->curout = SCM_PORT(scm_stdout);
1970 Scm_VM()->curerr = SCM_PORT(scm_stderr);
1971
1972 key_full = Scm_MakeKeyword(SCM_STRING(SCM_MAKE_STR("full")));
1973 key_modest = Scm_MakeKeyword(SCM_STRING(SCM_MAKE_STR("modest")));
1974 key_line = Scm_MakeKeyword(SCM_STRING(SCM_MAKE_STR("line")));
1975 key_none = Scm_MakeKeyword(SCM_STRING(SCM_MAKE_STR("none")));
1976 }
1977
1978 /* Windows specific:
1979
1980 When we run Windows no-console mode, stdios are bogus (gosh-noconsole
1981 wires them to NUL device, but when libgauche is called from other
1982 applications, we can't assume that.) It is too painful to be so,
1983 since when Scheme program tries to write to stdout or stderr it just
1984 crashes without any information at all.
1985
1986 So, this function re-wires Scheme standard output and error output
1987 to a special port; when an output is made for the first time
1988 the port opens up a console by AllocConsole(), and redirects further
1989 output to it.
1990
1991 Unfortunately we can't do this at initialization time, since
1992 Scm_Init() doesn't have a way to know whether we're in console mode
1993 or not. Only the application knows, thus it needs to call this API
1994 after Scheme system is initialized.
1995 */
1996 #if defined(GAUCHE_WINDOWS)
1997
1998 static ScmInternalMutex win_console_mutex;
1999 static int win_console_created = FALSE;
2000
prepare_console_and_stdio(const char * devname,int flags,DWORD nStdHandle,int fd,int * initialized)2001 static void prepare_console_and_stdio(const char *devname, int flags,
2002 DWORD nStdHandle, int fd,
2003 int *initialized)
2004 {
2005 HANDLE h;
2006 SECURITY_ATTRIBUTES sa;
2007 int temp_fd = -1;
2008 int err = 0;
2009 #define ERR_CREATEFILE 1
2010 #define ERR_OPEN_OSFHANDLE 2
2011 #define ERR_DUP2 3
2012 #define ERR_SETSTDHANDLE 4
2013
2014 SCM_INTERNAL_MUTEX_LOCK(win_console_mutex);
2015 if (!win_console_created) {
2016 win_console_created = TRUE;
2017 AllocConsole();
2018 }
2019 if (!(*initialized)) {
2020 /* NB: Double fault will be caught in the error handling
2021 mechanism, so we don't need to worry it here. */
2022 sa.nLength = sizeof(SECURITY_ATTRIBUTES);
2023 sa.lpSecurityDescriptor = NULL;
2024 sa.bInheritHandle = TRUE;
2025 h = CreateFile(SCM_MBS2WCS(devname),
2026 GENERIC_READ | GENERIC_WRITE,
2027 FILE_SHARE_READ | FILE_SHARE_WRITE,
2028 &sa, OPEN_EXISTING, 0, NULL);
2029 if (h == INVALID_HANDLE_VALUE) {
2030 err = ERR_CREATEFILE;
2031 } else if ((temp_fd = _open_osfhandle((intptr_t)h, flags)) < 0) {
2032 err = ERR_OPEN_OSFHANDLE;
2033 } else if (_dup2(temp_fd, fd) < 0) {
2034 err = ERR_DUP2;
2035 } else if (SetStdHandle(nStdHandle, (HANDLE)_get_osfhandle(fd)) == 0) {
2036 err = ERR_SETSTDHANDLE;
2037 } else {
2038 *initialized = TRUE;
2039 }
2040 }
2041 SCM_INTERNAL_MUTEX_UNLOCK(win_console_mutex);
2042
2043 if (temp_fd >= 0) close(temp_fd);
2044 switch (err) {
2045 case ERR_CREATEFILE:
2046 Scm_SysError("CreateFile(%s) failed", devname);
2047 break; /* Dummy */
2048 case ERR_OPEN_OSFHANDLE:
2049 CloseHandle(h);
2050 Scm_SysError("_open_osfhandle failed (fd = %d)", fd);
2051 break; /* Dummy */
2052 case ERR_DUP2:
2053 CloseHandle(h);
2054 Scm_SysError("dup2(%d) failed (osf_handle)", fd);
2055 break; /* Dummy */
2056 case ERR_SETSTDHANDLE:
2057 CloseHandle(h);
2058 Scm_SysError("SetStdHandle(%d) failed (fd = %d)", (int)nStdHandle, fd);
2059 break; /* Dummy */
2060 }
2061
2062 #undef ERR_CREATEFILE
2063 #undef ERR_OPEN_OSFHANDLE
2064 #undef ERR_DUP2
2065 #undef ERR_SETSTDHANDLE
2066 }
2067
trapper_filler(ScmPort * p,ScmSize cnt)2068 static ScmSize trapper_filler(ScmPort *p, ScmSize cnt)
2069 {
2070 static int initialized = FALSE;
2071 prepare_console_and_stdio("CONIN$", _O_RDONLY | _O_BINARY,
2072 STD_INPUT_HANDLE, 0, &initialized);
2073 return file_filler(p, cnt);
2074 }
2075
trapper_flusher1(ScmPort * p,ScmSize cnt,int forcep)2076 static ScmSize trapper_flusher1(ScmPort *p, ScmSize cnt, int forcep)
2077 {
2078 static int initialized = FALSE;
2079 prepare_console_and_stdio("CONOUT$", _O_WRONLY | _O_BINARY,
2080 STD_OUTPUT_HANDLE, 1, &initialized);
2081 return file_flusher(p, cnt, forcep);
2082 }
2083
trapper_flusher2(ScmPort * p,ScmSize cnt,int forcep)2084 static ScmSize trapper_flusher2(ScmPort *p, ScmSize cnt, int forcep)
2085 {
2086 static int initialized = FALSE;
2087 prepare_console_and_stdio("CONOUT$", _O_WRONLY | _O_BINARY,
2088 STD_ERROR_HANDLE, 2, &initialized);
2089 return file_flusher(p, cnt, forcep);
2090 }
2091
make_trapper_port(ScmObj name,int direction,int fd,int bufmode)2092 static ScmObj make_trapper_port(ScmObj name, int direction,
2093 int fd, int bufmode)
2094 {
2095 ScmPortBuffer bufrec;
2096
2097 bufrec.buffer = NULL;
2098 bufrec.size = 0;
2099 bufrec.mode = bufmode;
2100 if (fd == 0) {
2101 bufrec.filler = trapper_filler;
2102 } else {
2103 bufrec.filler = NULL;
2104 }
2105 if (fd == 1) {
2106 bufrec.flusher = trapper_flusher1;
2107 } else if (fd == 2) {
2108 bufrec.flusher = trapper_flusher2;
2109 } else {
2110 bufrec.flusher = NULL;
2111 }
2112 bufrec.closer = file_closer;
2113 bufrec.ready = file_ready;
2114 bufrec.filenum = file_filenum;
2115 file_port_data *data = SCM_NEW(file_port_data);
2116 data->fd = fd;
2117 bufrec.data = data;
2118 bufrec.seeker = NULL;
2119 ScmObj p = Scm_MakeBufferedPort(SCM_CLASS_PORT, name, direction, TRUE,
2120 &bufrec);
2121 return p;
2122 }
2123
2124 /* This is supposed to be called from application main(), before any
2125 threads are created. We don't mutex here. */
Scm__SetupPortsForWindows(int has_console)2126 void Scm__SetupPortsForWindows(int has_console)
2127 {
2128 if (!has_console) {
2129 static int initialized = FALSE;
2130 static volatile ScmObj orig_stdin = SCM_FALSE;
2131 static volatile ScmObj orig_stdout = SCM_FALSE;
2132 static volatile ScmObj orig_stderr = SCM_FALSE;
2133 if (!initialized) {
2134 initialized = TRUE;
2135 SCM_INTERNAL_MUTEX_INIT(win_console_mutex);
2136 /* Original scm_stdout and scm_stderr holds ports that are
2137 connected to fd=0 and fd=1, respectively. Losing reference
2138 to those ports will eventually lead to close those fds (when
2139 those ports are GC-ed), causing complications in the code
2140 that assumes fds 0, 1 and 2 are reserved. To make things
2141 easier, we just save the original ports. */
2142 orig_stdin = scm_stdin;
2143 orig_stdout = scm_stdout;
2144 orig_stderr = scm_stderr;
2145 /* We know the destination is allocated Windows Console, so we
2146 just use fixed buffered modes. */
2147 scm_stdin = make_trapper_port(SCM_MAKE_STR("(standard input)"),
2148 SCM_PORT_INPUT, 0,
2149 SCM_PORT_BUFFER_FULL);
2150 scm_stdout = make_trapper_port(SCM_MAKE_STR("(standard output)"),
2151 SCM_PORT_OUTPUT, 1,
2152 SCM_PORT_BUFFER_LINE);
2153 scm_stderr = make_trapper_port(SCM_MAKE_STR("(standard error output)"),
2154 SCM_PORT_OUTPUT, 2,
2155 SCM_PORT_BUFFER_NONE);
2156 Scm_VM()->curin = SCM_PORT(scm_stdin);
2157 Scm_VM()->curout = SCM_PORT(scm_stdout);
2158 Scm_VM()->curerr = SCM_PORT(scm_stderr);
2159 }
2160 (void)orig_stdin; /* suppress unused var warning */
2161 (void)orig_stdout; /* suppress unused var warning */
2162 (void)orig_stderr; /* suppress unused var warning */
2163 }
2164 }
2165 #endif /*defined(GAUCHE_WINDOWS)*/
2166